mutexes and conditions are now freed when no longer used

added $close-resurrected-mutexes&conditions and $keep-live

original commit: 8d9aa4dffc371fc365020e5dac62270dae2aaa95

LOG

@@ -440,3 +440,7 @@
     use.stex, scheme.1.in
 - destroy_thread now processes guardian entries
     thread.c, 4.ms, release_notes.stex
+- mutexes and conditions are now freed when no longer used via
+  $close-resurrected-mutexes&conditions, $keep-live primitive added
+    externs.h, prim5.c, thread.c, 4.ms, thread.ms, release_notes.stex,
+    7.ss, cpnanopass.ss, np-languages.ss, primdata.ss, prims.ss

c/externs.h

@@ -203,10 +203,12 @@ extern ptr S_create_thread_object PROTO((const char *who, ptr p_tc));
 #ifdef PTHREADS
 extern ptr S_fork_thread PROTO((ptr thunk));
 extern scheme_mutex_t *S_make_mutex PROTO((void));
+extern void S_mutex_free PROTO((scheme_mutex_t *m));
 extern void S_mutex_acquire PROTO((scheme_mutex_t *m));
 extern INT S_mutex_tryacquire PROTO((scheme_mutex_t *m));
 extern void S_mutex_release PROTO((scheme_mutex_t *m));
 extern s_thread_cond_t *S_make_condition PROTO((void));
+extern void S_condition_free PROTO((s_thread_cond_t *c));
 extern IBOOL S_condition_wait PROTO((s_thread_cond_t *c, scheme_mutex_t *m, ptr t));
 #endif
 

c/prim5.c

@@ -1447,12 +1447,14 @@ void S_prim5_init() {
 #ifdef PTHREADS
     Sforeign_symbol("(cs)fork_thread", (void *)S_fork_thread);
     Sforeign_symbol("(cs)make_mutex", (void *)S_make_mutex);
+    Sforeign_symbol("(cs)mutex_free", (void *)S_mutex_free);
     Sforeign_symbol("(cs)backdoor_thread", (void *)s_backdoor_thread);
     Sforeign_symbol("(cs)threads", (void *)s_threads);
     Sforeign_symbol("(cs)mutex_acquire", (void *)s_mutex_acquire);
     Sforeign_symbol("(cs)mutex_release", (void *)S_mutex_release);
     Sforeign_symbol("(cs)mutex_acquire_noblock", (void *)s_mutex_acquire_noblock);
     Sforeign_symbol("(cs)make_condition", (void *)S_make_condition);
+    Sforeign_symbol("(cs)condition_free", (void *)S_condition_free);
     Sforeign_symbol("(cs)condition_broadcast", (void *)s_condition_broadcast);
     Sforeign_symbol("(cs)condition_signal", (void *)s_condition_signal);
     Sforeign_symbol("(cs)condition_wait", (void *)S_condition_wait);

c/thread.c

@@ -259,6 +259,11 @@ scheme_mutex_t *S_make_mutex() {
   return m;
 }
 
+void S_mutex_free(m) scheme_mutex_t *m; {
+  s_thread_mutex_destroy(&m->pmutex);
+  free(m);
+}
+
 void S_mutex_acquire(m) scheme_mutex_t *m; {
   s_thread_t self = s_thread_self();
   iptr count;
@@ -322,6 +327,11 @@ s_thread_cond_t *S_make_condition() {
   return c;
 }
 
+void S_condition_free(c) s_thread_cond_t *c; {
+  s_thread_cond_destroy(c);
+  free(c);
+}
+
 #ifdef FEATURE_WINDOWS
 
 static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, long sec, long nsec) {

mats/4.ms

@@ -2993,12 +2993,20 @@
              (list ((g1)) p)))))
      '((c d) (b)))
 
