suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix custodian callbackks to run on exit

Browse Source 
Related to #3352
This commit is contained in:
Matthew Flatt 2020-08-15 11:13:05 -06:00
parent c96673d198
commit 0f530dd9f4
5 changed files with 186 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/src/cs/c/check_boot.sh
View File

@ -28,7 +28,7 @@ check_pb vfasl.inc
check_mach() check_mach()
{ {
SRC=$SCHEME_DIR/boot/pb/$1 SRC="$SCHEME_DIR"/boot/pb/$1
INIT=$SCHEME_WORKAREA/boot/$MACH/$1 INIT=$SCHEME_WORKAREA/boot/$MACH/$1
if [ ! -e $INIT ] ; then if [ ! -e $INIT ] ; then
touch boot_pending touch boot_pending

59
racket/src/cs/main.sps
View File

@ -110,9 +110,6 @@
(define gracket-guid-or-x11-args (list-ref the-command-line-arguments 9)) (define gracket-guid-or-x11-args (list-ref the-command-line-arguments 9))
(seq (seq
(when (foreign-entry? "racket_exit")
(#%exit-handler (foreign-procedure "racket_exit" (int) void)))
(when (eq? 'windows (system-type)) (when (eq? 'windows (system-type))
(unsafe-register-process-global (string->bytes/utf-8 "PLT_WM_IS_GRACKET") (unsafe-register-process-global (string->bytes/utf-8 "PLT_WM_IS_GRACKET")
(ptr-add #f wm-is-gracket-or-x11-arg-count)) (ptr-add #f wm-is-gracket-or-x11-arg-count))
@ -678,32 +675,35 @@
(when debug-GC:major? (when debug-GC:major?
(log-message* root-logger 'debug 'GC:major msg data #f in-interrupt?))))))))))) (log-message* root-logger 'debug 'GC:major msg data #f in-interrupt?)))))))))))
(seq (define (initialize-exit-handler!)
(exit-handler (when (foreign-entry? "racket_exit")
(let ([orig (exit-handler)] (#%exit-handler (foreign-procedure "racket_exit" (int) void)))
[root-logger (current-logger)]) (#%exit-handler
(lambda (v) (let ([orig (#%exit-handler)]
(when gcs-on-exit? [root-logger (current-logger)])
(collect-garbage) (lambda (v)
(collect-garbage)) (when gcs-on-exit?
(let ([debug-GC? (log-level?* root-logger 'debug 'GC)] (collect-garbage)
[debug-GC:major? (log-level?* root-logger 'debug 'GC:major)]) (collect-garbage))
(when (or debug-GC? debug-GC:major?) (let ([debug-GC? (log-level?* root-logger 'debug 'GC)]
(let ([msg (chez:format "GC: 0:atexit peak ~a(~a); alloc ~a; major ~a; minor ~a; ~ams" [debug-GC:major? (log-level?* root-logger 'debug 'GC:major)])
(K "" peak-mem) (when (or debug-GC? debug-GC:major?)
(K "+" (- (maximum-memory-bytes) peak-mem)) (let ([msg (chez:format "GC: 0:atexit peak ~a(~a); alloc ~a; major ~a; minor ~a; ~ams"
(K "" (- (+ (bytes-deallocated) (bytes-allocated)) (initial-bytes-allocated))) (K "" peak-mem)
major-gcs (K "+" (- (maximum-memory-bytes) peak-mem))
minor-gcs (K "" (- (+ (bytes-deallocated) (bytes-allocated)) (initial-bytes-allocated)))
(let ([t (sstats-gc-cpu (statistics))]) major-gcs
(+ (* (time-second t) 1000) minor-gcs
(quotient (time-nanosecond t) 1000000))))]) (let ([t (sstats-gc-cpu (statistics))])
(when debug-GC? (+ (* (time-second t) 1000)
(log-message root-logger 'info 'GC msg #f #f)) (quotient (time-nanosecond t) 1000000))))])
(when debug-GC:major? (when debug-GC?
(log-message root-logger 'info 'GC:major msg #f #f))))) (log-message root-logger 'info 'GC msg #f #f))
(linklet-performance-report!) (when debug-GC:major?
(|#%app| orig v))))) (log-message root-logger 'info 'GC:major msg #f #f)))))
(linklet-performance-report!)
(custodian-shutdown-root-at-exit)
(|#%app| orig v)))))
(define stderr-logging (define stderr-logging
(or stderr-logging-arg (or stderr-logging-arg
@ -875,6 +875,7 @@
(lambda (entry-point-k) (lambda (entry-point-k)
(call-in-main-thread (call-in-main-thread
(lambda () (lambda ()
(initialize-exit-handler!)
(initialize-place!) (initialize-place!)
(when init-library (when init-library

250
racket/src/cs/schemified/thread.scm
View File

@ -39,6 +39,8 @@
(1/custodian-require-memory custodian-require-memory) (1/custodian-require-memory custodian-require-memory)
(1/custodian-shut-down? custodian-shut-down?) (1/custodian-shut-down? custodian-shut-down?)
(1/custodian-shutdown-all custodian-shutdown-all) (1/custodian-shutdown-all custodian-shutdown-all)
(custodian-shutdown-root-at-exit
custodian-shutdown-root-at-exit)
(1/custodian? custodian?) (1/custodian? custodian?)
(1/dynamic-place dynamic-place) (1/dynamic-place dynamic-place)
(1/evt? evt?) (1/evt? evt?)
@ -5623,11 +5625,11 @@
(begin (begin
(set-custodian-place! c_0 (custodian-place parent_0)) (set-custodian-place! c_0 (custodian-place parent_0))
(let ((cref_0 (let ((cref_0
(let ((temp29_0 (let ((temp31_0
(let ((children_0 (let ((children_0
(custodian-children c_0))) (custodian-children c_0)))
(|#%name| (|#%name|
temp29 temp31
(lambda (c_1) (lambda (c_1)
(begin (begin
(begin (begin
@ -5640,7 +5642,7 @@
#t #t
parent_0 parent_0
c_0 c_0
temp29_0)))) temp31_0))))
(begin (begin
(set-custodian-parent-reference! c_0 cref_0) (set-custodian-parent-reference! c_0 cref_0)
(if cref_0 (if cref_0
@ -5793,20 +5795,20 @@
#f) #f)
#f))) #f)))
(if (willed-callback? callback_0) (if (willed-callback? callback_0)
(let ((temp50_0 (let ((temp52_0
(willed-callback-proc (willed-callback-proc
callback_0))) callback_0)))
(let ((temp51_0 (let ((temp53_0
(at-exit-callback? (at-exit-callback?
callback_0))) callback_0)))
(let ((temp50_1 temp50_0)) (let ((temp52_1 temp52_0))
(do-custodian-register.1 (do-custodian-register.1
temp51_0 temp53_0
gc-root?_0 gc-root?_0
#f #f
parent_0 parent_0
child_0 child_0
temp50_1)))) temp52_1))))
(do-custodian-register.1 (do-custodian-register.1
#f #f
gc-root?_0 gc-root?_0
@ -5859,6 +5861,13 @@
(start-atomic) (start-atomic)
(begin0 (do-custodian-shutdown-all c_0) (end-atomic)) (begin0 (do-custodian-shutdown-all c_0) (end-atomic))
(|#%app| post-shutdown-action)))))) (|#%app| post-shutdown-action))))))
(define custodian-shutdown-root-at-exit
(lambda ()
(begin
(start-atomic)
(begin0
(do-custodian-shutdown-all (unsafe-place-local-ref cell.1$6) #t)
(end-atomic)))))
(define queued-shutdowns null) (define queued-shutdowns null)
(define queue-custodian-shutdown! (define queue-custodian-shutdown!
(lambda (c_0) (lambda (c_0)
@ -5964,74 +5973,103 @@
(define custodian-this-place? (define custodian-this-place?
(lambda (c_0) (eq? (custodian-place c_0) (unsafe-place-local-ref cell.1$2)))) (lambda (c_0) (eq? (custodian-place c_0) (unsafe-place-local-ref cell.1$2))))
(define do-custodian-shutdown-all (define do-custodian-shutdown-all
(lambda (c_0) (let ((do-custodian-shutdown-all_0
(if (1/custodian-shut-down? c_0) (|#%name|
(void) do-custodian-shutdown-all
(begin (lambda (c17_0 only-at-exit?16_0)
(set-custodian-shut-down! c_0)
(begin
(if (custodian-sync-futures? c_0)
(|#%app| futures-sync-for-custodian-shutdown)
(void))
(begin
(let ((ht_0 (custodian-children c_0)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (i_0)
(begin
(if i_0
(call-with-values
(lambda () (hash-iterate-key+value ht_0 i_0 #f))
(case-lambda
((child_0 callback_0)
(begin
(if child_0
(if (procedure-arity-includes? callback_0 2)
(|#%app| callback_0 child_0 c_0)
(|#%app| callback_0 child_0))
(void))
(for-loop_0 (hash-iterate-next ht_0 i_0))))
(args (raise-binding-result-arity-error 2 args))))
(values)))))))
(for-loop_0 (hash-iterate-first ht_0)))))
(begin (begin
(hash-clear! (custodian-children c_0)) (if (1/custodian-shut-down? c17_0)
(begin (void)
(if (custodian-gc-roots c_0)
(hash-clear! (custodian-gc-roots c_0))
(void))
(begin (begin
(let ((lst_0 (custodian-post-shutdown c_0))) (set-custodian-shut-down! c17_0)
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (lst_1)
(begin
(if (pair? lst_1)
(let ((proc_0 (unsafe-car lst_1)))
(let ((rest_0 (unsafe-cdr lst_1)))
(begin
(|#%app| proc_0)
(for-loop_0 rest_0))))
(values)))))))
(for-loop_0 lst_0))))
(begin (begin
(set-custodian-post-shutdown! c_0 null) (if (custodian-sync-futures? c17_0)
(|#%app| futures-sync-for-custodian-shutdown)
(void))
(begin (begin
(let ((sema_0 (custodian-shutdown-sema c_0))) (let ((ht_0 (custodian-children c17_0)))
(if sema_0 (semaphore-post-all sema_0) (void)))
(let ((p-cref_0 (custodian-parent-reference c_0)))
(begin (begin
(if p-cref_0 (letrec*
(1/unsafe-custodian-unregister c_0 p-cref_0) ((for-loop_0
(|#%name|
for-loop
(lambda (i_0)
(begin
(if i_0
(call-with-values
(lambda ()
(hash-iterate-key+value ht_0 i_0 #f))
(case-lambda
((child_0 callback_0)
(begin
(if (if child_0
(let ((or-part_0
(not only-at-exit?16_0)))
(if or-part_0
or-part_0
(at-exit-callback?
callback_0)))
#f)
(if (procedure-arity-includes?
callback_0
2)
(|#%app| callback_0 child_0 c17_0)
(|#%app| callback_0 child_0))
(void))
(for-loop_0
(hash-iterate-next ht_0 i_0))))
(args
(raise-binding-result-arity-error
2
args))))
(values)))))))
(for-loop_0 (hash-iterate-first ht_0)))))
(begin
(hash-clear! (custodian-children c17_0))
(begin
(if (custodian-gc-roots c17_0)
(hash-clear! (custodian-gc-roots c17_0))
(void)) (void))
(remove-limit-custodian! c_0) (begin
(set-custodian-memory-limits! c_0 null)))))))))))))) (let ((lst_0 (custodian-post-shutdown c17_0)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (lst_1)
(begin
(if (pair? lst_1)
(let ((proc_0 (unsafe-car lst_1)))
(let ((rest_0 (unsafe-cdr lst_1)))
(begin
(|#%app| proc_0)
(for-loop_0 rest_0))))
(values)))))))
(for-loop_0 lst_0))))
(begin
(set-custodian-post-shutdown! c17_0 null)
(begin
(let ((sema_0 (custodian-shutdown-sema c17_0)))
(if sema_0
(semaphore-post-all sema_0)
(void)))
(let ((p-cref_0
(custodian-parent-reference c17_0)))
(begin
(if p-cref_0
(1/unsafe-custodian-unregister
c17_0
p-cref_0)
(void))
(remove-limit-custodian! c17_0)
(set-custodian-memory-limits!
c17_0
null)))))))))))))))))
(case-lambda
((c_0) (do-custodian-shutdown-all_0 c_0 #f))
((c_0 only-at-exit?16_0)
(do-custodian-shutdown-all_0 c_0 only-at-exit?16_0)))))
(define custodian-get-shutdown-sema (define custodian-get-shutdown-sema
(lambda (c_0) (lambda (c_0)
(begin (begin
@ -6052,28 +6090,28 @@
(let ((unsafe-add-post-custodian-shutdown_0 (let ((unsafe-add-post-custodian-shutdown_0
(|#%name| (|#%name|
unsafe-add-post-custodian-shutdown unsafe-add-post-custodian-shutdown
(lambda (proc17_0 custodian16_0) (lambda (proc19_0 custodian18_0)
(begin (begin
(begin (begin
(if (if (procedure? proc17_0) (if (if (procedure? proc19_0)
(procedure-arity-includes? proc17_0 0) (procedure-arity-includes? proc19_0 0)
#f) #f)
(void) (void)
(raise-argument-error (raise-argument-error
'unsafe-add-post-custodian-shutdown 'unsafe-add-post-custodian-shutdown
"(procedure-arity-includes/c 0)" "(procedure-arity-includes/c 0)"
proc17_0)) proc19_0))
(begin (begin
(if (let ((or-part_0 (not custodian16_0))) (if (let ((or-part_0 (not custodian18_0)))
(if or-part_0 or-part_0 (1/custodian? custodian16_0))) (if or-part_0 or-part_0 (1/custodian? custodian18_0)))
(void) (void)
(raise-argument-error (raise-argument-error
'unsafe-add-post-custodian-shutdown 'unsafe-add-post-custodian-shutdown
"(or/c custodian? #f)" "(or/c custodian? #f)"
custodian16_0)) custodian18_0))
(let ((c_0 (let ((c_0
(if custodian16_0 (if custodian18_0
custodian16_0 custodian18_0
(place-custodian (place-custodian
(unsafe-place-local-ref cell.1$2))))) (unsafe-place-local-ref cell.1$2)))))
(if (if (not (if (if (not
@ -6088,14 +6126,14 @@
(begin0 (begin0
(set-custodian-post-shutdown! (set-custodian-post-shutdown!
c_0 c_0
(cons proc17_0 (custodian-post-shutdown c_0))) (cons proc19_0 (custodian-post-shutdown c_0)))
(end-atomic)))))))))))) (end-atomic))))))))))))
(|#%name| (|#%name|
unsafe-add-post-custodian-shutdown unsafe-add-post-custodian-shutdown
(case-lambda (case-lambda
((proc_0) (begin (unsafe-add-post-custodian-shutdown_0 proc_0 #f))) ((proc_0) (begin (unsafe-add-post-custodian-shutdown_0 proc_0 #f)))
((proc_0 custodian16_0) ((proc_0 custodian18_0)
(unsafe-add-post-custodian-shutdown_0 proc_0 custodian16_0)))))) (unsafe-add-post-custodian-shutdown_0 proc_0 custodian18_0))))))
(define custodian-subordinate? (define custodian-subordinate?
(lambda (c_0 super-c_0) (lambda (c_0 super-c_0)
(letrec* (letrec*
@ -6188,25 +6226,25 @@
(let ((custodian-limit-memory_0 (let ((custodian-limit-memory_0
(|#%name| (|#%name|
custodian-limit-memory custodian-limit-memory
(lambda (limit-cust19_0 need-amt20_0 stop-cust18_0) (lambda (limit-cust21_0 need-amt22_0 stop-cust20_0)
(begin (begin
(let ((stop-cust_0 (let ((stop-cust_0
(if (eq? stop-cust18_0 unsafe-undefined) (if (eq? stop-cust20_0 unsafe-undefined)
limit-cust19_0 limit-cust21_0
stop-cust18_0))) stop-cust20_0)))
(begin (begin
(if (1/custodian? limit-cust19_0) (if (1/custodian? limit-cust21_0)
(void) (void)
(raise-argument-error (raise-argument-error
'custodian-limit-memory 'custodian-limit-memory
"custodian?" "custodian?"
limit-cust19_0)) limit-cust21_0))
(if (exact-nonnegative-integer? need-amt20_0) (if (exact-nonnegative-integer? need-amt22_0)
(void) (void)
(raise-argument-error (raise-argument-error
'custodian-limit-memory 'custodian-limit-memory
"exact-nonnegative-integer?" "exact-nonnegative-integer?"
need-amt20_0)) need-amt22_0))
(if (1/custodian? stop-cust_0) (if (1/custodian? stop-cust_0)
(void) (void)
(raise-argument-error (raise-argument-error
@ -6217,36 +6255,36 @@
(start-atomic/no-interrupts) (start-atomic/no-interrupts)
(begin0 (begin0
(if (let ((or-part_0 (if (let ((or-part_0
(1/custodian-shut-down? limit-cust19_0))) (1/custodian-shut-down? limit-cust21_0)))
(if or-part_0 (if or-part_0
or-part_0 or-part_0
(1/custodian-shut-down? stop-cust_0))) (1/custodian-shut-down? stop-cust_0)))
(void) (void)
(begin (begin
(set-custodian-memory-limits! (set-custodian-memory-limits!
limit-cust19_0 limit-cust21_0
(let ((app_0 (let ((app_0
(cons (cons
need-amt20_0 need-amt22_0
(if (eq? limit-cust19_0 stop-cust_0) (if (eq? limit-cust21_0 stop-cust_0)
#f #f
stop-cust_0)))) stop-cust_0))))
(cons (cons
app_0 app_0
(custodian-memory-limits limit-cust19_0)))) (custodian-memory-limits limit-cust21_0))))
(if (eq? stop-cust_0 limit-cust19_0) (if (eq? stop-cust_0 limit-cust21_0)
(let ((old-limit_0 (let ((old-limit_0
(custodian-immediate-limit limit-cust19_0))) (custodian-immediate-limit limit-cust21_0)))
(if (let ((or-part_0 (not old-limit_0))) (if (let ((or-part_0 (not old-limit_0)))
(if or-part_0 (if or-part_0
or-part_0 or-part_0
(> old-limit_0 need-amt20_0))) (> old-limit_0 need-amt22_0)))
(set-custodian-immediate-limit! (set-custodian-immediate-limit!
limit-cust19_0 limit-cust21_0
need-amt20_0) need-amt22_0)
(void))) (void)))
(void)) (void))
(check-limit-custodian limit-cust19_0))) (check-limit-custodian limit-cust21_0)))
(end-atomic/no-interrupts)) (end-atomic/no-interrupts))
(void)))))))) (void))))))))
(|#%name| (|#%name|
@ -6255,8 +6293,8 @@
((limit-cust_0 need-amt_0) ((limit-cust_0 need-amt_0)
(begin (begin
(custodian-limit-memory_0 limit-cust_0 need-amt_0 unsafe-undefined))) (custodian-limit-memory_0 limit-cust_0 need-amt_0 unsafe-undefined)))
((limit-cust_0 need-amt_0 stop-cust18_0) ((limit-cust_0 need-amt_0 stop-cust20_0)
(custodian-limit-memory_0 limit-cust_0 need-amt_0 stop-cust18_0)))))) (custodian-limit-memory_0 limit-cust_0 need-amt_0 stop-cust20_0))))))
(define custodians-with-limits (make-hasheq)) (define custodians-with-limits (make-hasheq))
(define check-limit-custodian (define check-limit-custodian
(lambda (limit-cust_0) (lambda (limit-cust_0)
@ -6286,7 +6324,7 @@
(define 1/make-custodian-box (define 1/make-custodian-box
(letrec ((procz1 (letrec ((procz1
(|#%name| (|#%name|
temp65 temp67
(lambda (b_0) (begin (set-custodian-box-v! b_0 #f)))))) (lambda (b_0) (begin (set-custodian-box-v! b_0 #f))))))
(|#%name| (|#%name|
make-custodian-box make-custodian-box
@ -6299,8 +6337,8 @@
(let ((b_0 (let ((b_0
(custodian-box1.1 v_0 (custodian-get-shutdown-sema c_0)))) (custodian-box1.1 v_0 (custodian-get-shutdown-sema c_0))))
(begin (begin
(if (let ((temp65_0 procz1)) (if (let ((temp67_0 procz1))
(do-custodian-register.1 #f #t #t c_0 b_0 temp65_0)) (do-custodian-register.1 #f #t #t c_0 b_0 temp67_0))
(void) (void)
(raise-arguments-error (raise-arguments-error
'make-custodian-box 'make-custodian-box

11
racket/src/thread/custodian.rkt
View File

@ -33,6 +33,7 @@
unsafe-custodian-unregister unsafe-custodian-unregister
custodian-register-thread custodian-register-thread
custodian-register-place custodian-register-place
custodian-shutdown-root-at-exit
raise-custodian-is-shut-down raise-custodian-is-shut-down
unsafe-add-post-custodian-shutdown unsafe-add-post-custodian-shutdown
check-queued-custodian-shutdown check-queued-custodian-shutdown
@ -222,6 +223,10 @@
;; should be swapped out ;; should be swapped out
(post-shutdown-action)) (post-shutdown-action))
(define (custodian-shutdown-root-at-exit)
(atomically
(do-custodian-shutdown-all root-custodian #t)))
;; Custodians across all places that have a queued shutdown. Hold the ;; Custodians across all places that have a queued shutdown. Hold the
;; memory-limit lock and also disable interrupts (or OK as a GC ;; memory-limit lock and also disable interrupts (or OK as a GC
;; callback) while modifying this list: ;; callback) while modifying this list:
@ -292,13 +297,15 @@
(eq? (custodian-place c) current-place)) (eq? (custodian-place c) current-place))
;; In atomic mode ;; In atomic mode
(define (do-custodian-shutdown-all c) (define (do-custodian-shutdown-all c [only-at-exit? #f])
(unless (custodian-shut-down? c) (unless (custodian-shut-down? c)
(set-custodian-shut-down! c) (set-custodian-shut-down! c)
(when (custodian-sync-futures? c) (when (custodian-sync-futures? c)
(futures-sync-for-custodian-shutdown)) (futures-sync-for-custodian-shutdown))
(for ([(child callback) (in-hash (custodian-children c) #f)]) (for ([(child callback) (in-hash (custodian-children c) #f)])
(when child (when (and child
(or (not only-at-exit?)
(at-exit-callback? callback)))
(if (procedure-arity-includes? callback 2) (if (procedure-arity-includes? callback 2)
(callback child c) (callback child c)
(callback child)))) (callback child))))

1
racket/src/thread/main.rkt
View File

@ -122,6 +122,7 @@
custodian-require-memory custodian-require-memory
custodian-limit-memory custodian-limit-memory
custodian-shut-down? custodian-shut-down?
custodian-shutdown-root-at-exit
make-will-executor make-will-executor
make-late-will-executor make-late-will-executor