summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--2d/mvars.scm173
-rw-r--r--2d/repl/repl.scm4
2 files changed, 88 insertions, 89 deletions
diff --git a/2d/mvars.scm b/2d/mvars.scm
index 70674a4..77461ae 100644
--- a/2d/mvars.scm
+++ b/2d/mvars.scm
@@ -20,118 +20,104 @@
;;; Code:
(define-module (2d mvars)
- #:use-module (srfi srfi-8) ; receive
- #:use-module (srfi srfi-9) ; records
- #:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 threads)
- #:export (new-mvar mvar? mvar-empty?
- take-mvar put-mvar read-mvar swap-mvar
- try-take-mvar try-put-mvar try-read-mvar
- with-mvar modify-mvar modify-mvar*))
+ #:use-module (srfi srfi-8) ; receive
+ #:use-module (srfi srfi-9) ; records
+ #:use-module (srfi srfi-9 gnu)
+ #:export (mvar?
+ mvar-empty? new-empty-mvar new-mvar
+ take-mvar put-mvar read-mvar swap-mvar
+ try-take-mvar try-put-mvar
+ with-mvar modify-mvar modify-mvar*))
(define-record-type <mvar>
- (make-mvar contents empty? mutex condvar)
+ (make-mvar contents empty? mutex full-condition empty-condition)
mvar?
- (contents mvar-contents set-mvar-contents!)
- (empty? mvar-empty? set-mvar-empty?!)
- (mutex mvar-mutex)
- (condvar mvar-condvar))
+ (contents %mvar-contents %set-mvar-contents!)
+ (empty? %mvar-empty? %set-mvar-empty?!)
+ (mutex mvar-mutex)
+ (full-condition mvar-full-condition)
+ (empty-condition mvar-empty-condition))
-(set-record-type-printer!
- <mvar>
- (lambda (mvar port)
- (display "#<mvar " port)
- (display (number->string (object-address mvar) 16) port)
- (display " " port)
- (write (receive (x full?) (try-read-mvar mvar)
- (if full? (list x) '()))
- port)
- (display ">" port)))
-
-(define new-mvar
- (case-lambda
- "Return a freshly allocated mvar. The optional argument, if provided,\n\
-specifies the initial contents of the mvar, otherwise it will be empty."
- (() (make-mvar #f #t (make-mutex) (make-condition-variable)))
- ((x) (make-mvar x #f (make-mutex) (make-condition-variable)))))
+(define (mvar-empty? mvar)
+ (with-mutex (mvar-mutex mvar)
+ (%mvar-empty? mvar)))
+
+(define (new-empty-mvar)
+ "Return a freshly allocated mvar that is initially empty."
+ (make-mvar #f ; contents
+ #t ; empty?
+ (make-mutex)
+ (make-condition-variable)
+ (make-condition-variable)))
+
+(define (new-mvar x)
+ "Return a freshly allocated mvar with initial contents X."
+ (make-mvar x ; contents
+ #f ; empty?
+ (make-mutex)
+ (make-condition-variable)
+ (make-condition-variable)))
(define (take-mvar mvar)
"Block until MVAR is full, then atomically remove and return its contents."
(with-mutex (mvar-mutex mvar)
- (when (mvar-empty? mvar)
- (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
- (when (mvar-empty? mvar)
- (error "take-mvar: expected full mvar after waiting")))
- (let ((x (mvar-contents mvar)))
- (set-mvar-contents! mvar #f)
- (set-mvar-empty?! mvar #t)
- (signal-condition-variable (mvar-condvar mvar))
+ (when (%mvar-empty? mvar)
+ (wait-condition-variable (mvar-full-condition mvar) (mvar-mutex mvar)))
+ (let ((x (%mvar-contents mvar)))
+ (%set-mvar-contents! mvar #f)
+ (%set-mvar-empty?! mvar #t)
+ (signal-condition-variable (mvar-empty-condition mvar))
x)))
(define (put-mvar mvar x)
"Block until MVAR is empty, then put X into it."
(with-mutex (mvar-mutex mvar)
- (unless (mvar-empty? mvar)
- (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
- (unless (mvar-empty? mvar)
- (error "put-mvar: expected empty mvar after waiting")))
- (set-mvar-contents! mvar x)
- (set-mvar-empty?! mvar #f)
- (signal-condition-variable (mvar-condvar mvar))
+ (unless (%mvar-empty? mvar)
+ (wait-condition-variable (mvar-empty-condition mvar) (mvar-mutex mvar)))
+ (%set-mvar-contents! mvar x)
+ (%set-mvar-empty?! mvar #f)
+ (signal-condition-variable (mvar-full-condition mvar))
*unspecified*))
(define (read-mvar mvar)
- "Block until MVAR is full, then return its contents, leaving MVAR unchanged."
- (with-mutex (mvar-mutex mvar)
- (when (mvar-empty? mvar)
- (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
- (when (mvar-empty? mvar)
- (error "read-mvar: expected full mvar after waiting")))
- (mvar-contents mvar)))
-
-(define (swap-mvar mvar new)
- "Block until MVAR is full, and then atomically swap its contents\n\
-with NEW and return the previous contents."
- (with-mutex (mvar-mutex mvar)
- (when (mvar-empty? mvar)
- (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar))
- (when (mvar-empty? mvar)
- (error "swap-mvar: expected full mvar after waiting")))
- (let ((old (mvar-contents mvar)))
- (set-mvar-contents! mvar new)
- old)))
+ "Take a value x from MVAR, then put it back and return x. This
+procedure is atomic only if there are no other producers for MVAR."
+ (let ((x (take-mvar mvar)))
+ (put-mvar mvar x)
+ x))
+
+(define (swap-mvar mvar y)
+ "Take a value x from MVAR, then put Y into MVAR and return x. This
+procedure is atomic only if there are no other producers for MVAR."
+ (let ((x (take-mvar mvar)))
+ (put-mvar mvar y)
+ x))
(define (try-take-mvar mvar)
"If MVAR is full, return its contents and #t, else return #f and #f."
(with-mutex (mvar-mutex mvar)
- (if (mvar-empty? mvar)
+ (if (%mvar-empty? mvar)
(values #f #f)
- (let ((x (mvar-contents mvar)))
- (set-mvar-contents! mvar #f)
- (set-mvar-empty?! mvar #t)
- (signal-condition-variable (mvar-condvar mvar))
+ (let ((x (%mvar-contents mvar)))
+ (%set-mvar-contents! mvar #f)
+ (%set-mvar-empty?! mvar #t)
+ (signal-condition-variable (mvar-empty-condition mvar))
(values x #t)))))
(define (try-put-mvar mvar x)
"If MVAR is empty, put X into it and return #t, else return #f."
(with-mutex (mvar-mutex mvar)
- (and (mvar-empty? mvar)
+ (and (%mvar-empty? mvar)
(begin
- (set-mvar-contents! mvar x)
- (set-mvar-empty?! mvar #f)
- (signal-condition-variable (mvar-condvar mvar))
+ (%set-mvar-contents! mvar x)
+ (%set-mvar-empty?! mvar #f)
+ (signal-condition-variable (mvar-full-condition mvar))
#t))))
-(define (try-read-mvar mvar)
- "If MVAR is full, return its contents and #t, else return #f and #f."
- (with-mutex (mvar-mutex mvar)
- (if (mvar-empty? mvar)
- (values #f #f)
- (values (mvar-contents mvar) #t))))
-
(define (with-mvar mvar proc)
- "Take a value from MVAR and apply PROC to it. If an exception is raised,\n\
-the original value is put back into MVAR. This procedure is atomic only if\n\
+ "Take a value from MVAR and apply PROC to it. If an exception is raised,
+the original value is put back into MVAR. This procedure is atomic only if
there are no other producers for MVAR."
(let ((x (take-mvar mvar)))
(catch #t
@@ -141,8 +127,8 @@ there are no other producers for MVAR."
(apply throw key args)))))
(define (modify-mvar mvar f)
- "Take a value x from MVAR, and then put back (F x). If an exception is\n\
-raised, the original value is put back into MVAR. This procedure is\n\
+ "Take a value x from MVAR, and then put back (F x). If an exception is
+raised, the original value is put back into MVAR. This procedure is
atomic only if there are no other producers for MVAR."
(let ((old (take-mvar mvar)))
(catch #t
@@ -152,10 +138,10 @@ atomic only if there are no other producers for MVAR."
(apply throw key args)))))
(define (modify-mvar* mvar f)
- "Take a value x from MVAR, and apply F to it. (F x) should return one\n\
-or more values: the new value to be put back into MVAR, and zero or more\n\
-additional values to be returned from MODIFY-MVAR*. If an exception is\n\
-raised, the original value is put back into MVAR. This procedure is\n\
+ "Take a value x from MVAR, and apply F to it. (F x) should return one
+or more values: the new value to be put back into MVAR, and zero or more
+additional values to be returned from MODIFY-MVAR*. If an exception is
+raised, the original value is put back into MVAR. This procedure is
atomic only if there are no other producers for MVAR."
(let ((old (take-mvar mvar)))
(catch #t
@@ -166,3 +152,16 @@ atomic only if there are no other producers for MVAR."
(lambda (key . args)
(put-mvar mvar old)
(apply throw key args)))))
+
+(set-record-type-printer!
+ <mvar>
+ (lambda (mvar port)
+ (display "#<mvar " port)
+ (display (number->string (object-address mvar) 16) port)
+ (display " " port)
+ (write (with-mutex (mvar-mutex mvar)
+ (if (%mvar-empty? mvar)
+ '()
+ (list (%mvar-contents mvar))))
+ port)
+ (display ">" port)))
diff --git a/2d/repl/repl.scm b/2d/repl/repl.scm
index 253789d..4ff8f52 100644
--- a/2d/repl/repl.scm
+++ b/2d/repl/repl.scm
@@ -130,8 +130,8 @@
;;; The repl
;;;
-(define repl-input-mvar (new-mvar))
-(define repl-output-mvar (new-mvar))
+(define repl-input-mvar (new-empty-mvar))
+(define repl-output-mvar (new-empty-mvar))
(define* (start-repl #:optional (lang (current-language)) #:key debug)
;; ,language at the REPL will update the current-language. Make