+   (eq? (with-interrupts-disabled
+          (let* ([g (make-guardian)] [x (list 'a 'b)])
+            (g x)
+            (collect 0 0)
+            (#%$keep-live x)
+            (g)))
+        #f)
+
    (or (not (threaded?))
        (equal?
          (parameterize ([collect-request-handler void])
            (let ([g (make-guardian)])
              (fork-thread (lambda () (g (list 'a 'b))))
-             (let f () (when (> #%$active-threads 1) (f)))
+             (let f () (when (> (length (#%$thread-list)) 1) (f)))
              (collect)
              (g)))
          '(a b)))

mats/thread.ms

@@ -1435,6 +1435,27 @@
                 (condition-wait c m)
                 (loop))))))
     -1.5)
+  ($thread-check)
+  (parameterize ([collect-request-handler void])
+    (define (expect-error what thunk)
+      (guard (c [(and (message-condition? c)
+                      (equal? (condition-message c)
+                        (format "~a is defunct" what)))])
+        (thunk)
+        (error #f "error expected")))
+    (let ([g (make-guardian)])
+      (g (make-mutex))
+      (collect)
+      (let ([m (g)])
+        (expect-error 'mutex (lambda () (mutex-acquire m)))
+        (expect-error 'mutex (lambda () (mutex-release m)))
+        (expect-error 'mutex (lambda () (condition-wait (make-condition) m))))
+      (g (make-condition))
+      (collect)
+      (let ([c (g)])
+        (expect-error 'condition (lambda () (condition-wait c (make-mutex))))
+        (expect-error 'condition (lambda () (condition-broadcast c)))
+        (expect-error 'condition (lambda () (condition-signal c))))))
  )
 
 (mat make-thread-parameter

release_notes/release_notes.stex

@@ -1490,6 +1490,11 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Storage for inaccessible mutexes and conditions is reclaimed (9.4.1)}
+
+The C heap storage for inaccessible mutexes and conditions is now reclaimed.
+[This bug dated back to Version 6.5.]
+
 \subsection{Missing guardian entries when a thread exits (9.4.1)}
 
 A bug that causes guardian entries for a thread to be lost when a

s/7.ss

@@ -671,6 +671,8 @@
                 (flush-output-port (console-output-port)))
               (do-gc g gtarget)
               ($close-resurrected-files)
+              (when-feature pthreads
+                ($close-resurrected-mutexes&conditions))
               (when (collect-notify)
                 (fprintf (console-output-port) "done]~%")
                 (flush-output-port (console-output-port)))

s/cpnanopass.ss

@@ -3729,6 +3729,8 @@
           [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)])
         (define-inline 2 eq?
           [(e1 e2) (%inline eq? ,e1 ,e2)])
+        (define-inline 2 $keep-live
+          [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))])
         (let ()
           (define (zgo src sexpr e e1 e2 r6rs?)
             (build-simple-or

s/np-languages.ss

@@ -494,6 +494,7 @@
   (declare-primitive inc-cc-counter effect #f)
   (declare-primitive inc-profile-counter effect #f)
   (declare-primitive invoke-prelude effect #f)
+  (declare-primitive keep-live effect #f)
   (declare-primitive load-double effect #f)
   (declare-primitive load-double->single effect #f)
   (declare-primitive load-single effect #f)
@@ -1049,4 +1050,9 @@
           (_ var ('extends x) #f (_ _ #f ...) ...)))
      (pretty-format 'labels '(_ ([bracket x e] 0 ...) #f e ...))
      (pretty-format 'blocks '(_ #f [bracket (x ...) 0 e] ...))])
+
+  (primitive-handler-set! %keep-live
+    (lambda (info x)
+      (with-output-language (L15d Effect)
+        `(asm ,info ,(lambda (code*) code*)))))
 )

s/primdata.ss

@@ -1710,6 +1710,7 @@
   ($clear-pass-stats [flags])
   ($close-files [flags])
   ($close-resurrected-files [flags])
+  ($close-resurrected-mutexes&conditions [feature pthreads] [flags])
   ($closure-code [flags])
   ($closure-length [flags])
   ($closure-ref [flags])
@@ -1999,6 +2000,7 @@
   ($invoke-library [flags])
   ($invoke-program [flags])
   ($io-init [flags])
+  ($keep-live [flags])
   ($last-new-vector-element [flags])
   ($lexical-error [flags])
   ($library-requirements-options [flags])

s/prims.ss

@@ -1460,6 +1460,7 @@
 (define condition-wait)
 (define condition-signal)
 (define condition-broadcast)
+(define $close-resurrected-mutexes&conditions)
 (define $tc-mutex)
 (define $collect-cond)
 (let ()
@@ -1468,25 +1469,30 @@
 (define ft (foreign-procedure "(cs)fork_thread" (scheme-object)
               scheme-object))
 (define mm (foreign-procedure "(cs)make_mutex" () scheme-object))
+(define mf (foreign-procedure "(cs)mutex_free" (scheme-object) void))
 (define ma (foreign-procedure "(cs)mutex_acquire" (scheme-object) void))
 (define ma-nb (foreign-procedure "(cs)mutex_acquire_noblock" (scheme-object)
                   scheme-object))
 (define mr (foreign-procedure "(cs)mutex_release" (scheme-object) void))
 (define mc (foreign-procedure "(cs)make_condition" () scheme-object))
+(define cf (foreign-procedure "(cs)condition_free" (scheme-object) void))
 (define cw (foreign-procedure "(cs)condition_wait" (scheme-object scheme-object scheme-object) boolean))
 (define cb (foreign-procedure "(cs)condition_broadcast" (scheme-object) void))
 (define cs (foreign-procedure "(cs)condition_signal" (scheme-object) void))
 
 (define-record-type (condition $make-condition $condition?)
-  (fields (immutable addr $condition-addr))
+  (fields (mutable addr $condition-addr $condition-addr-set!))
   (nongenerative)
   (sealed #t))
 
 (define-record-type (mutex $make-mutex $mutex?)
-  (fields (immutable addr $mutex-addr))
+  (fields (mutable addr $mutex-addr $mutex-addr-set!))
   (nongenerative)
   (sealed #t))
 
+(define mutex-guardian (make-guardian))
+(define condition-guardian (make-guardian))
+
 (set! fork-thread
   (lambda (t)
     (unless (procedure? t)
@@ -1504,7 +1510,9 @@
 
 (set! make-mutex
   (lambda ()
-    ($make-mutex (mm))))
+    (let ([m ($make-mutex (mm))])
+      (mutex-guardian m)
+      m)))
 
 (set! mutex?
   (lambda (x)
@@ -1516,17 +1524,27 @@
     [(m block?)
      (unless (mutex? m)
        ($oops 'mutex-acquire "~s is not a mutex" m))
-     ((if block? ma ma-nb) ($mutex-addr m))]))
+     (let ([addr ($mutex-addr m)])
+       (when (eq? addr 0)
+         ($oops 'mutex-acquire "mutex is defunct"))
+       (let ([r ((if block? ma ma-nb) addr)])
+         ($keep-live m)
+         r))]))
 
 (set! mutex-release
   (lambda (m)
     (unless (mutex? m)
       ($oops 'mutex-release "~s is not a mutex" m))
-    (mr ($mutex-addr m))))
+    (let ([addr ($mutex-addr m)])
+      (when (eq? addr 0)
+        ($oops 'mutex-release "mutex is defunct"))
+      (mr addr))))
 
 (set! make-condition
   (lambda ()
-    ($make-condition (mc))))
+    (let ([c ($make-condition (mc))])
+      (condition-guardian c)
+      c)))
 
 (set! thread-condition?
   (lambda (x)
@@ -1543,19 +1561,53 @@
     (unless (or (not t)
 		(and (time? t) (memq (time-type t) '(time-duration time-utc))))
       ($oops 'condition-wait "~s is not a time record of type time-duration or time-utc" t))
-    (cw ($condition-addr c) ($mutex-addr m) t)]))
+    (let ([caddr ($condition-addr c)] [maddr ($mutex-addr m)])
+      (when (eq? caddr 0)
+        ($oops 'condition-wait "condition is defunct"))
+      (when (eq? maddr 0)
+        ($oops 'condition-wait "mutex is defunct"))
+      (let ([r (cw caddr maddr t)])
+        ($keep-live c)
+        ($keep-live m)
+        r))]))
 
 (set! condition-broadcast
   (lambda (c)
     (unless (thread-condition? c)
       ($oops 'condition-broadcast "~s is not a condition" c))
-    (cb ($condition-addr c))))
+    (let ([addr ($condition-addr c)])
+      (when (eq? addr 0)
+        ($oops 'condition-broadcast "condition is defunct"))
+      (cb addr))))
 
 (set! condition-signal
   (lambda (c)
     (unless (thread-condition? c)
       ($oops 'condition-signal "~s is not a condition" c))
-    (cs ($condition-addr c))))
+    (let ([addr ($condition-addr c)])
+      (when (eq? addr 0)
+        ($oops 'condition-signal "condition is defunct"))
+      (cs addr))))
+
+(set! $close-resurrected-mutexes&conditions
+  ; called from single-threaded docollect
+  (lambda ()
+    (let f ()
+      (let mg ([m (mutex-guardian)])
+        (when m
+          (let ([addr ($mutex-addr m)])
+	    (unless (eq? addr 0)
+	      (mf addr)
+              ($mutex-addr-set! m 0)))
+          (f))))
+    (let f ()
+      (let cg ([c (condition-guardian)])
+        (when c
+	  (let ([addr ($condition-addr c)])
+	    (unless (eq? addr 0)
+	      (cf addr)
+              ($condition-addr-set! c 0)))
+          (f))))))
 
 (set! $tc-mutex ($make-mutex ($raw-tc-mutex)))
 (set! $collect-cond ($make-condition ($raw-collect-cond)))
@@ -2135,6 +2187,10 @@
   (lambda ()
     (#3%$read-time-stamp-counter)))
 
+(define $keep-live
+  (lambda (x)
+    (#2%$keep-live x)))
+
 (when-feature windows
 (let ()
   (define mbtwc