add __atomic foreign convention and improve related flonum unboxing (#976)

The `__atomic` convention promises that a foreign function will not
call back into Scheme, such as through a foreign callable, before it
returns. That promise enables a more direct call to the foreign
function. For example, on my machine, calling

```
(foreign-procedure __atomic "(cs)s_errno" () int))
```

takes about 80% the time of calling

```
(foreign-procedure "(cs)s_errno" () int))
```

When a foreign function has arguments or results that are represented
as flonums, using `__atomic` allows the call to be exposed enough in
intermediate compiler passes so that it can partitcapte in
flonum-unboxing optimizations. In principle, unboxing optimizations
could also apply to non-`__atomic` foreign functions, but the current
calling convention for Scheme functions and the protocol between
Scheme code and the kernel (especially the garbage collector) make
that difficult. Further improvements there are possible, but functions
that fit the `__atomic` constraint can be handled relatively easily.
Probably `__atomic` is wanted for the best performance, anyway, when
unboxing is relevant.

Meanwhile, various problems were interfering with flonum unboxing
around `ftype-ref` and `ftype-set!` on `double` and `float` fields,
and those problems are now fixed.

Closes #921 and uses parts of the example there by @williewillus in
tests.

Author: mflatt

boot/pb/equates.h

@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 10.3.0-pre-release.4 */
+/* equates.h for Chez Scheme Version 10.3.0-pre-release.5 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -1015,7 +1015,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0xA030004
+#define scheme_version 0xA030005
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0

boot/pb/petite.boot

@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 10.3.0-pre-release.4 (pb) */
+/* scheme.h for Chez Scheme Version 10.3.0-pre-release.5 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "10.3.0-pre-release.4"
+#define VERSION "10.3.0-pre-release.5"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */

boot/pb/scheme.boot

@@ -680,6 +680,9 @@ static void closure_callback(UNUSED ffi_cif *cif, void *ret, void **args, void *
   memcpy(&PBREGS(tc, 0), caller_saved, sizeof(caller_saved));
 
   if (!ret_is_arg) {
+    /* in case GC moved `types` (but `vec` is immobile) */
+    types = Svector_ref(vec, 1);
+
     /* move result to "arena" */
     type = Svector_ref(types, RET_TYPE_INDEX);
 

boot/pb/scheme.h

@@ -220,7 +220,8 @@ Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
 Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
 equivalent to specifying \scheme{#f} or no convention.
 Additionally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
-collection is allowed concurrently with a call of the foreign procedure, or it
+collection is allowed concurrently with a call of the foreign procedure, it can be
+\scheme{__atomic} to indicate that the foreign function never calls back to Scheme, or it
 can be \scheme{__varargs} or \scheme{(__varargs_after \var{n})} to indicate
 that the procedure uses a convention that works with a variable number of arguments
 after the first \var{n} (which may differ from the convention used for the
@@ -285,6 +286,11 @@ If a foreign procedure that is called with \scheme{__collect_safe} can
 invoke callables, then each callable should also be declared with
 \scheme{__collect_safe} so that the callable reactivates the thread.
 
+Use \scheme{__atomic} to declare that the foreign procedure never
+calls back to Scheme, such as through a foreign callable, which may
+allow a more efficient implementation of calls to the foreign
+function. The \scheme{__atomic} and \scheme{__collect_safe}
+declarations cannot be used at the same time.
 
 Complete type checking and conversion is performed on the parameters
 to a foreign procedure.
@@ -1171,7 +1177,7 @@ correct.
 
 Each \var{conv} adjusts the calling convention to be used.
 \scheme{foreign-callable} supports the same conventions as
-\scheme{foreign-procedure} with the exception of \scheme{__com}.
+\scheme{foreign-procedure} except for \scheme{__com} and \scheme{__atomic}.
 The \scheme{__collect_safe} convention for a callable activates a
 calling thread if the thread is not already activated, and
 the thread's activation state is reverted when the callable

c/ffi.c

@@ -1147,23 +1147,24 @@
   (begin
     (define-syntax check-loop-allocation
       (syntax-rules ()
-        [(_ proc) ; proc should allocate only its result flonum
+        [(_ proc val-example) ; proc should allocate only its result flonum
          (or (eq? (current-eval) interpret)
              (#%$suppress-primitive-inlining)
              (let ([before (+ (bytes-allocated) (bytes-deallocated))]
                    [N 100000])
                (and
                 (box?
-                 (let loop ([i N] [bx (box 0.0)])
+                 (let loop ([i N] [bx (box val-example)])
                    (if (zero? i)
                        bx
                        (loop (sub1 i) (let ([v (unbox bx)])
                                         (box (proc v)))))))
                 (let ([allocated (- (+ (bytes-allocated) (bytes-deallocated)) before)]
-                      [expected (* N (+ (compute-size 1.0)
+                      [expected (* N (+ (compute-size val-example)
                                         (compute-size (box #f))))])
                   (printf "~s ~s\n" allocated expected)
-                  (<= expected allocated (* 1.2 expected))))))]))
+                  (<= expected allocated (* 1.2 expected))))))]
+        [(_ proc) (check-loop-allocation proc 1.0)]))
     #t)
 
   (check-loop-allocation (lambda (v) (fl+ v v)))
@@ -1239,6 +1240,13 @@
                                          (fl+ v 1.0)
                                          (fl- v 1.0))))
 
+  (or (and (not (enable-cp0))
+           (not (= 3 (optimize-level))))
+      (check-loop-allocation (lambda (v)
+                               (fl-make-rectangular (fl- (cfl-real-part v) 1.0)
+                                                    (fl+ 1.0 (cfl-imag-part v))))
+                             1.0-3.0i))
+
   (check-loop-allocation (lambda (v)
                            ;; The two single-argument `fl+`s here should work as
                            ;; a hint for unboxing in the loop
@@ -1275,6 +1283,45 @@
                                                (set-pseudo-random-generator-x12! s v)
                                                (pseudo-random-generator-x20 s)))))))
 
+  (let ()
+    (define-ftype V2d
+      (struct (x double) (y double)))
+    (define v2d (make-ftype-pointer V2d (foreign-alloc (ftype-sizeof V2d))))
+    (check-loop-allocation (lambda (v)
+                             (fl+ (ftype-ref V2d (x) v2d)
+                                  (ftype-ref V2d (y) v2d)))))
+
+  (let ()
+    (define-ftype V2d
+      (struct (x double) (y double)))
+    (define v2d (make-ftype-pointer V2d (foreign-alloc (ftype-sizeof V2d))))
+    (check-loop-allocation (lambda (v)
+                             (ftype-set! V2d (x) v2d v)
+                             (ftype-set! V2d (y) v2d v)
+	                     (fl- v))))
+
+  (let ()
+    (define-ftype V2f
+      (struct (x float) (y float)))
+    (define v2f (make-ftype-pointer V2f (foreign-alloc (ftype-sizeof V2f))))
+    (check-loop-allocation (lambda (v)
+                             (ftype-set! V2f (x) v2f v)
+	                     (ftype-set! V2f (y) v2f v)
+                             (fl- v))))
+
+  (let ()
+    (define-ftype V2f
+      (struct (x float) (y float)))
+    (define v2f (make-ftype-pointer V2f (foreign-alloc (ftype-sizeof V2f))))
+    (check-loop-allocation (lambda (v)
+                             (fl+ (ftype-ref V2f (x) v2f)
+	                          (ftype-ref V2f (y) v2f)))))
+
+  (or (not (enable-cp0))
+      (let ([my-flsin (foreign-procedure __atomic "(cs)sin" (double) double)])
+        (check-loop-allocation (lambda (v)
+                                 (my-flsin (my-flsin v))))))
+
   (begin
     (define many-compare
       (lambda (a b c d e f g h i j k)

csug/foreign.stex

@@ -179,6 +179,8 @@
                              ls)])
            (syntax (= (let ([x (foreign-procedure name (p ...) double-float)])
                         (x v ...))
+                      (let ([x (foreign-procedure __atomic name (p ...) double-float)])
+                        (x v ...))
                       (+ v ...)))))))))
 
 (define foreign1.so (let ([p (find-source "foreign1.so")])
@@ -322,12 +324,23 @@
    (error? (begin (foreign-procedure 'foo () scheme-object) 'q))
    (error? (if (foreign-procedure 'foo () scheme-object) 'q 'q))
 
+   (error? (lambda () (foreign-procedure __bad_conv "foo" () scheme-object)))
+   (error? (lambda () (foreign-procedure __atomic __collect_safe "foo" () scheme-object)))
+
    (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo))
 
+   (procedure? (foreign-procedure __atomic "idiptr" (scheme-object) scheme-object))
+   (error? (foreign-procedure __atomic "i do not exist" (scheme-object) scheme-object))
+   (eq? 'foo ((foreign-procedure __atomic "idiptr" (scheme-object) scheme-object) 'foo))
+
    (parameterize ([current-eval interpret])
        (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo)))
 
    (not (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) void) 'foo)))
+   (not (eq? 'foo ((foreign-procedure __atomic "idiptr" (scheme-object) void) 'foo)))
+
+   (parameterize ([current-eval interpret])
+       (eq? 'foo ((foreign-procedure __atomic "idiptr" (scheme-object) scheme-object) 'foo)))
 
    (begin (define idint32 (foreign-procedure "id" (integer-32) integer-32))
           (procedure? idint32))
@@ -348,6 +361,25 @@
    (error? (idint32 #f))
    (error? (idint32 "hi"))
 
+   (begin (define idint32-a (foreign-procedure __atomic "id" (integer-32) integer-32))
+          (procedure? idint32-a))
+   (eqv? (idint32-a 0) 0)
+   (eqv? (idint32-a #x7fffffff) #x7fffffff)
+   (eqv? (idint32-a -1) -1)
+   (eqv? (idint32-a #x-7fffffff) #x-7fffffff)
+   (eqv? (idint32-a #x-80000000) #x-80000000)
+   (eqv? (idint32-a #x80000000) (+ #x-100000000 #x80000000))
+   (eqv? (idint32-a #x80000001) (+ #x-100000000 #x80000001))
+   (eqv? (idint32-a #xffffffff) (+ #x-100000000 #xffffffff))
+   (error? (idint32-a #x100000000))
+   (error? (idint32-a #x100000001))
+   (error? (idint32-a #xfffffffffffffffffffffffffffff))
+   (error? (idint32-a #x8000000080000000))
+   (error? (idint32-a #x-80000001))
+   (error? (idint32-a #x-8000000080000000))
+   (error? (idint32-a #f))
+   (error? (idint32-a "hi"))
+
    (begin (define iduns32 (foreign-procedure "id" (unsigned-32) unsigned-32))
           (procedure? iduns32))
    (eqv? (iduns32 0) 0)
@@ -372,6 +404,9 @@
    (eqv? #xffffffff ((foreign-procedure "id" (integer-32) unsigned-32) -1))
    (eqv? -1 ((foreign-procedure "id" (unsigned-32) integer-32) #xffffffff))
 
+   (eqv? #xffffffff ((foreign-procedure __atomic "id" (integer-32) unsigned-32) -1))
+   (eqv? -1 ((foreign-procedure __atomic "id" (unsigned-32) integer-32) #xffffffff))
+
    (begin (define idfix (foreign-procedure "idiptr" (fixnum) fixnum))
           (procedure? idfix))
    (eqv? 0 (idfix 0))
@@ -395,6 +430,11 @@
    (error? (foreign-procedure "id" () chare))
    (error? (foreign-procedure "id" (void) char))
 
+   (error? (foreign-procedure __atomic "id" (booleen) char))
+   (error? (foreign-procedure __atomic "id" (integer-32 integer-34) char))
+   (error? (foreign-procedure __atomic "id" () chare))
+   (error? (foreign-procedure __atomic "id" (void) char))
+
    ((foreign-procedure "id" (boolean) boolean) #t)
    (not ((foreign-procedure "id" (boolean) boolean) #f))
    ((foreign-procedure "id" (boolean) boolean) 0)
@@ -404,6 +444,12 @@
    (not ((foreign-procedure "id" (integer-32) boolean) 0))
    ((foreign-procedure "id" (integer-32) boolean) 1)
 
+   (= 1 ((foreign-procedure __atomic "id" (boolean) integer-32) #t))
+   (= 1 ((foreign-procedure __atomic "id" (boolean) integer-32) 0))
+   (= 0 ((foreign-procedure __atomic "id" (boolean) integer-32) #f))
+   (not ((foreign-procedure __atomic "id" (integer-32) boolean) 0))
+   ((foreign-procedure __atomic "id" (integer-32) boolean) 1)
+
    (char=? #\a ((foreign-procedure "id" (char) char) #\a))
    (= 0 ((foreign-procedure "id" (char) integer-32) #\nul))
    (char=? #\nul ((foreign-procedure "id" (integer-32) char) 0))
@@ -436,6 +482,12 @@
          (= 0 ((foreign-procedure (if (windows?) "windows_strcmp" "strcmp") (u8* string) integer-32) bv s)))))
    (error? ((foreign-procedure "id" (string) void) 'foo))
 
+   (let ([id1 (foreign-procedure __atomic "idiptr" (string) string)]
+         [id2 (foreign-procedure __atomic "idiptr" (string) iptr)]
+         [id3 (foreign-procedure __atomic "idiptr" (iptr) string)])
+      (and (eq? (id1 #f) #f) (eq? (id2 #f) 0) (eq? (id3 0) #f)))
+   (error? ((foreign-procedure __atomic "id" (string) void) 'foo))
+
    (= ((foreign-procedure "idid" (integer-32) integer-32) #xc7c7c7) #xc7c7c7)
    (= ((foreign-procedure "ididid" (integer-32) integer-32) #x7c7c7c7c)
       #x7c7c7c7c)
@@ -444,6 +496,10 @@
       #x80000000)
    (= ((foreign-procedure "id" (unsigned-32) integer-32) #x80000000)
       #x-80000000)
+   (= ((foreign-procedure __atomic "id" (unsigned-32) unsigned-32) #x80000000)
+      #x80000000)
+   (= ((foreign-procedure __atomic "id" (unsigned-32) integer-32) #x80000000)
+      #x-80000000)
 
    (error? (foreign-procedure 'abcde (integer-32) integer-32))
    (let ([template
@@ -460,6 +516,10 @@
    (= 1.1 ((foreign-procedure "float_id" (double-float) double-float) 1.1))
    (error? ((foreign-procedure "float_id" (double-float) void) 0))
 
+   (= 0.0 ((foreign-procedure __atomic "float_id" (double-float) double-float) 0.0))
+   (= 1.1 ((foreign-procedure __atomic "float_id" (double-float) double-float) 1.1))
+   (error? ((foreign-procedure __atomic "float_id" (double-float) void) 0))
+
    (let ([fid (foreign-procedure "float_id" (double-float) double-float)])
      (let f ((n 10000))
        (or (= n 0)
@@ -475,13 +535,28 @@
           integer-32)
        29 31 37 41 43 47 49 53 59 61))
 
+   (= (+ (*  1 29) (*  2 31) (*  3 37) (*  5 41) (*  7 43)
+         (* 11 47) (* 13 49) (* 17 53) (* 19 59) (* 23 61))
+      ((foreign-procedure __atomic "testten"
+          (integer-32 integer-32 integer-32 integer-32 integer-32
+           integer-32 integer-32 integer-32 integer-32 integer-32)
+          integer-32)
+       29 31 37 41 43 47 49 53 59 61))
+
    (= (+ 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8)
       ((foreign-procedure "flsum8"
           (double-float double-float double-float double-float
            double-float double-float double-float double-float)
           double-float)
        1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8))
 
+   (= (+ 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8)
+      ((foreign-procedure __atomic "flsum8"
+          (double-float double-float double-float double-float
+           double-float double-float double-float double-float)
+          double-float)
+       1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8))
+
    (= (+ 1 2 3 4 5 6.75 7 8.5)
       ((foreign-procedure "sparcfltest"
           (integer-32 integer-32 integer-32 integer-32
@@ -2720,7 +2795,7 @@
       x)
     43)
   (equal?
-    (let ()
+    (let ([keeps '()])
      ; foreign_callable example adapted from foreign.stex
       (define cb-init
         (foreign-procedure "cb_init" () void))
@@ -2732,6 +2807,7 @@
       (define callback
         (lambda (p)
           (let ([code (foreign-callable p (char) void)])
+            (set! keeps (cons code keeps))
             (foreign-callable-entry-point code))))
       (let ()
         (define ouch
@@ -2750,6 +2826,7 @@
 
         (parameterize ([current-output-port (open-output-string)])
           (event-loop "abcde")
+          (keep-live keeps)
           (get-output-string (current-output-port)))))
     (format "Ouch! Hit by 'a'~%Rats! Received 'c'~%Ouch! Hit by 'e'~%"))
    ; make sure foreign-procedure's code-object is properly locked when