From cbae4b9d7789e0baa23bdbd4534f2b592ec90f71 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Thu, 13 Apr 2017 09:41:58 -0400 Subject: [PATCH] mutexes and conditions are now freed when no longer used added $close-resurrected-mutexes&conditions and $keep-live original commit: 8d9aa4dffc371fc365020e5dac62270dae2aaa95 --- LOG | 4 ++ c/externs.h | 2 + c/prim5.c | 2 + c/thread.c | 10 +++++ mats/4.ms | 10 ++++- mats/thread.ms | 21 +++++++++ release_notes/release_notes.stex | 5 +++ s/7.ss | 2 + s/cpnanopass.ss | 2 + s/np-languages.ss | 6 +++ s/primdata.ss | 2 + s/prims.ss | 74 ++++++++++++++++++++++++++++---- 12 files changed, 130 insertions(+), 10 deletions(-) diff --git a/LOG b/LOG index 1fbb59e9e3..5d01de7e7e 100644 --- a/LOG +++ b/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 diff --git a/c/externs.h b/c/externs.h index f5e9c36dd9..c554ec1e5f 100644 --- a/c/externs.h +++ b/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 diff --git a/c/prim5.c b/c/prim5.c index 697bf2ec42..0b7fb4af97 100644 --- a/c/prim5.c +++ b/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); diff --git a/c/thread.c b/c/thread.c index e4ff613f58..88395dea98 100644 --- a/c/thread.c +++ b/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) { diff --git a/mats/4.ms b/mats/4.ms index b29cbb7edd..5607c64d87 100644 --- a/mats/4.ms +++ b/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))) diff --git a/mats/thread.ms b/mats/thread.ms index 9865beabe8..5d87da4e9f 100644 --- a/mats/thread.ms +++ 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 diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 1000ffb63f..960a6993a6 100644 --- a/release_notes/release_notes.stex +++ b/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 diff --git a/s/7.ss b/s/7.ss index 3cc868726a..d8fbb9f26e 100644 --- a/s/7.ss +++ b/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))) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index d0841009c0..964405612f 100644 --- a/s/cpnanopass.ss +++ b/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 diff --git a/s/np-languages.ss b/s/np-languages.ss index fced3cb0c5..ef81f8cdc2 100644 --- a/s/np-languages.ss +++ b/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*))))) ) diff --git a/s/primdata.ss b/s/primdata.ss index bf46816d68..041be16a8e 100644 --- a/s/primdata.ss +++ b/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]) diff --git a/s/prims.ss b/s/prims.ss index 49e7936839..b9a51846d0 100644 --- a/s/prims.ss +++ b/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