add `ffi/unsafe/custodian'

collects/ffi/unsafe/custodian.rkt

@@ -0,0 +1,41 @@
+#lang racket/base
+(require ffi/unsafe)
+
+(provide (protect-out register-custodian-shutdown
+                      unregister-custodian-shutdown))
+
+(define _Scheme_Custodian_Reference-pointer
+  (_gcable (_cpointer 'Scheme_Custodian_Reference)))
+
+(define scheme_add_managed
+  (get-ffi-obj 'scheme_add_managed #f
+               (_fun _racket _racket _fpointer _racket _int
+                     -> _Scheme_Custodian_Reference-pointer)))
+(define scheme_add_managed_close_on_exit
+  (get-ffi-obj 'scheme_add_managed_close_on_exit #f
+               (_fun _racket _racket _fpointer _racket
+                     -> _Scheme_Custodian_Reference-pointer)))
+
+(define scheme_remove_managed
+  (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
+  (cast shutdown-callback (_fun #:atomic? #t _racket _racket -> _void) _fpointer))
+
+(define (register-custodian-shutdown obj proc [custodian (current-custodian)]
+                                     #:atexit? [atexit? #f]
+                                     #:weak? [weak? #f])
+  (define proc+self (cons proc
+                          shutdown-callback)) ; proc as data -> ffi callback retained
+  (if atexit?
+      (scheme_add_managed_close_on_exit custodian
+                                        obj shutdown_callback proc+self)
+      (scheme_add_managed custodian
+                          obj shutdown_callback proc+self
+                          (if weak? 0 1))))
+
+(define (unregister-custodian-shutdown obj mref)
+  (scheme_remove_managed mref obj))

collects/scribblings/foreign/custodian.scrbl

@@ -0,0 +1,46 @@
+#lang scribble/doc
+@(require "utils.rkt"
+          (for-label ffi/unsafe/custodian))
+
+@title{Custodian Shutdown Registration}
+
+@defmodule[ffi/unsafe/custodian]{The
+@racketmodname[ffi/unsafe/custodian] library provides utilities for
+registering shutdown callbacks with custodians.}
+
+@defproc[(register-custodian-shutdown [v any/c]
+                                      [callback (any/c . -> . any)]
+                                      [custodian custodian? (current-custodian)]
+                                      [#:atexit? atexit? any/c #f]
+                                      [#:weak? weak? any/c #f])
+          cpointer?]{
+
+Registers @racket[callback] to be applied (in atomic mode and an
+unspecified Racket thread) to @racket[v] when @racket[custodian] is
+shutdown. The result is a pointer that can be supplied to
+@racket[unregister-custodian-shutdown] to remove the registration.
+
+If @racket[atexit?] is true, then @racket[callback] is applied when
+Racket exits, even if the custodian is not explicitly shut down.
+
+If @racket[weak?]  is true, then @racket[callback] may not be called
+if @racket[v] is determined to be unreachable during garbage
+collection.  The value @racket[v] is always weakly held by the
+custodian, even if @racket[weak?] is @racket[#f]; see
+@cpp{scheme_add_managed} for more information.
+
+Normally, @racket[weak?] should be false. To trigger actions based on
+finalization or custodian shutdown---whichever happens first---leave
+@racket[weak?] as @racket[#f] and have a finalizer cancel the shutdown
+action via @racket[unregister-custodian-shutdown]. Otherwise, a
+not-yet-run finalizer may remain pending after the custodian is
+shutdown.}
+
+
+@defproc[(unregister-custodian-shutdown [v any/c]
+                                        [registration _cpointer])
+         void?]{
+
+Cancels a custodian-shutdown registration, where @racket[registration]
+is a previous result from @racket[register-custodian-shutdown] applied
+to @racket[v].}

collects/scribblings/foreign/derived.scrbl

@@ -10,6 +10,7 @@
 @include-section["cpointer.scrbl"]
 @include-section["define.scrbl"]
 @include-section["alloc.scrbl"]
+@include-section["custodian.scrbl"]
 @include-section["atomic.scrbl"]
 @include-section["try-atomic.scrbl"]
 @include-section["objc.scrbl"]

collects/scribblings/foreign/intro.scrbl

@@ -504,6 +504,11 @@ finalizer for the function's argument.  An @racket[allocator] wrapper
 refers to the deallocator, so that the deallocator can be run if
 necessary by a finalizer.
 
+If a resource is scarce or visible to end users, then @tech[#:doc
+reference.scrbl]{custodian} management is more appropriate than
+mere finalization as implemented by @racket[allocator]. See the
+@racketmodname[ffi/unsafe/custodian] library.
+
 @; ------------------------------------------------------------
 
 @section{More Examples}

collects/scribblings/foreign/pointers.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "utils.rkt")
+@(require "utils.rkt"
+          (for-label ffi/unsafe/custodian))
 
 @title[#:tag "foreign:pointer-funcs"]{Pointer Functions}
 
@@ -313,8 +314,9 @@ Registers a finalizer procedure @racket[finalizer-proc] with the given
 @racket[obj], which can be any Racket (GC-able) object.  The finalizer
 is registered with a will executor; see
 @racket[make-will-executor]. The finalizer is invoked when
-@racket[obj] is about to be collected.  (This is done by a thread that
+@racket[obj] is about to be collected.  (The finalizer is invoked in a
-is in charge of triggering these will executors.)
+thread that is in charge of triggering these will executors.)
+See also @racket[register-custodian-shutdown].
 
 Finalizers are mostly intended to be used with cpointer objects (for
 freeing unused memory that is not under GC control), but it can be

collects/scribblings/inside/custodians.scrbl

@@ -64,6 +64,16 @@ If @var{m} (or the current custodian if @var{m} is @cpp{NULL})is shut
 down, then @var{f} is called immediately, and the result is
 @cpp{NULL}.}
 
+@function[(Scheme_Custodian_Reference* scheme_add_managed_close_on_exit
+           [Scheme_Custodian* m]
+           [Scheme_Object* o]
+           [Scheme_Close_Custodian_Client* f]
+           [void* data])]{
+
+Like @cpp{scheme_add_managed} with a @cpp{1} final argument, but also
+causes @var{f} to be called when Racket exists without an explicit
+custodian shutdown.}
+
 @function[(void scheme_custodian_check_available
            [Scheme_Custodian* m]
            [const-char* name]
@@ -107,7 +117,8 @@ where @var{d} is the second argument for @var{f}.
 
 At-exit functions are run in reverse of the order that they are
 added. An at-exit function is initially registered (and therefore runs
-last) that flushes each file-stream output port.
+last) that flushes each file-stream output port and calls every
+function registered with @cpp{scheme_add_managed_close_on_exit}.
 
 An at-exit function should not necessarily apply the closer function
 for every object that it is given. In particular, shutting down a

collects/tests/racket/ffi-custodian.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+(require ffi/unsafe/custodian)
+
+(define c (make-custodian))
+
+(define done? #f)
+
+(define val (cons 1 2))
+
+(define (reg)
+  (register-custodian-shutdown val
+                               (lambda (x)
+                                 (when done? (error "duplicate!"))
+                                 (set! done? (equal? x '(1 . 2))))
+                               c
+                               #:atexit? #t))
+
+(unregister-custodian-shutdown val (reg))
+(void (reg))
+
+(custodian-shutdown-all c)
+
+(unless done?
+  (error "shutdown didn't work"))

src/racket/include/mzwin.def

@@ -65,6 +65,7 @@ EXPORTS
  scheme_tls_get
  scheme_make_custodian
  scheme_add_managed
+ scheme_add_managed_close_on_exit
  scheme_custodian_check_available
  scheme_custodian_is_available
  scheme_remove_managed

src/racket/include/mzwin3m.def

@@ -65,6 +65,7 @@ EXPORTS
  scheme_tls_get
  scheme_make_custodian
  scheme_add_managed
+ scheme_add_managed_close_on_exit
  scheme_custodian_check_available
  scheme_custodian_is_available
  scheme_remove_managed

src/racket/include/racket.exp

@@ -63,6 +63,7 @@ scheme_tls_set
 scheme_tls_get
 scheme_make_custodian
 scheme_add_managed
+scheme_add_managed_close_on_exit
 scheme_custodian_check_available
 scheme_custodian_is_available
 scheme_remove_managed

src/racket/include/racket3m.exp

@@ -63,6 +63,7 @@ scheme_tls_set
 scheme_tls_get
 scheme_make_custodian
 scheme_add_managed
+scheme_add_managed_close_on_exit
 scheme_custodian_check_available
 scheme_custodian_is_available
 scheme_remove_managed

src/racket/src/schemef.h

@@ -153,6 +153,9 @@ MZ_EXTERN Scheme_Custodian *scheme_make_custodian(Scheme_Custodian *);
 MZ_EXTERN Scheme_Custodian_Reference *scheme_add_managed(Scheme_Custodian *m, Scheme_Object *o,
 							 Scheme_Close_Custodian_Client *f, void *data,
 							 int strong);
+MZ_EXTERN Scheme_Custodian_Reference *scheme_add_managed_close_on_exit(Scheme_Custodian *m, Scheme_Object *o, 
+                                                                       Scheme_Close_Custodian_Client *f, void *data);
+
 MZ_EXTERN void scheme_custodian_check_available(Scheme_Custodian *m, const char *who, const char *what);
 MZ_EXTERN int scheme_custodian_is_available(Scheme_Custodian *m);
 MZ_EXTERN void scheme_remove_managed(Scheme_Custodian_Reference *m, Scheme_Object *o);

src/racket/src/schemex.h

@@ -107,6 +107,8 @@ Scheme_Custodian *(*scheme_make_custodian)(Scheme_Custodian *);
 Scheme_Custodian_Reference *(*scheme_add_managed)(Scheme_Custodian *m, Scheme_Object *o,
 							 Scheme_Close_Custodian_Client *f, void *data,
 							 int strong);
+Scheme_Custodian_Reference *(*scheme_add_managed_close_on_exit)(Scheme_Custodian *m, Scheme_Object *o, 
+                                                                       Scheme_Close_Custodian_Client *f, void *data);
 void (*scheme_custodian_check_available)(Scheme_Custodian *m, const char *who, const char *what);
 int (*scheme_custodian_is_available)(Scheme_Custodian *m);
 void (*scheme_remove_managed)(Scheme_Custodian_Reference *m, Scheme_Object *o);

src/racket/src/schemex.inc

@@ -71,6 +71,7 @@
   scheme_extension_table->scheme_tls_get = scheme_tls_get;
   scheme_extension_table->scheme_make_custodian = scheme_make_custodian;
   scheme_extension_table->scheme_add_managed = scheme_add_managed;
+  scheme_extension_table->scheme_add_managed_close_on_exit = scheme_add_managed_close_on_exit;
   scheme_extension_table->scheme_custodian_check_available = scheme_custodian_check_available;
   scheme_extension_table->scheme_custodian_is_available = scheme_custodian_is_available;
   scheme_extension_table->scheme_remove_managed = scheme_remove_managed;

src/racket/src/schemexm.h

@@ -71,6 +71,7 @@
 #define scheme_tls_get (scheme_extension_table->scheme_tls_get)
 #define scheme_make_custodian (scheme_extension_table->scheme_make_custodian)
 #define scheme_add_managed (scheme_extension_table->scheme_add_managed)
+#define scheme_add_managed_close_on_exit (scheme_extension_table->scheme_add_managed_close_on_exit)
 #define scheme_custodian_check_available (scheme_extension_table->scheme_custodian_check_available)
 #define scheme_custodian_is_available (scheme_extension_table->scheme_custodian_is_available)
 #define scheme_remove_managed (scheme_extension_table->scheme_remove_managed)

src/racket/src/thread.c

@@ -872,7 +872,7 @@ static void ensure_custodian_space(Scheme_Custodian *m, int k)
       m->alloc += k;
     
     naya_boxes = MALLOC_N(Scheme_Object**, m->alloc);
-    naya_closers = MALLOC_N(Scheme_Close_Custodian_Client*, m->alloc);
+    naya_closers = MALLOC_N_ATOMIC(Scheme_Close_Custodian_Client*, m->alloc);
     naya_data = MALLOC_N(void*, m->alloc);
     naya_mrefs = MALLOC_N(Scheme_Custodian_Reference*, m->alloc);
 
@@ -1222,6 +1222,36 @@ Scheme_Custodian_Reference *scheme_add_managed(Scheme_Custodian *m, Scheme_Objec
   return mr;
 }
 
+static void chain_close_at_exit(Scheme_Object *o, void *_data)
+/* This closer is recognized specially in scheme_run_atexit_closers() */
+{
+  Scheme_Object *data = (Scheme_Object *)_data;
+  Scheme_Close_Custodian_Client *f;
+  void **fp;
+  
+  fp = (void **)SCHEME_CAR(data);
+  
+  if (fp) {
+    f = (Scheme_Close_Custodian_Client *)*fp;
+    SCHEME_CAR(data) = NULL;
+    f(o, SCHEME_CDR(data));
+  }
+}
+
+Scheme_Custodian_Reference *scheme_add_managed_close_on_exit(Scheme_Custodian *m, Scheme_Object *o, 
+                                                             Scheme_Close_Custodian_Client *f, void *data)
+{
+  void **p;
+
+  p = (void **)scheme_malloc_atomic(sizeof(void *));
+  *p = f;
+
+  return scheme_add_managed(m, o, 
+                            chain_close_at_exit, scheme_make_raw_pair((Scheme_Object *)p, 
+                                                                      (Scheme_Object *)data),
+                            1);
+}
+
 void scheme_remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o)
 {
   /* Is this a good idea? I'm not sure: */
@@ -1704,6 +1734,9 @@ void scheme_run_atexit_closers(Scheme_Object *o, Scheme_Close_Custodian_Client *
       cf(o, f, data);
     }
   }
+
+  if (f == chain_close_at_exit)
+    f(o, data);
 }
 
 void scheme_run_atexit_closers_on_all(Scheme_Exit_Closer_Func alt)