Mutexes and condition variables with names (#380)

add name fields for mutexes and condition variables, now `make-mutex` and `make-condition` accept an optional argument `name`, which must be a symbol or #f.  The name, if not #f, is printed every time the object is printed, which is useful for debugging.
original commit: 1397e173200d1697ed714d24fc2eb4767421b976

LOG

@@ -1254,3 +1254,9 @@
 - ignore multiple-value return from interleaved init expressions in
   top-level-program
     syntax.ss, 8.ms
+- add name fields for mutexes and condition variables, now `make-mutex` and
+  `make-condition` accept an optional argument `name`, which must be a
+  symbol or #f.  The name, if not #f, is printed every time the object is
+  printed, which is useful for debugging
+    primdata.ss prims.ss print.ss
+    thread.ms threads.stex

csug/threads.stex

@@ -123,10 +123,16 @@ in all threads.
 %----------------------------------------------------------------------------
 \noskipentryheader
 \formdef{make-mutex}{\categoryprocedure}{(make-mutex)}
+\formdef{make-mutex}{\categoryprocedure}{(make-mutex \var{name})}
 \returns a new mutex object
 \listlibraries
 \endnoskipentryheader
 
+\noindent
+\var{name}, if supplied, must be a symbol which identifies the mutex, or
+\scheme{#f} for no name. The name is printed every time the mutex is
+printed, which is useful for debugging.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{mutex?}{\categoryprocedure}{(mutex? \var{obj})}
@@ -207,10 +213,16 @@ Using \scheme{with-mutex} is generally more convenient and safer than using
 %----------------------------------------------------------------------------
 \noskipentryheader
 \formdef{make-condition}{\categoryprocedure}{(make-condition)}
+\formdef{make-condition}{\categoryprocedure}{(make-condition \var{name})}
 \returns a new condition object
 \listlibraries
 \endnoskipentryheader
 
+\noindent
+\var{name}, if supplied, must be a symbol which identifies the condition
+object, or \scheme{#f} for no name. The name is printed every time the
+condition is printed, which is useful for debugging.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{thread-condition?}{\categoryprocedure}{(thread-condition? \var{obj})}

mats/thread.ms

@@ -82,11 +82,20 @@
 
 (when-threaded
 (mat thread
-  (let ([m (make-mutex)] [c (make-condition)])
+  (let ([m (make-mutex)] [c (make-condition)]
+        [m2 (make-mutex 'mname)] [c2 (make-condition 'cname)])
     (and (mutex? m)
          (thread-condition? c)
+         (mutex? m2)
+         (thread-condition? c2)
          (not (mutex? c))
          (not (thread-condition? m))
+         (not (mutex? c2))
+         (not (thread-condition? m2))
+         (not (mutex-name m))
+         (not (condition-name c))
+         (eq? 'mname (mutex-name m2))
+         (eq? 'cname (condition-name c2))
          (not (mutex? 'mutex))
          (not (thread-condition? 'condition))))
   (begin

release_notes/release_notes.stex

@@ -58,6 +58,14 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{Mutexes and condition variables can have names (9.5.3)}
+
+The procedures \scheme{make-mutex} and \scheme{make-condition} now
+accept an optional argument \scheme{name}, which must be a symbol
+that identifies the object or \scheme{f} for no name. The name is
+printed every time the mutex or condition object is printed, which
+is useful for debugging.
+
 \subsection{Improved packaging support (9.5.1)}
 
 The Chez Scheme \scheme{Makefile} has been enhanced with new targets for

s/primdata.ss

@@ -1220,6 +1220,7 @@
   (compute-size [sig [(ptr) -> (uint)] [(ptr sub-ufixnum) -> (uint)]] [flags alloc])
   (condition-broadcast [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
   (condition-continuation [sig [(continuation-condition) -> (ptr)]] [flags pure mifoldable discard])
+  (condition-name [feature pthreads] [sig [(condition-object) -> (maybe-symbol)]] [flags pure])
   (condition-signal [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
   (condition-wait [feature pthreads] [sig [(condition-object mutex) (condition-object mutex timeout) -> (boolean)]] [flags])
   (conjugate [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
@@ -1429,7 +1430,7 @@
   (make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true])
   (make-boot-header [sig [(pathname pathname pathname ...) -> (void)]] [flags true])
   (make-compile-time-value [sig [(ptr) -> (compile-time-value)]] [flags pure unrestricted alloc])
-  (make-condition [feature pthreads] [sig [() -> (condition-object)]] [flags pure unrestricted alloc])
+  (make-condition [feature pthreads] [sig [() (maybe-symbol) -> (condition-object)]] [flags pure unrestricted alloc])
   (make-continuation-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
   (make-cost-center [sig [() -> (cost-center)]] [flags unrestricted alloc])
   (make-ephemeron-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
@@ -1442,7 +1443,7 @@
   (make-input-port [sig [(procedure string) -> (textual-input-port)]] [flags alloc])
   (make-input/output-port [sig [(procedure string string) -> (textual-input/output-port)]] [flags alloc])
   (make-list [sig [(length) (length ptr) -> (list)]] [flags alloc])
-  (make-mutex [feature pthreads] [sig [() -> (mutex)]] [flags unrestricted alloc])
+  (make-mutex [feature pthreads] [sig [() (maybe-symbol) -> (mutex)]] [flags unrestricted alloc])
   (make-object-finder [sig [(procedure) (procedure ptr) (procedure ptr sub-ufixnum) -> (procedure)]] [flags alloc])
   (make-output-port [sig [(procedure string) -> (textual-output-port)]] [flags alloc])
   (make-parameter [sig [(ptr) (ptr procedure) -> (procedure)]] [flags true cp02 cp03])
@@ -1469,6 +1470,7 @@
   (mutable-bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (mutable-vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (mutex-acquire [feature pthreads] [sig [(mutex) (mutex ptr) -> (ptr)]] [flags]) ; can return #f if optional block? arg is #f
+  (mutex-name [feature pthreads] [sig [(mutex) -> (maybe-symbol)]] [flags pure])
   (mutex-release [feature pthreads] [sig [(mutex) -> (void)]] [flags true])
   (mutex? [feature pthreads] [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (new-cafe [sig [() (procedure) -> (ptr ...)]] [flags])

s/prims.ss

@@ -1484,10 +1484,12 @@
 (define fork-thread)
 (define make-mutex)
 (define mutex?)
+(define mutex-name)
 (define mutex-acquire)
 (define mutex-release)
 (define make-condition)
 (define thread-condition?)
+(define condition-name)
 (define condition-wait)
 (define condition-signal)
 (define condition-broadcast)
@@ -1512,15 +1514,29 @@
 (define cs (foreign-procedure "(cs)condition_signal" (scheme-object) void))
 
 (define-record-type (condition $make-condition $condition?)
-  (fields (mutable addr $condition-addr $condition-addr-set!))
+  (fields (mutable addr $condition-addr $condition-addr-set!)
+          (immutable name $condition-name))
   (nongenerative)
   (sealed #t))
 
 (define-record-type (mutex $make-mutex $mutex?)
-  (fields (mutable addr $mutex-addr $mutex-addr-set!))
+  (fields (mutable addr $mutex-addr $mutex-addr-set!)
+          (immutable name $mutex-name))
   (nongenerative)
   (sealed #t))
 
+(define make-mutex-no-check
+  (lambda (name)
+    (let ([m ($make-mutex (mm) name)])
+      (mutex-guardian m)
+      m)))
+
+(define make-condition-no-check
+  (lambda (name)
+    (let ([c ($make-condition (mc) name)])
+      (condition-guardian c)
+      c)))
+
 (define mutex-guardian (make-guardian))
 (define condition-guardian (make-guardian))
 
@@ -1539,16 +1555,22 @@
                 (t)
                 (void))))))))
 
-(set! make-mutex
+(set-who! make-mutex
-  (lambda ()
+  (case-lambda
-    (let ([m ($make-mutex (mm))])
+    [() (make-mutex-no-check #f)]
-      (mutex-guardian m)
+    [(name)
-      m)))
+     (unless (or (not name) (symbol? name)) ($oops who "~s is not a symbol or #f" name))
+     (make-mutex-no-check name)]))
 
 (set! mutex?
   (lambda (x)
     ($mutex? x)))
 
+(set-who! mutex-name
+  (lambda (m)
+    (unless (mutex? m) ($oops who "~s is not a mutex" m))
+    ($mutex-name m)))
+
 (set! mutex-acquire
   (case-lambda
     [(m) (mutex-acquire m #t)]
@@ -1571,16 +1593,22 @@
         ($oops 'mutex-release "mutex is defunct"))
       (mr addr))))
 
-(set! make-condition
+(set-who! make-condition
-  (lambda ()
+  (case-lambda
-    (let ([c ($make-condition (mc))])
+    [() (make-condition-no-check #f)]
-      (condition-guardian c)
+    [(name)
-      c)))
+     (unless (or (not name) (symbol? name)) ($oops who "~s is not a symbol or #f" name))
+     (make-condition-no-check name)]))
 
 (set! thread-condition?
   (lambda (x)
     ($condition? x)))
 
+(set-who! condition-name
+  (lambda (c)
+    (unless (thread-condition? c) ($oops who "~s is not a condition" c))
+    ($condition-name c)))
+
 (set! condition-wait
   (case-lambda
    [(c m) (condition-wait c m #f)]
@@ -1640,8 +1668,8 @@
               ($condition-addr-set! c 0)))
           (f))))))
 
-(set! $tc-mutex ($make-mutex ($raw-tc-mutex)))
+(set! $tc-mutex ($make-mutex ($raw-tc-mutex) '$tc-mutex))
-(set! $collect-cond ($make-condition ($raw-collect-cond)))
+(set! $collect-cond ($make-condition ($raw-collect-cond) '$collect-cond))
 ))
 
 (let ()

s/print.ss

@@ -592,10 +592,14 @@ floating point returns with (1 0 -1 ...).
      (if-feature pthreads
        (begin
          (define $condition? thread-condition?)
-         (define $mutex? mutex?))
+         (define $condition-name condition-name)
+         (define $mutex? mutex?)
+         (define $mutex-name mutex-name))
        (begin
          (define $condition? (lambda (x) #f))
-         (define $mutex? (lambda (x) #f))))
+         (define $condition-name (lambda (x) #f))
+         (define $mutex? (lambda (x) #f))
+         (define $mutex-name (lambda (x) #f))))
      (cond
        [($immediate? x)
         (type-case x
@@ -651,8 +655,22 @@ floating point returns with (1 0 -1 ...).
           [(bytevector?) (wrvector bytevector-length bytevector-u8-ref "vu8" x r lev len d? env p)]
           [(flonum?) (wrflonum #f x r d? p)]
           ; catch before record? case
-          [($condition?) (display-string "#<condition>" p)]
+          [($condition?)
-          [($mutex?) (display-string "#<mutex>" p)]
+           (cond
+            (($condition-name x) =>
+             (lambda (name)
+               (display-string "#<condition " p)
+               (wrsymbol (symbol->string name) p)
+               (write-char #\> p)))
+            (else (display-string "#<condition>" p)))]
+          [($mutex?)
+           (cond
+            (($mutex-name x) =>
+             (lambda (name)
+               (display-string "#<mutex " p)
+               (wrsymbol (symbol->string name) p)
+               (write-char #\> p)))
+            (else (display-string "#<mutex>" p)))]
           [(base-rtd?) (display-string "#!base-rtd" p)]
           [($record?)
            (if (print-record)