add custodian-based unloading of foreign libraries

Specificially, add a `#:custodian` argument to `ffi-lib`.

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

@@ -18,7 +18,8 @@ Returns @racket[#t] if @racket[v] is a @deftech{foreign-library value},
                   [version (or/c string? (listof (or/c string? #f)) #f) #f]
 		  [#:get-lib-dirs get-lib-dirs (-> (listof path?)) get-lib-search-dirs]
 		  [#:fail fail (or/c #f (-> any)) #f]
-                  [#:global? global? any/c (eq? 'global (system-type 'so-mode))])
+                  [#:global? global? any/c (eq? 'global (system-type 'so-mode))]
+                  [#:custodian custodian (or/c 'place custodian? #f) #f])
          any]{
 
 Returns a @tech{foreign-library value} or the result of @racket[fail]. 
@@ -115,23 +116,43 @@ library's symbols are not made available for future resolution. This
 local-versus-global choice does not affect whether the library's
 symbols are available via @racket[(ffi-lib #f)].
 
+If @racket[custodian] is @racket['place] or a custodian, the
+library is unloaded when a custodian is shut down---either the given
+custodian or the place's main custodian if @racket[custodian] is
+@racket['place]. When a library is unloaded, all references to the
+library become invalid. Supplying @racket['place] for
+@racket[custodian] is consistent with finalization via
+@racketmodname[ffi/unsafe/alloc] but will not, for example, unload the
+library when hitting in the @onscreen{Run} button in DrRacket.
+Supplying @racket[(current-custodian)] for @racket[custodian] tends to
+unload the library for eagerly, but requires even more care to ensure
+that library references are not accessed after the library is
+unloaded.
+
+If @racket[custodian] is @racket[#f], the loaded library is associated
+with Racket (or DrRacket) for the duration of the process. Loading
+again with @racket[ffi-lib], will not force a re-load of the
+corresponding library.
+
+When @racket[ffi-lib] returns a reference to a library that was
+previously loaded within the current place, it increments a
+reference count on the loaded library rather than loading the library
+fresh. Unloading a library reference decrements the reference count
+and requests unloading at the operating-system level only if the
+reference count goes to zero.
+
 The @racket[ffi-lib] procedure logs (see @secref["logging" #:doc '(lib
 "scribblings/reference/reference.scrbl")]) on the topic
 @racket['ffi-lib]. In particular, on failure it logs the paths
 attempted according to the rules above, but it cannot report the
 paths tried due to the operating system's library search path.
 
-Due to the way the operating system performs dynamic binding, loaded
-libraries are associated with Racket (or DrRacket) for the duration of
-the process. Re-evaluating @racket[ffi-lib] (or hitting the
-@onscreen{Run} button in DrRacket) will not force a re-load of the
-corresponding library.
-
 @history[#:changed "6.1.0.5" @elem{Changed the way a version number is
                                    added with a @filepath{.dll} suffix
                                    to place it before the suffix,
                                    instead of after.}
-         #:changed "7.3.0.3" @elem{Added logging.}]}
+         #:changed "7.3.0.3" @elem{Added logging.}
+         #:changed "7.4.0.7" @elem{Added the @racket[#:custodian] argument.}]}
 
 @defproc[(get-ffi-obj [objname (or/c string? bytes? symbol?)]
                       [lib (or/c ffi-lib? path-string? #f)]

racket/collects/ffi/unsafe.rkt

@@ -4,7 +4,8 @@
 (require '#%foreign setup/dirs racket/unsafe/ops racket/private/for
          (only-in '#%unsafe
                   unsafe-thread-at-root
-                  unsafe-make-security-guard-at-root)
+                  unsafe-make-security-guard-at-root
+                  unsafe-add-post-custodian-shutdown)
          (for-syntax racket/base racket/list syntax/stx racket/syntax
                      racket/struct-info))
 
@@ -130,7 +131,8 @@
 (define (get-ffi-lib name [version/s ""]
 		     #:fail [fail #f]
 		     #:get-lib-dirs [get-lib-dirs get-lib-search-dirs]
-                     #:global? [global? (eq? (system-type 'so-mode) 'global)])
+                     #:global? [global? (eq? (system-type 'so-mode) 'global)]
+                     #:custodian [custodian #f])
   (cond
    [(not name) (ffi-lib name)] ; #f => NULL => open this executable
    [(not (or (string? name) (path? name)))
@@ -172,6 +174,7 @@
 				 (string-append name0 "." lib-suffix v)
 				 (string-append name0 v "." lib-suffix))))
 		       versions)])
+      (define lib
         (or ;; try to look in our library paths first
          (and (not absolute?)
               (ormap (lambda (dir)
@@ -198,11 +201,21 @@
                               (cond [(file-exists?/insecure attempt) " (exists)"]
                                     [else " (no such file)"])]
                              [else " (using OS library search path)"])))))
-         (if fail
+           (and (not fail)
-             (fail)
                 (if (pair? names)
                     (ffi-lib (car names) #f global?)
-                 (ffi-lib name0 #f global?))))))]))
+                    (ffi-lib name0 #f global?))))))
+      (cond
+        [lib
+         (when custodian
+           (unsafe-add-post-custodian-shutdown (lambda () (ffi-lib-unload lib))
+                                               (if (eq? custodian 'place)
+                                                   #f
+                                                   custodian)))
+         lib]
+        [fail
+         (fail)]
+        [else (error 'ffi-lib "internal error; shouldn't get here")]))]))
 
 (define (get-ffi-lib-internal x)
   (if (ffi-lib? x) x (get-ffi-lib x)))

racket/src/cs/Makefile

@@ -5,7 +5,7 @@ RACKET = ../../bin/racket
 SCHEME = scheme
 
 # Controls whether Racket layers are built as unsafe:
-UNSAFE_COMP = --unsafe
+UNSAFE_COMP = # --unsafe
 
 # Controls whether compiled code is compressed:
 COMPRESS_COMP = # --compress

racket/src/cs/io.sls

@@ -476,7 +476,7 @@
                              (1/log-message (|#%app| 1/current-logger) level str #f)))
   (set-error-display-eprintf! (lambda (fmt . args)
                                 (apply 1/fprintf (|#%app| 1/current-error-port) fmt args)))
-  (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ptr->address)
+  (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ffi-unload-lib ptr->address)
   (set-make-async-callback-poll-wakeup! unsafe-make-signal-received)
   (set-get-machine-info! get-machine-info)
   (set-processor-count! (1/processor-count))

racket/src/cs/rumble.sls

@@ -610,7 +610,7 @@
           ctype-alignof ctype-basetype ctype-c->scheme ctype-scheme->c ctype-sizeof ctype?
           end-stubborn-change extflvector->cpointer
           ffi-call ffi-call-maker ffi-callback ffi-callback-maker ffi-callback?
-          ffi-lib-name ffi-lib? ffi-obj ffi-obj-lib
+          ffi-lib-name ffi-lib? ffi-obj ffi-obj-lib ffi-lib-unload
           ffi-obj-name  ffi-obj? flvector->cpointer free free-immobile-cell lookup-errno
           make-array-type make-cstruct-type make-ctype make-late-weak-box make-late-weak-hasheq
           make-sized-byte-string make-union-type malloc malloc-immobile-cell

racket/src/cs/rumble/foreign.ss

@@ -748,6 +748,10 @@
                    (lambda (h)
                      (make-ffi-lib h name))))]))
 
+(define/who (ffi-lib-unload lib)
+  (check who ffi-lib? lib)
+  (ffi-unload-lib (ffi-lib-handle lib))) 
+
 (define-record-type (cpointer/ffi-obj make-ffi-obj ffi-obj?)
   (parent cpointer)
   (fields lib name))
@@ -777,6 +781,11 @@
         #f
         (success-k #f))))
 
+(define ffi-unload-lib
+  ;; Placeholder implementation that does nothing:
+  (lambda (lib)
+    (void)))
+
 (define ffi-get-obj
   ;; Placeholder implementation that always fails:
   (lambda (who lib lib-name name success-k)
@@ -790,9 +799,10 @@
   ;; Placeholder implementation
   (lambda (p) p))
 
-(define (set-ffi-get-lib-and-obj! do-ffi-get-lib do-ffi-get-obj do-ffi-ptr->address)
+(define (set-ffi-get-lib-and-obj! do-ffi-get-lib do-ffi-get-obj do-ffi-unload-lib do-ffi-ptr->address)
   (set! ffi-get-lib do-ffi-get-lib)
   (set! ffi-get-obj do-ffi-get-obj)
+  (set! ffi-unload-lib do-ffi-unload-lib)
   (set! ffi-ptr->address do-ffi-ptr->address))
 
 ;; ----------------------------------------

racket/src/io/foreign/main.rkt

@@ -10,7 +10,7 @@
          "../locale/string.rkt")
 
 (provide ffi-get-lib
-         ffi-lib-unload
+         ffi-unload-lib
          ffi-get-obj
          current-load-extension)
 
@@ -36,7 +36,7 @@
         (raise-dll-error who msg err-str dll)])]
     [else (success-k dll)]))
 
-(define/who (ffi-lib-unload dll)
+(define/who (ffi-unload-lib dll)
   (start-atomic)
   (define r (rktio_dll_close rktio dll))
   (cond

racket/src/racket/include/schthread.h

@@ -251,7 +251,6 @@ 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_;
@@ -639,7 +638,6 @@ 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

@@ -571,8 +571,6 @@ 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/mzmark_thread.inc

@@ -156,6 +156,7 @@ static int mark_custodian_val_MARK(void *p, struct NewGC *gc) {
   gcMARK2(m->closers, gc);
   gcMARK2(m->data, gc);
   gcMARK2(m->data_ptr, gc);
+  gcMARK2(m->post_callbacks, gc);
 
   gcMARK2(m->parent, gc);
   gcMARK2(m->sibling, gc);
@@ -184,6 +185,7 @@ static int mark_custodian_val_FIXUP(void *p, struct NewGC *gc) {
   gcFIXUP2(m->closers, gc);
   gcFIXUP2(m->data, gc);
   gcFIXUP2(m->data_ptr, gc);
+  gcFIXUP2(m->post_callbacks, gc);
 
   gcFIXUP2(m->parent, gc);
   gcFIXUP2(m->sibling, gc);

racket/src/racket/src/mzmarksrc.c

@@ -1691,6 +1691,7 @@ mark_custodian_val {
   gcMARK2(m->closers, gc);
   gcMARK2(m->data, gc);
   gcMARK2(m->data_ptr, gc);
+  gcMARK2(m->post_callbacks, gc);
 
   gcMARK2(m->parent, gc);
   gcMARK2(m->sibling, gc);

racket/src/racket/src/schpriv.h

@@ -850,6 +850,7 @@ struct Scheme_Custodian {
   Scheme_Close_Custodian_Client **closers;
   void **data;
   void ***data_ptr; /* points to `data`, registered as finalizer data for strong retention */
+  Scheme_Object *post_callbacks; /* additional callbacks run after all others */
 
   /* weak indirections: */
   Scheme_Custodian_Reference *parent;
@@ -877,7 +878,6 @@ 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/thread.c

@@ -650,7 +650,7 @@ 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-add-post-custodian-shutdown", unsafe_add_post_custodian_shutdown, 1, 2, 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);
@@ -1236,6 +1236,8 @@ Scheme_Custodian *scheme_make_custodian(Scheme_Custodian *parent)
   data_ptr = (void ***)scheme_malloc(sizeof(void**));
   m->data_ptr = data_ptr;
 
+  m->post_callbacks = scheme_null;
+
   insert_custodian(m, parent);
 
   scheme_add_finalizer(m, do_adjust_custodian_family, data_ptr);
@@ -1553,6 +1555,17 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
     }
 #endif
 
+    if (SCHEME_PAIRP(m->post_callbacks)) {
+      Scheme_Object *proc;
+      scheme_start_in_scheduler();
+      while (SCHEME_PAIRP(m->post_callbacks)) {
+        proc = SCHEME_CAR(m->post_callbacks);
+        m->post_callbacks = SCHEME_CDR(m->post_callbacks);
+        _scheme_apply_multi(proc, 0, NULL);
+      }
+      scheme_end_in_scheduler();
+    }
+
     m->count = 0;
     m->alloc = 0;
     m->elems = 0;
@@ -1950,38 +1963,33 @@ void do_run_atexit_closers_on_all()
 
 static Scheme_Object *unsafe_add_post_custodian_shutdown(int argc, Scheme_Object *argv[])
 {
+  Scheme_Custodian *c;
+  Scheme_Object *l;
+  
   scheme_check_proc_arity("unsafe-add-post-custodian-shutdown", 0, 0, argc, argv);
 
-#if defined(MZ_USE_PLACES)
+  if ((argc > 1)
-  if (!RUNNING_IN_ORIGINAL_PLACE) {
+      && !(SCHEME_FALSEP(argv[1])
-    if (!post_custodian_shutdowns) {
+           || SCHEME_CUSTODIANP(argv[1])))
-      REGISTER_SO(post_custodian_shutdowns);
+    scheme_wrong_contract("unsafe-add-post-custodian-shutdown", "custodian?", 1, argc, argv);
-      post_custodian_shutdowns = scheme_null;
-    }
 
-    post_custodian_shutdowns = scheme_make_pair(argv[0], post_custodian_shutdowns);
+  if ((argc > 1) && !SCHEME_FALSEP(argv[1]))
-  }
+    c = (Scheme_Custodian *)argv[1];
+  else
+    c = main_custodian;
+
+#if defined(MZ_USE_PLACES)
+  if (RUNNING_IN_ORIGINAL_PLACE
+      && (c == main_custodian))
+    return scheme_void;
 #endif
       
+  l = scheme_make_pair(argv[0], c->post_callbacks);
+  c->post_callbacks = l;
+  
   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;

racket/src/rktio/rktio_dll.c

@@ -139,6 +139,9 @@ rktio_ok_t rktio_dll_close(rktio_t *rktio, rktio_dll_t *dll)
 {
   int ok = 1;
 
+  if (!dll->name)
+    return ok;
+  
   dll->refcount--;
   if (dll->refcount)
     return ok;

racket/src/thread/custodian-object.rkt

@@ -22,7 +22,8 @@
                    [gc-roots #:mutable]   ; weak references to charge to custodian; access without interrupts
                    [memory-limits #:mutable]   ; list of (cons limit cust)
                    [immediate-limit #:mutable] ; limit on immediate allocation
-                   [sync-futures? #:mutable])  ; whether a sync witht future threads is needed on shutdown
+                   [sync-futures? #:mutable]   ; whether a sync witht future threads is needed on shutdown
+                   [post-shutdown #:mutable])  ; callbacks to run in atomic mode after shutdown
   #:authentic)
 
 (define (create-custodian parent)
@@ -37,7 +38,8 @@
              #f     ; GC roots
              null   ; memory limits
              #f     ; immediate limit
-             #f))   ; sync-futures?
+             #f     ; sync-futures?
+             null)) ; post-shutdown
 
 ;; Call only from a place's main pthread, and only a
 ;; place's main thread should change the box value.

racket/src/thread/custodian.rkt

@@ -33,9 +33,10 @@
          custodian-register-thread
          custodian-register-place
          raise-custodian-is-shut-down
-         set-post-shutdown-action!
+         unsafe-add-post-custodian-shutdown
          check-queued-custodian-shutdown
          set-place-custodian-procs!
+         set-post-shutdown-action!
          custodian-check-immediate-limit)
 
 (module+ scheduling
@@ -186,6 +187,10 @@
     (when self-ref
       (set-custodian-reference-c! self-ref (custodian-self-reference parent)))
     (hash-clear! (custodian-children c))
+    (set-custodian-post-shutdown! parent
+                                  (append (custodian-post-shutdown c)
+                                          (custodian-post-shutdown parent)))
+    (set-custodian-post-shutdown! c null)
     (when gc-roots (hash-clear! gc-roots))))
   
 ;; Called in scheduler thread:
@@ -274,6 +279,9 @@
           (callback child c)
           (callback child)))
     (hash-clear! (custodian-children c))
+    (for ([proc (in-list (custodian-post-shutdown c))])
+      (proc))
+    (set-custodian-post-shutdown! c null)
     (let ([sema (custodian-shutdown-sema c)])
       (when sema
         (semaphore-post-all sema)))
@@ -291,6 +299,15 @@
            (semaphore-post-all sema))
          sema))))
 
+(define/who (unsafe-add-post-custodian-shutdown proc [custodian #f])
+  (check who (procedure-arity-includes/c 0) proc)
+  (check who custodian? #:or-false custodian)
+  (define c (or custodian (place-custodian current-place)))
+  (unless (and (not (place-parent current-place))
+               (eq? c (place-custodian current-place)))
+    (atomically
+     (set-custodian-post-shutdown! c (cons proc (custodian-post-shutdown c))))))
+
 (define (custodian-subordinate? c super-c)
   (let loop ([p-cref (custodian-parent-reference c)])
     (define p (and p-cref (custodian-reference->custodian p-cref)))

racket/src/thread/place.rkt

@@ -34,8 +34,7 @@
          place-channel-put
 
          set-make-place-ports+fds!
-         place-pumper-threads
+         place-pumper-threads)
-         unsafe-add-post-custodian-shutdown)
 
 ;; For `(struct place ...)`, see "place-object.rkt"
 
@@ -441,13 +440,6 @@
 (define (place-pumper-threads p vec)
   (set-place-pumpers! p vec))
 
-(define (unsafe-add-post-custodian-shutdown proc)
-  (when (place-parent current-place)
-    (atomically
-     (set-place-post-shutdown! current-place
-                               (cons proc
-                                     (place-post-shutdown current-place))))))
-
 (void (set-place-custodian-procs!
        (lambda ()
          (atomically (ensure-wakeup-handle!))