diff --git a/collects/ffi/unsafe/custodian.rkt b/collects/ffi/unsafe/custodian.rkt index 619d04e418..1db4dead5a 100644 --- a/collects/ffi/unsafe/custodian.rkt +++ b/collects/ffi/unsafe/custodian.rkt @@ -20,21 +20,23 @@ (get-ffi-obj 'scheme_remove_managed #f (_fun _Scheme_Custodian_Reference-pointer _racket -> _void))) -(define (shutdown-callback impl proc+self) - ((car proc+self) impl)) +(define (shutdown-callback impl proc+box) + ((car proc+box) impl)) +(define shutdown-callback-box (box #f)) (define shutdown_callback - (cast shutdown-callback (_fun #:atomic? #t _racket _racket -> _void) _fpointer)) + (cast shutdown-callback (_fun #:atomic? #t #:keep shutdown-callback-box + _racket _racket -> _void) _fpointer)) (define (register-custodian-shutdown obj proc [custodian (current-custodian)] #:at-exit? [at-exit? #f] #:weak? [weak? #f]) - (define proc+self (cons proc - shutdown-callback)) ; proc as data -> ffi callback retained + (define proc+box (cons proc + shutdown-callback-box)) ; proc as data -> ffi callback retained (if at-exit? (scheme_add_managed_close_on_exit custodian - obj shutdown_callback proc+self) + obj shutdown_callback proc+box) (scheme_add_managed custodian - obj shutdown_callback proc+self + obj shutdown_callback proc+box (if weak? 0 1)))) (define (unregister-custodian-shutdown obj mref) diff --git a/collects/math/private/bigfloat/mpfr.rkt b/collects/math/private/bigfloat/mpfr.rkt index d283b4ef9c..e9e38e6e70 100644 --- a/collects/math/private/bigfloat/mpfr.rkt +++ b/collects/math/private/bigfloat/mpfr.rkt @@ -76,9 +76,14 @@ [(_ name type fail-thunk) (get-ffi-obj name mpfr-lib type fail-thunk)])) (define mpfr-free-cache (get-mpfr-fun 'mpfr_free_cache (_fun -> _void))) -#; + (define mpfr-shutdown - (register-custodian-shutdown mpfr-free-cache (λ (free) (free)))) + (register-custodian-shutdown + mpfr-free-cache ; acts as a "random" object for a shutdown handle + (λ (free) + ;; The direct reference here is important, since custodian holds only + ;; a weak reference to shutdown handle: + (mpfr-free-cache)))) ;; =================================================================================================== ;; MPFR types diff --git a/collects/math/tests/bigfloat-custodian.rkt b/collects/math/tests/bigfloat-custodian.rkt new file mode 100644 index 0000000000..fe7200c040 --- /dev/null +++ b/collects/math/tests/bigfloat-custodian.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +;; Not crashing means success for this stress test: + +(let loop ([i 0] [l null]) + (unless (= i 100) + (displayln "next") + (let ([l (if (zero? (random 5)) + (begin + (printf "shutdown\n") + (for-each custodian-shutdown-all l) + null) + l)]) + (let ([c (make-custodian)]) + (parameterize ([current-custodian c]) + (for ([i (random 10)]) (thread (lambda () (sleep 10)))) + (parameterize ([current-namespace (make-base-namespace)]) + (dynamic-require `math/bigfloat #f))) + (loop (add1 i) (cons c l))))))