ffi/unsafe/alloc: add decallocation on place exit

Closes #1830

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.0.0.3")
+(define version "7.0.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/foreign/alloc.scrbl

@@ -11,17 +11,40 @@ deallocated.}
 
 @defproc[((allocator [dealloc (any/c . -> . any)]) [alloc procedure?]) procedure?]{
 
-Produces a procedure that behaves like @racket[alloc], but the result
-of @racket[alloc] is given a finalizer that calls @racket[dealloc] on
-a non-@racket[#f] result if it is not otherwise freed through a deallocator (as
-designated with @racket[deallocator]). In addition, @racket[alloc] is
-called in @tech{atomic mode} (see @racket[call-as-atomic]); its result is
-received and registered in atomic mode, so that the result is reliably
-freed as long as no exception is raised.
+Produces an @deftech{allocator} procedure that behaves like
+@racket[alloc], but each result @racket[_v] of the @tech{allocator},
+if not @racket[#f], is given a finalizer that calls @racket[dealloc]
+on @racket[_v] --- unless the call has been canceled by applying a
+@tech{deallocator} (produced by @racket[deallocator]) to @racket[_v].
+Any existing @racket[dealloc] registered for @racket[_v] is canceled.
 
-The @racket[dealloc] procedure itself need not be specifically
-designated a deallocator (via @racket[deallocator]). If a deallocator
-is called explicitly, it need not be the same as @racket[dealloc].}
+The resulting @tech{allocator} calls @racket[alloc] in @tech{atomic
+mode} (see @racket[call-as-atomic]). The result from @racket[alloc] is
+received and registered in atomic mode, so that the result is reliably
+deallocated as long as no exception is raised.
+
+The @racket[dealloc] procedure will be called in atomic mode, and it
+must obey the same constraints as a finalizer procedure provided to
+@racket[register-finalizer]. The @racket[dealloc] procedure itself
+need not be specifically a @tech{deallocator} produced by
+@racket[deallocator]. If a @tech{deallocator} is called explicitly, it
+need not be the same as @racket[dealloc].
+
+When a non-main @tech[#:doc reference.scrbl]{place} exits, after all
+@tech[#:doc reference.scrbl]{custodian}-shutdown actions, for every
+@racket[dealloc] still registered via an @tech{allocator} or
+@tech{retainer} (from @racket[allocator] or @racket[retainer]), the
+value to deallocate is treated as immediately unreachable. At that
+point, @racket[dealloc] functions are called in reverse order of their
+registrations. Note that references in a @racket[dealloc] function's
+closure do @emph{not} prevent running a @racket[dealloc] function for
+any other value. If deallocation needs to proceed in an order
+different than reverse of allocation, use a @tech{retainer} to insert
+a new deallocation action that will run earlier.
+
+@history[#:changed "7.0.0.4" @elem{Added atomic mode for @racket[dealloc]
+                                   and changed non-main place exits to call
+                                   all remaining @racket[dealloc]s.}]}
 
 @deftogether[(
 @defproc[((deallocator [get-arg (list? . -> . any/c) car]) [dealloc procedure?]) 
@@ -30,13 +53,11 @@ is called explicitly, it need not be the same as @racket[dealloc].}
          procedure?]
 )]{
 
-Produces a procedure that behaves like @racket[dealloc]. The
-@racket[dealloc] procedure is called in @tech{atomic mode} (see
-@racket[call-as-atomic]), and the reference count on one of its
-arguments is decremented; if the reference count reaches zero, no
-finalizer associated by an @racket[allocator]- or
-@racket[retainer]-wrapped procedure is invoked when the value
-becomes inaccessible.
+Produces a @deftech{deallocator} procedure that behaves like
+@racket[dealloc]. The @tech{deallocator} calls @racket[dealloc] in
+@tech{atomic mode} (see @racket[call-as-atomic]), and for one of its
+arguments, the it cancels the most recent remaining deallocator
+registered by a @tech{allocator} or @tech{retainer}.
 
 The optional @racket[get-arg] procedure determines which of
 @racket[dealloc]'s arguments correspond to the released object;
@@ -52,19 +73,28 @@ The @racket[releaser] procedure is a synonym for
           [retain procedure?]) 
          procedure?]{
 
-Produces a procedure that behaves like @racket[retain]. The procedure
-is called in @tech{atomic mode} (see @racket[call-as-atomic]), and the
-reference count on one of its arguments is incremented, with
-@racket[release] recorded as the corresponding release procedure to be
-called by the finalizer on the retained object (unless some
-deallocator, as wrapped by @racket[deallocator], is explicitly called
-first).
+Produces a @deftech{retainer} procedure that behaves like
+@racket[retain]. A @tech{retainer} acts the same as an
+@tech{allocator} produced by @racket[allocator], except that
 
-The optional @racket[get-arg] procedure determines which of
-@racket[retain]'s arguments correspond to the retained object;
+@itemlist[
+
+ @item{a @tech{retainer} does not cancel any existing @racket[release]
+       or @racket[_dealloc] registrations when registering
+       @racket[release]; and}
+
+ @item{@racket[release] is registered for a value @racket[_v] that is
+       is an argument to the @tech{retainer}, instead of the result
+       for an @tech{allocator}.}
+
+]
+
+The optional @racket[get-arg] procedure determines which of the
+@tech{retainer}'s arguments (that is, which of @racket[retain]'s
+arguments) correspond to the retained object @racket[_v];
 @racket[get-arg] receives a list of arguments passed to
 @racket[retain], so the default @racket[car] selects the first one.
 
