tinymsg.scm

   1 ;;; tinymsg, a GNU Guile messages module for communicating threads
   2 ;;; Copyright (C) 2015 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation, either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 (define-module (tinymsg)
  19   #:use-module (ice-9 q)
  20   #:use-module (ice-9 threads)
  21   #:use-module (ice-9 vlist)
  22   #:use-module (srfi srfi-9)
  23   #:export (send-message
  24             receive-message
  25             wait-message
  26             flush-messages))
  27
  28
  29 (define-record-type <msgbox>
  30   (make-msgbox mutex condvar queue)
  31   msgbox?
  32   (mutex    msgbox-mutex)
  33   (condvar  msgbox-condvar)
  34   (queue    msgbox-queue))
  35
  36 (define msgboxes vlist-null)
  37 (define msgboxes-mutex (make-recursive-mutex))
  38
  39 (define (new-msgbox name)
  40   "Create a new msgbox for receiving messages"
  41   (with-mutex msgboxes-mutex
  42     (let ((msgbox (make-msgbox (make-mutex) (make-condition-variable) (make-q))))
  43       (set! msgboxes (vhash-cons name msgbox msgboxes))
  44       msgbox)))
  45
  46 (define (get-msgbox name)
  47   "Get a msgbox or create a new one if doesn't exists"
  48   (with-mutex msgboxes-mutex
  49     (let ((msgbox (vhash-assoc name msgboxes)))
  50       (cond (msgbox
  51              (cdr msgbox))
  52             (else
  53              (new-msgbox name))))))
  54
  55 (define (send-message to message)
  56   "Get msgbox from destination and queue the message"
  57   (let ((msgbox (get-msgbox to)))
  58     (with-mutex (msgbox-mutex msgbox)
  59       (enq! (msgbox-queue msgbox) message)
  60       (signal-condition-variable (msgbox-condvar msgbox))))
  61   message)
  62
  63 (define (receive-message name)
  64   "Get msgbox and retrieve a message without waiting"
  65   (let ((msgbox (get-msgbox name)))
  66     (with-mutex (msgbox-mutex msgbox)
  67       (let ((queue (msgbox-queue msgbox)))
  68         (if (not (q-empty? queue))
  69             (deq! queue))))))
  70
  71 (define (wait-message name)
  72   "Get msgbox and wait for a message"
  73   (let ((msgbox (get-msgbox name)))
  74     (let ((mutex (msgbox-mutex msgbox))
  75           (condvar (msgbox-condvar msgbox))
  76           (queue (msgbox-queue msgbox)))
  77       (with-mutex mutex
  78         (if (or (not (q-empty? queue))
  79                 (wait-condition-variable condvar mutex))
  80             (deq! queue))))))
  81
  82 (define (flush-messages name)
  83   "Print all messages from the msgbox"
  84   (let ((msgbox (get-msgbox name)))
  85     (with-mutex (msgbox-mutex msgbox)
  86       (let flush ((queue (msgbox-queue msgbox)))
  87         (cond ((not (q-empty? queue))
  88                (format #t "~a got ~a~%" name (deq! queue))
  89                (flush queue)))))))