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:
parent
c19e662ed0
commit
cbae4b9d77
4
LOG
4
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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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);
|
||||
|
|
10
c/thread.c
10
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) {
|
||||
|
|
10
mats/4.ms
10
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)))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
2
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)))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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*)))))
|
||||
)
|
||||
|
|
|
@ -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])
|
||||
|
|
74
s/prims.ss
74
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
|
||||
|
|
Loading…
Reference in New Issue
Block a user