-The @racket[release] procedure itself need not be specifically
-designated a deallocator (via @racket[deallocator]). If a deallocator
-is called explicitly, it need not be the same as @racket[release].}
+@history[#:changed "7.0.0.4" @elem{Added atomic mode for @racket[release]
+                                   and changed non-main place exits to call
+                                   all remaining @racket[release]s.}]}

pkgs/racket-doc/scribblings/foreign/pointers.scrbl

@@ -303,7 +303,6 @@ Registers a finalizer procedure @racket[finalizer-proc] with the given
 is registered with a will executor; see
 @racket[make-will-executor]. The finalizer is invoked when
 @racket[obj] is about to be collected.
-See also @racket[register-custodian-shutdown].
 
 The finalizer is invoked in a thread that is in charge of triggering
 will executors for @racket[register-finalizer]. The given
@@ -320,9 +319,13 @@ foreign code.  Note, however, that the finalizer is registered for the
 free a pointer object, then you must be careful to not register
 finalizers for two cpointers that point to the same address.  Also, be
 careful to not make the finalizer a closure that holds on to the
-object.
+object. Finally, beware that the finalizer is not guaranteed to
+be run when a place exits; see @racketmodname[ffi/unsafe/alloc]
+and @racket[register-finalizer-and-custodian-shutdown] for more
+complete solutions.
 
