mutexes and conditions are now freed when no longer used

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

original commit: 8d9aa4dffc371fc365020e5dac62270dae2aaa95
This commit is contained in:
Bob Burger 2017-04-13 09:41:58 -04:00
parent c19e662ed0
commit cbae4b9d77
12 changed files with 130 additions and 10 deletions

4
LOG
View File

@ -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

View File

@ -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

View File

@ -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);

View File

@ -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) {

View File

@ -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)))

View File

@ -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

View File

@ -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

2
s/7.ss
View File

@ -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)))

View File

@ -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

View File

@ -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*)))))
)

View File

@ -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])

View File

@ -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