From d9ec0705cfb0ed0f70ff2917d5eda8dc41892cfa Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 29 Jul 2018 13:30:02 -0600
Subject: [PATCH] add `ffi/unsafe/collect-callback`

The `ffi/unsafe/collect-callback` library exposes functionality
formerly only available via Racket's C interface, but implement
it for both Racket and RacketCs.
---
 pkgs/base/info.rkt                            |  2 +-
 .../foreign/collect-callback.scrbl            | 94 +++++++++++++++++++
 .../scribblings/foreign/derived.scrbl         |  1 +
 .../scribblings/inside/memory.scrbl           | 62 ++----------
 .../collects/ffi/unsafe/collect-callback.rkt  |  5 +
 racket/collects/racket/unsafe/ops.rkt         |  4 +-
 racket/src/cs/primitive/unsafe.ss             |  2 +
 racket/src/cs/rumble.sls                      |  2 +
 racket/src/cs/rumble/memory.ss                | 91 +++++++++++++++++-
 racket/src/racket/src/schminc.h               |  2 +-
 racket/src/racket/src/schvers.h               |  4 +-
 racket/src/racket/src/thread.c                | 18 ++++
 12 files changed, 226 insertions(+), 61 deletions(-)
 create mode 100644 pkgs/racket-doc/scribblings/foreign/collect-callback.scrbl
 create mode 100644 racket/collects/ffi/unsafe/collect-callback.rkt

diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt
index 8a6560a1a0..d92eb2d3d9 100644
--- a/pkgs/base/info.rkt
+++ b/pkgs/base/info.rkt
@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.0.0.8")
+(define version "7.0.0.9")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))
diff --git a/pkgs/racket-doc/scribblings/foreign/collect-callback.scrbl b/pkgs/racket-doc/scribblings/foreign/collect-callback.scrbl
new file mode 100644
index 0000000000..4d43cc4b83
--- /dev/null
+++ b/pkgs/racket-doc/scribblings/foreign/collect-callback.scrbl
@@ -0,0 +1,94 @@
+#lang scribble/doc
+@(require "utils.rkt"
+          (for-label ffi/unsafe/collect-callback))
+
+@title{Garbage Collection Callbacks}
+
+@defmodule[ffi/unsafe/collect-callback]{The
+@racketmodname[ffi/unsafe/collect-callback] library provides functions
+to register constrained callbacks that are run just before and after a
+garbage collection.}
+
+@history[#:added "7.0.0.9"]
+
+
+@defproc[(unsafe-add-collect-callbacks [pre (vectorof vector?)]
+                                       [post (vectorof vector?)])
+         any/c]{
+
+Registers descriptions of foreign functions to be called just before
+and just after a garbage collection. The foreign functions must not
+allocate garbage-collected memory, and they are called in a way that
+does not allocate, which is why @var{pre_desc} and @var{post_desc} are
+function descriptions instead of thunks.
+
+A description is a vector of vectors, where each of the inner vectors
+describes a single call, and the calls are performed in sequence. Each
+call vector starts with a symbol that indicates the protocol of the
+foreign function to be called. The following protocols are supported:
+@margin-note*{The apparently arbitrary and whimsical set of supported
+protocols is enough to allow DrRacket to show a garbage-collection
+icon.}
+
+@itemlist[
+
+ @item{@racket['int->void] corresponds to @cpp{void (*)(int)}.}
+
+ @item{@racket['ptr_ptr_ptr->void] corresponds to @cpp{void
+ (*)(void*, void*, void*)}.}
+
+ @item{@racket['ptr_ptr->save] corresponds to @cpp{void* (*)(void*,
+ void*, void*)}, but the result is recored as the current ``save''
+ value. The current ``save'' value starts as @cpp{NULL}.}
+
+ @item{@racket['save!_ptr->void] corresponds to @cpp{void (*)(void*,
+ void*)}, but only if the current ``save'' value is not a @cpp{NULL}
+ pointer, and passing that pointer as the function's first argument
+ (so that only one additional argument is us from the description
+ vector).}
+
+ @item{@racket['ptr_ptr_ptr_int->void] corresponds to @cpp{void
+ (*)(void*, void*, void*, int)}.}
+
+ @item{@racket['ptr_ptr_float->void] corresponds to @cpp{void
+ (*)(void*, void*, float)}.}
+
+ @item{@racket['ptr_ptr_double->void] corresponds to @cpp{void
+ (*)(void*, void*, double)}.}
+
+ @item{@racket['ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void]
+ corresponds to @cpp{void (*)(void*, void*, void*, int, int, int, int,
+ int, int, int, int, int)}.}
+
+ @item{@racket['osapi_ptr_int->void] corresponds to @cpp{void
+ (*)(void*, int)}, but using the stdcall calling convention
+ on Windows.}
+
+ @item{@racket['osapi_ptr_ptr->void] corresponds to @cpp{void
+ (*)(void*, void*)}, but using the stdcall calling convention
+ on Windows.}
+
+ @item{@racket['osapi_ptr_int_int_int_int_ptr_int_int_long->void]
+ corresponds to @cpp{void (*)(void*, int, int, int, int, void*,
+ int, int, long)}, but using the stdcall calling convention
+ on Windows.}
+
+]
+
+After the protocol symbol, the vector should contain a pointer to a
+foreign function and then an element for each of the function's
+arguments. Pointer values are represented as for the @racket[_pointer]
+representation defined by @racketmodname[ffi/unsafe].
+
+The result is a key for use with @cpp{scheme_remove_gc_callback}. If
+the key becomes inaccessible, then the callback will be removed
+automatically (but beware that the pre-callback will have executed and
+the post-callback will not have executed)
+
+}
+
+@defproc[(unsafe-remove-collect-callbacks [key any/c]) void?]{
+
+Unregisters pre- and post-collection callbacks that were previously
+registered by a call to @racket[unsafe-add-collect-callbacks] that
+returned @racket[v].}
diff --git a/pkgs/racket-doc/scribblings/foreign/derived.scrbl b/pkgs/racket-doc/scribblings/foreign/derived.scrbl
index 8942e74149..8f7dbaec46 100644
--- a/pkgs/racket-doc/scribblings/foreign/derived.scrbl
+++ b/pkgs/racket-doc/scribblings/foreign/derived.scrbl
@@ -18,6 +18,7 @@
 @include-section["port.scrbl"]
 @include-section["global.scrbl"]
 @include-section["os-thread.scrbl"]
+@include-section["collect-callback.scrbl"]
 @include-section["objc.scrbl"]
 @include-section["ns.scrbl"]
 @include-section["com.scrbl"]
diff --git a/pkgs/racket-doc/scribblings/inside/memory.scrbl b/pkgs/racket-doc/scribblings/inside/memory.scrbl
index ab9555c4f5..2866164484 100644
--- a/pkgs/racket-doc/scribblings/inside/memory.scrbl
+++ b/pkgs/racket-doc/scribblings/inside/memory.scrbl
@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "utils.rkt" (for-label ffi/unsafe))
+@(require "utils.rkt" (for-label ffi/unsafe
+                                 ffi/unsafe/collect-callback))
 
 @title[#:tag "im:memoryalloc"]{Memory Allocation}
 
@@ -1176,60 +1177,11 @@ array @var{shape}, so the array need not be retained.
 @function[(Scheme_Object* scheme_add_gc_callback [Scheme_Object* pre_desc]
                                                  [Scheme_Object* post_desc])]{
 
-Registers descriptions of foreign functions to be called just before
-and just after a garbage collection. The foreign functions must not
-allocate garbage-collected memory, and they are called in a way that
-does not allocate, which is why @var{pre_desc} and @var{post_desc} are
-function descriptions instead of thunks.
-
-A description is a vector of vectors, where each of the inner vectors
-describes a single call, and the calls are performed in sequence. Each
-call vector starts with a symbol that indicates the protocol of the
-foreign function to be called. The following protocols are supported:
-
-@itemlist[
-
- @item{@racket['ptr_ptr_ptr->void] corresponds to @cpp{void
- (*)(void*, void*, void*)}.}
-
- @item{@racket['ptr_ptr_ptr_int->void] corresponds to @cpp{void
- (*)(void*, void*, void*, int)}.}
-
- @item{@racket['ptr_ptr_float->void] corresponds to @cpp{void
- (*)(void*, void*, float)}.}
-
- @item{@racket['ptr_ptr_double->void] corresponds to @cpp{void
- (*)(void*, void*, double)}.}
-
- @item{@racket['ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void]
- corresponds to @cpp{void (*)(void*, void*, void*, int, int, int, int,
- int, int, int, int, int)}.}
-
- @item{@racket['osapi_ptr_int->void] corresponds to @cpp{void
- (*)(void*, int)}, but using the stdcall calling convention
- on Windows.}
-
- @item{@racket['osapi_ptr_ptr->void] corresponds to @cpp{void
- (*)(void*, void*)}, but using the stdcall calling convention
- on Windows.}
-
- @item{@racket['osapi_ptr_int_int_int_int_ptr_int_int_long->void]
- corresponds to @cpp{void (*)(void*, int, int, int, int, void*,
- int, int, long)}, but using the stdcall calling convention
- on Windows.}
-
-]
-
-After the protocol symbol, the vector should contain a pointer to a
-foreign function and then an element for each of the function's
-arguments. Pointer values are represented as for the @racket[_pointer]
-representation defined by @racketmodname[ffi/unsafe].
-
-The result is a key for use with @cpp{scheme_remove_gc_callback}. If
-the key becomes inaccessible, then the callback will be removed
-automatically (but beware that the pre-callback will have executed and
-the post-callback will not have executed).}
+The same as @racket[unsafe-add-collect-callbacks] from
+@racketmodname[ffi/unsafe/collect-callback].}
 
 @function[(void scheme_remove_gc_callback [Scheme_Object* key])]{
 
-Removes a garbage-collection callback installed with @cpp{scheme_add_gc_callback}.}
+The same as @racket[unsafe-remove-collect-callbacks], removes
+garbage-collection callbacks installed with
+@cpp{scheme_add_gc_callback}.}
diff --git a/racket/collects/ffi/unsafe/collect-callback.rkt b/racket/collects/ffi/unsafe/collect-callback.rkt
new file mode 100644
index 0000000000..0ec41e2962
--- /dev/null
+++ b/racket/collects/ffi/unsafe/collect-callback.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+(require '#%unsafe)
+
+(provide unsafe-add-collect-callbacks
+         unsafe-remove-collect-callbacks)
diff --git a/racket/collects/racket/unsafe/ops.rkt b/racket/collects/racket/unsafe/ops.rkt
index 97f1b56ef3..e632cfc424 100644
--- a/racket/collects/racket/unsafe/ops.rkt
+++ b/racket/collects/racket/unsafe/ops.rkt
@@ -41,7 +41,9 @@
                      unsafe-call-in-os-thread
                      unsafe-make-os-semaphore
                      unsafe-os-semaphore-post
-                     unsafe-os-semaphore-wait)
+                     unsafe-os-semaphore-wait
+                     unsafe-add-collect-callbacks
+                     unsafe-remove-collect-callbacks)
          (rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure]
                      [new:unsafe-chaperone-procedure unsafe-chaperone-procedure])
          (prefix-out unsafe-
diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss
index 571038302e..cb9d4ca694 100644
--- a/racket/src/cs/primitive/unsafe.ss
+++ b/racket/src/cs/primitive/unsafe.ss
@@ -6,6 +6,7 @@
   [prop:chaperone-unsafe-undefined (known-constant)]
   [unsafe-abort-current-continuation/no-wind (known-procedure 4)]
   [unsafe-add-post-custodian-shutdown (known-procedure 2)]
+  [unsafe-add-collect-callbacks (known-procedure 4)]
   [unsafe-box*-cas! (known-procedure 8)]
   [unsafe-bytes-length (known-procedure/succeeds 2)]
   [unsafe-bytes-ref (known-procedure 4)]
@@ -123,6 +124,7 @@
   [unsafe-port->file-descriptor (known-procedure 2)]
   [unsafe-port->socket (known-procedure 2)]
   [unsafe-register-process-global (known-procedure 4)]
+  [unsafe-remove-collect-callbacks (known-procedure 2)]
   [unsafe-s16vector-ref (known-procedure 4)]
   [unsafe-s16vector-set! (known-procedure 8)]
   [unsafe-set-box! (known-procedure 4)]
diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls
index 393394292b..061b49d14e 100644
--- a/racket/src/cs/rumble.sls
+++ b/racket/src/cs/rumble.sls
@@ -453,6 +453,8 @@
           make-phantom-bytes
           set-phantom-bytes!
           set-garbage-collect-notify! ; not exported to Racket
+          unsafe-add-collect-callbacks
+          unsafe-remove-collect-callbacks
 
           ;; not the same as Racket will executors:
           (rename
diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss
index f7731f9c26..8469f4d3f6 100644
--- a/racket/src/cs/rumble/memory.ss
+++ b/racket/src/cs/rumble/memory.ss
@@ -52,6 +52,7 @@
                     [(zero? (bitwise-and c collect-generation-radix-mask))
                      (loop (bitwise-arithmetic-shift-right c log-collect-generation-radix) (add1 gen))]
                     [else gen]))])])