-For example, suppose that you're dealing with a foreign function that returns a
+As an example for @racket[register-finalizer],
+suppose that you're dealing with a foreign function that returns a
 C string that you should free.  Here is an attempt at creating a suitable type:
 
 @racketblock[
@@ -337,7 +340,7 @@ C string that you should free.  Here is an attempt at creating a suitable type:
 
 The above code is wrong: the finalizer is registered for @racket[x],
 which is no longer needed after the byte string is created.  Changing
-the example to register the finalizer for @racket[b] correct the problem,
+the example to register the finalizer for @racket[b] corrects the problem,
 but then @racket[free] is invoked @racket[b] it instead of on @racket[x].
 In the process of fixing this problem, we might be careful and log a message
 for debugging:

pkgs/racket-test/tests/racket/ffi-alloc.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+(require racket/place
+         ffi/unsafe
+         ffi/unsafe/alloc)
+
+(module+ test
+  (define-syntax-rule (test expect got)
+    (let ([e expect]
+          [g got])
+      (unless (equal? e g)
+        (error 'test "failed: ~s => ~v != ~s => ~v" 'expect e 'got g))))
+
+  (define (check-allocator
+           #:retain? [retain? #f]
+           #:release? [release? #f]
+           #:deallocate? [deallocate? #f])
+    (printf "~s\n" (list retain? release? deallocate?))
+    (define done? #f)
+    (define released? #f)
+    (let ([x (((allocator (lambda (v) (set! done? (symbol? v))))
+               gensym))])
+      (collect-garbage)
+      (sync (system-idle-evt))
+      (test #f done?)
+      (when retain?
+        (((retainer (lambda (v) (set! released? (symbol? v)))) void) x))
+      (when release?
+        (((releaser) void) x))
+      (when deallocate?
+        (((deallocator) void) x))
+      (void/reference-sink x)
+      (collect-garbage)
+      (sync (system-idle-evt))
+      (when retain?
+        (collect-garbage)
+        (sync (system-idle-evt)))
+      (test (or (not deallocate?) (and retain? (not release?))) done?)
+      (test (and retain? (not (or deallocate? release?))) released?)))
+
+  (unless (eq? 'cgc (system-type 'gc))
+    (check-allocator)
+    (check-allocator #:deallocate? #t)
+    (check-allocator #:retain? #t #:deallocate? #t)
+    (check-allocator #:retain? #t #:deallocate? #t #:release? #t)
+    (check-allocator #:retain? #t #:deallocate? #f #:release? #t))
+
+  (when (place-enabled?)
+    ;; Make sure deallocators are run when a place exits,
+    ;; and make sure they're run in the right order:
+    (define p (go-in-place))
+    (define bstr (make-shared-bytes 2 0))
+    (place-channel-put p bstr)
+    (void (place-wait p))
+    (test #"\x0A\x64" bstr)))
+
+(define (go-in-place)
+  (place p
+         (define bstr (place-channel-get p))
+         ;; These 10 should be deallocated later
+         (define orig
+           (for/list ([i 10])
+             (((allocator (lambda (v) (bytes-set! bstr 1 (+ (bytes-ref bstr 1) (bytes-ref bstr 0)))))
+               gensym))))
+         ;; These 10 should be deallocated earlier:
+         (define next
+           (for/list ([i 10])
+             (((allocator (lambda (v) (bytes-set! bstr 0 (+ (bytes-ref bstr 0) 1))))
+               gensym))))
+         (list next orig)))
+

racket/collects/ffi/unsafe/alloc.rkt

@@ -1,5 +1,9 @@
 #lang racket/base
 (require ffi/unsafe
+         (only-in '#%unsafe
+                  unsafe-add-post-custodian-shutdown
+                  unsafe-start-atomic
+                  unsafe-end-atomic)
          "atomic.rkt")
 
 (provide allocator deallocator retainer 
@@ -7,6 +11,12 @@
 
 (define allocated (make-late-weak-hasheq))
 
+;; A `node` is used to implement a doubly linked list that
+;; records the allocation order. That way, deallocators can
+;; be called in reverse order when a non-main place exits.
+(struct node (weak-val proc [next #:mutable] [prev #:mutable] rest)
+  #:authentic)
+
 ;; A way to show all still-unfinalized values on exit:
 #;
 (plumber-add-flush! (current-plumber)
@@ -15,13 +25,35 @@
                         (printf "~s\n" k))))
 
 (define (deallocate v)
-  ;; Called as a finalizer, we we assume that the
-  ;; enclosing thread will not be interrupted.
+  ;; Called either as finalizer (in the finalizer thread) or
+  ;; as a place is about to exit. Run in atomic mode to
+  ;; avoid a race with a place exit.
+  (unsafe-start-atomic)
   (let ([ds (hash-ref allocated v #f)])
     (when ds
       (hash-remove! allocated v)
-      (for ([d (in-list ds)])
-        (d v)))))
+      (let loop ([ds ds])
+        (when ds
+          (remove-node! ds)
+          ((node-proc ds) v)
+          (loop (node-rest ds))))))
+  (unsafe-end-atomic))
+
+(define (deallocate-one v expected-ds)
+  ;; Called for a place exit.
+  (let ([ds (hash-ref allocated v #f)])
+    (cond
+      [(eq? ds expected-ds)
+       (define rest-ds (node-rest ds))
+       (if rest-ds
+           (hash-set! allocated v rest-ds)
+           (hash-remove! allocated v))
+       (remove-node! ds)
+       ((node-proc ds) v)]
+      [else
+       ;; Not the expected node. Maybe an allocator
+       ;; replaced existing allocations/retains.
+       (remove-node! expected-ds)])))
 
 (define ((allocator d) proc)
   (rename
@@ -30,7 +62,9 @@
         (lambda ()
           (let ([v (apply proc args)])
             (when v
-              (hash-set! allocated v (list d))
+              (define ds (node (make-late-weak-box v) d #f #f #f))
+              (add-node! ds)
+              (hash-set! allocated v ds)
               (register-finalizer v deallocate))
             v))))
     proc))
@@ -44,10 +78,12 @@
          (let ([v (get-arg args)])
            (let ([ds (hash-ref allocated v #f)])
              (when ds
-               (if (null? (cdr ds))
-                   (hash-remove! allocated v)
-                   (hash-set! allocated v (cdr ds)))))))))
-   proc))
+               (remove-node! ds)
+               (define rest-ds (node-rest ds))
+               (if rest-ds
+                   (hash-set! allocated v rest-ds)
+                   (hash-remove! allocated v))))))))
+    proc))
 
 (define ((retainer d [get-arg car]) proc)
   (rename
@@ -57,8 +93,12 @@
          (begin0
            (apply proc args)
            (let ([v (get-arg args)])
-             (let ([ds (hash-ref allocated v null)])
-               (hash-set! allocated v (cons d ds))))))))
+             (define next-ds (hash-ref allocated v #f))
+             (define ds (node (make-late-weak-box v) d #f #f next-ds))
+             (add-node! ds)
+             (hash-set! allocated v ds)
+             (unless next-ds
+               (register-finalizer v deallocate)))))))
    proc))
 
 (define (rename new orig)
@@ -70,3 +110,36 @@
          (if n
              (procedure-rename new n)
              new))))
+
+;; ----------------------------------------
+
+(define all-nodes #f)
+
+(define (add-node! ds)
+  (set-node-next! ds all-nodes)
+  (when all-nodes
+    (set-node-prev! all-nodes ds))
+  (set! all-nodes ds))
+
+(define (remove-node! ds)
+  (define prev (node-prev ds))
+  (define next (node-next ds))
+  (if prev
+      (set-node-next! prev next)
+      (set! all-nodes next))
+  (when next
+    (set-node-prev! next prev)))
+
+(define (release-all)
+  (define ds all-nodes)
+  (when ds
+    (define v (weak-box-value (node-weak-val ds)))
+    (cond
+      [v (deallocate-one v ds)]
+      [else
+       (log-error "ffi/unsafe/alloc: internal error with a value deallocated by ~s" (node-proc ds))
+       (remove-node! ds)])
+    (release-all)))
+
+;; This is a no-op in the main place:
+(unsafe-add-post-custodian-shutdown release-all)

racket/collects/racket/unsafe/ops.rkt

@@ -30,6 +30,7 @@
                      unsafe-make-custodian-at-root
                      unsafe-custodian-register
                      unsafe-custodian-unregister
+                     unsafe-add-post-custodian-shutdown
                      unsafe-register-process-global
                      unsafe-get-place-table
                      unsafe-make-security-guard-at-root

racket/src/cs/primitive/unsafe.ss

@@ -5,6 +5,7 @@
   [check-not-unsafe-undefined/assign (known-procedure 4)]
   [prop:chaperone-unsafe-undefined (known-constant)]
   [unsafe-abort-current-continuation/no-wind (known-procedure 4)]
+  [unsafe-add-post-custodian-shutdown (known-procedure 2)]
   [unsafe-box*-cas! (known-procedure 8)]
   [unsafe-bytes-length (known-procedure/succeeds 2)]
   [unsafe-bytes-ref (known-procedure 4)]

racket/src/cs/rumble.sls

@@ -558,6 +558,7 @@
           place-channel place-dead-evt place-kill place-message-allowed?
           dynamic-place place-wait place-pumper-threads place-shared?
           unsafe-get-place-table
+          unsafe-add-post-custodian-shutdown
 
           _bool _bytes _short_bytes _double _double* _fixint _fixnum _float _fpointer _gcpointer
           _int16 _int32 _int64 _int8 _longdouble _pointer _scheme _stdbool _void

racket/src/cs/rumble/place.ss

@@ -21,6 +21,11 @@
     [(_ id ...)
      (begin (define-place-not-yet-available id) ...)]))
 
+;; This operation adds shutdown thunks to a non-main place, so it's a
+;; no-op for now:
+(define (unsafe-add-post-custodian-shutdown proc)
+  (void))
+
 (define-place-not-yet-available
   place-break
   place-channel-get

racket/src/racket/include/schthread.h

@@ -250,6 +250,7 @@ typedef struct Thread_Local_Variables {
   intptr_t scheme_current_cont_mark_pos_;
   struct Scheme_Custodian *main_custodian_;
   struct Scheme_Hash_Table *limited_custodians_;
+  struct Scheme_Object *post_custodian_shutdowns_;
   struct Scheme_Plumber *initial_plumber_;
   struct Scheme_Config *initial_config_;
   struct Scheme_Thread *swap_target_;
@@ -628,6 +629,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define main_custodian XOA (scheme_get_thread_local_variables()->main_custodian_)
 #define last_custodian XOA (scheme_get_thread_local_variables()->last_custodian_)
 #define limited_custodians XOA (scheme_get_thread_local_variables()->limited_custodians_)
+#define post_custodian_shutdowns XOA (scheme_get_thread_local_variables()->post_custodian_shutdowns_)
 #define initial_plumber XOA (scheme_get_thread_local_variables()->initial_plumber_)
 #define initial_config XOA (scheme_get_thread_local_variables()->initial_config_)
 #define swap_target XOA (scheme_get_thread_local_variables()->swap_target_)

racket/src/racket/src/env.c

@@ -590,6 +590,8 @@ void scheme_place_instance_destroy(int force)
   else
     scheme_run_atexit_closers_on_all(force_more_closed_after);
 
+  scheme_run_post_custodian_shutdown();
+
   scheme_release_fd_semaphores();
   
   scheme_release_file_descriptor();

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1431
+#define EXPECTED_PRIM_COUNT 1432
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schpriv.h

@@ -873,6 +873,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
 Scheme_Custodian *scheme_get_current_custodian(void);
 void scheme_run_atexit_closers_on_all(Scheme_Exit_Closer_Func alt);
 void scheme_run_atexit_closers(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);
+void scheme_run_post_custodian_shutdown();
 
 typedef struct Scheme_Security_Guard {
   Scheme_Object so;

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "7.0.0.3"
+#define MZSCHEME_VERSION "7.0.0.4"
 
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/thread.c

@@ -335,6 +335,8 @@ static Scheme_Object *unsafe_make_custodian_at_root(int argc, Scheme_Object *arg
 static Scheme_Object *unsafe_custodian_register(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_custodian_unregister(int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *unsafe_add_post_custodian_shutdown(int argc, Scheme_Object *argv[]);
+
 static Scheme_Object *unsafe_register_process_global(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_get_place_table(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[]);
@@ -478,6 +480,12 @@ extern BOOL WINAPI DllMain(HINSTANCE inst, ULONG reason, LPVOID reserved);
 
 SHARED_OK Scheme_Object *initial_cmdline_vec;
 
+#if defined(MZ_USE_PLACES)
+# define RUNNING_IN_ORIGINAL_PLACE (scheme_current_place_id == 0)
+#else
+# define RUNNING_IN_ORIGINAL_PLACE 1
+#endif
+
 /*========================================================================*/
 /*                             initialization                             */
 /*========================================================================*/
@@ -646,6 +654,8 @@ scheme_init_unsafe_thread (Scheme_Startup_Env *env)
   ADD_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env);
   ADD_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env);
 
+  ADD_PRIM_W_ARITY("unsafe-add-post-custodian-shutdown", unsafe_add_post_custodian_shutdown, 1, 1, env);
+
   ADD_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env);
   ADD_PRIM_W_ARITY("unsafe-get-place-table", unsafe_get_place_table, 0, 0, env);
 
@@ -1916,6 +1926,40 @@ void do_run_atexit_closers_on_all()
   scheme_run_atexit_closers_on_all(NULL);
 }
 
+static Scheme_Object *unsafe_add_post_custodian_shutdown(int argc, Scheme_Object *argv[])
+{
+  scheme_check_proc_arity("unsafe-add-post-custodian-shutdown", 0, 0, argc, argv);
+
+#if defined(MZ_USE_PLACES)
+  if (!RUNNING_IN_ORIGINAL_PLACE) {
+    if (!post_custodian_shutdowns) {
+      REGISTER_SO(post_custodian_shutdowns);
+      post_custodian_shutdowns = scheme_null;
+    }
+    
+    post_custodian_shutdowns = scheme_make_pair(argv[0], post_custodian_shutdowns);
+  }
+#endif
+  
+  return scheme_void;
+}
+
+void scheme_run_post_custodian_shutdown()
+{
+#if defined(MZ_USE_PLACES)
+  if (post_custodian_shutdowns) {
+    Scheme_Object *proc;
+    scheme_start_in_scheduler();
+    while (SCHEME_PAIRP(post_custodian_shutdowns)) {
+      proc = SCHEME_CAR(post_custodian_shutdowns);
+      post_custodian_shutdowns = SCHEME_CDR(post_custodian_shutdowns);
+      _scheme_apply_multi(proc, 0, NULL);
+    }
+    scheme_end_in_scheduler();
+  }
+#endif
+}
+
 void scheme_set_atexit(Scheme_At_Exit_Proc p)
 {
   replacement_at_exit = p;
@@ -1923,12 +1967,6 @@ void scheme_set_atexit(Scheme_At_Exit_Proc p)
 
 void scheme_add_atexit_closer(Scheme_Exit_Closer_Func f)
 {
-#if defined(MZ_USE_PLACES)
-# define RUNNING_IN_ORIGINAL_PLACE (scheme_current_place_id == 0)
-#else
-# define RUNNING_IN_ORIGINAL_PLACE 1
-#endif
-
   if (!cust_closers) {
     if (RUNNING_IN_ORIGINAL_PLACE) {
       scheme_atexit(do_run_atexit_closers_on_all);