+      (run-collect-callbacks car)
       (collect gen)
       (let ([post-allocated (bytes-allocated)])
         (when (= gen (collect-maximum-generation))
@@ -59,7 +60,8 @@
         (garbage-collect-notify gen
                                 pre-allocated pre-allocated+overhead pre-time pre-cpu-time
                                 post-allocated  (current-memory-bytes) (real-time) (cpu-time)))
-      (poll-foreign-guardian))))
+      (poll-foreign-guardian)
+      (run-collect-callbacks cdr))))
 
 (define collect-garbage
   (case-lambda
@@ -295,3 +297,90 @@
   (check who phantom-bytes? phantom-bstr)
   (check who exact-nonnegative-integer? k)
   (phantom-bytes-size-set! phantom-bstr k))
+
+;; ----------------------------------------
+
+;; List of (cons <pre> <post>)
+(define collect-callbacks '())
+
+(define (unsafe-add-collect-callbacks pre post)
+  (let ([p (cons pre post)])
+    (with-interrupts-disabled
+     (set! collect-callbacks (cons p collect-callbacks)))
+    p))
+
+(define (unsafe-remove-collect-callbacks p)
+  (with-interrupts-disabled
+   (set! collect-callbacks (#%remq p collect-callbacks))))
+
+(define (run-collect-callbacks sel)
+  (let loop ([l collect-callbacks])
+    (unless (null? l)
+      (let ([v (sel (car l))])
+        (let loop ([i 0] [save #f])
+          (unless (fx= i (#%vector-length v))
+            (loop (fx+ i 1)
+                  (run-one-collect-callback (#%vector-ref v i) save sel))))
+        (loop (cdr l))))))
+
+(define-syntax (osapi-foreign-procedure stx)
+  (syntax-case stx ()
+    [(_ s ...)
+     (case (machine-type)
+       [(a6nt ta6nt i3nt ti3nt) #'(foreign-procedure _stdcall s ...)]
+       [else #'(foreign-procedure s ...)])]))
+
+;; This is an inconvenient callback interface, certainly, but it
+;; accomodates a limitatuon of the traditional Racket implementation
+(define (run-one-collect-callback v save sel)
+  (let ([protocol (#%vector-ref v 0)]
+        [proc (cpointer-address (#%vector-ref v 1))]
+        [ptr (lambda (i)
+               (cpointer*-address (#%vector-ref v (fx+ 2 i))))]
+        [val (lambda (i)
+               (#%vector-ref v (fx+ 2 i)))])
+    (case protocol
+      [(int->void)
+       ((foreign-procedure proc (int) void) (val 0))
+       save]
+      [(ptr_ptr_ptr_int->void)
+       ((foreign-procedure proc (void* void* void* int) void) (ptr 0) (ptr 1) (ptr 2) (val 3))
+       save]
+      [(ptr_ptr->save)
+       ((foreign-procedure proc (void* void*) void*) (ptr 0) (ptr 1))]
+      [(save!_ptr->void)
+       (and save (not (eqv? save 0))
+            ((foreign-procedure proc (void* void*) void*) save (ptr 0))
+            save)]
+      [(ptr_ptr_ptr->void)
+       ((foreign-procedure proc (void* void* void*) void) (ptr 0) (ptr 1) (ptr 2))
+       save]
+      [(ptr_ptr_float->void)
+       ((foreign-procedure proc (void* void* float) void) (ptr 0) (ptr 1) (val 2))
+       save]
+      [(ptr_ptr_double->void)
+       ((foreign-procedure proc (void* void* double) void) (ptr 0) (ptr 1) (val 2))
+       save]
+      [(float_float_float_float->void)
+       ((foreign-procedure proc (float float float float) void) (val 0) (val 1) (val 2) (val 3))
+       save]
+      [(ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void)
+       ((foreign-procedure proc (void* void* void* int int int int int int int int int) void)
+        (ptr 0) (ptr 2) (ptr 2)
+        (val 3) (val 4) (val 5) (val 6)
+        (val 7) (val 8) (val 9) (val 10) (val 11))
+       save]
+      [(osapi_ptr_ptr->void)
+       ((osapi-foreign-procedure proc (void* void*) void) (ptr 0) (ptr 1))
+       save]
+      [(osapi_ptr_int->void)
+       ((osapi-foreign-procedure proc (void* int) void) (ptr 0) (val 1))
+       save]
+      [(osapi_ptr_int_int_int_int_ptr_int_int_long->void)
+       ((osapi-foreign-procedure proc (void* int int int int void* int int long) void)
+        (ptr 0) (val 1) (val 2) (val 3) (val 4)
+        (ptr 5) (val 6) (val 7) (val 8))
+       save]
+      [else
+       (eprintf "unrecognized collect-callback protocol: ~s\n" protocol)
+       save])))
diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h
index fa9727bb58..3a88ead3c1 100644
--- a/racket/src/racket/src/schminc.h
+++ b/racket/src/racket/src/schminc.h
@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1435
+#define EXPECTED_PRIM_COUNT 1437
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP
diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h
index 523669dc49..eda903b9dc 100644
--- a/racket/src/racket/src/schvers.h
+++ b/racket/src/racket/src/schvers.h
@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "7.0.0.8"
+#define MZSCHEME_VERSION "7.0.0.9"
 
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 8
+#define MZSCHEME_VERSION_W 9
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c
index 913f523ffe..c86608b738 100644
--- a/racket/src/racket/src/thread.c
+++ b/racket/src/racket/src/thread.c
@@ -347,6 +347,9 @@ static Scheme_Object *unsafe_make_os_semaphore(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_os_semaphore_wait(int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_os_semaphore_post(int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *unsafe_add_collect_callbacks(int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_remove_collect_callbacks(int argc, Scheme_Object *argv[]);
+
 static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[]);
 static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[]);
@@ -675,6 +678,9 @@ scheme_init_unsafe_thread (Scheme_Startup_Env *env)
   ADD_PRIM_W_ARITY("unsafe-make-os-semaphore", unsafe_make_os_semaphore, 0, 0, env);
   ADD_PRIM_W_ARITY("unsafe-os-semaphore-wait", unsafe_os_semaphore_wait, 1, 1, env);
   ADD_PRIM_W_ARITY("unsafe-os-semaphore-post", unsafe_os_semaphore_post, 1, 1, env);
+
+  ADD_PRIM_W_ARITY("unsafe-add-collect-callbacks", unsafe_add_collect_callbacks, 2, 2, env);
+  ADD_PRIM_W_ARITY("unsafe-remove-collect-callbacks", unsafe_remove_collect_callbacks, 1, 1, env);
 }
 
 void scheme_init_thread_places(void) {
@@ -8747,6 +8753,18 @@ void scheme_remove_gc_callback(Scheme_Object *key)
   }
 }
 
+static Scheme_Object *unsafe_add_collect_callbacks(int argc, Scheme_Object *argv[])
+{
+  return scheme_add_gc_callback(argv[0], argv[1]);
+}
+
+static Scheme_Object *unsafe_remove_collect_callbacks(int argc, Scheme_Object *argv[])
+{
+  scheme_remove_gc_callback(argv[0]);
+  return scheme_void;
+}
+
+
 #if defined(_MSC_VER) || defined(__MINGW32__)
 # define mzOSAPI WINAPI
 #else