repairs for pb32 foreign interface (#824)

Support via libffi for pb32 had not been well tested before. Just
running existing tests turned up several problems in the handling of
callable addresses and 64-bit arguments and results.

IMPLEMENTATION.md

@@ -1353,6 +1353,15 @@ code for a basic build; on a big-endian machine, the kernel rewrites
 instruction bytes to big-endian form while loading a fasl file, so the
 interpreter can decode instructions in native order.
 
+A basic build supports only a limited, hardwired set of foreign
+interfaces that are sufficient to access kernel functions. A non-basic
+build can support the full foreign interface if the Scheme build is
+configured to use libffi. The pb32 variants assume 8-byte alignment in
+structs for doubles and 64-bit integer values, which can limit
+interoperability with foreign libraries on platforms with a different
+alignment convention (such as non-Windows x86, where doubles and
+64-bit integers need only 4-byte alignment).
+
 For a non-basic build, fragments of static Scheme code can be turned
 into C code to compile and plug back into the kernel. These fragments
 are called *pbchunks*.

c/ffi.c

@@ -509,9 +509,9 @@ void S_ffi_call(ptr types, ptr proc, ptr *arena) {
         if (sizeof(I64) > sizeof(ptr)) {
 #         ifdef PORTABLE_BYTECODE_BIGENDIAN
           {
-            ptr lo = arena[0];
-            arena[0] = arena[1];
-            arena[1] = lo;
+            ptr lo = arena_start[0];
+            arena_start[0] = arena_start[1];
+            arena_start[1] = lo;
           }
 #         endif
         }
@@ -584,7 +584,7 @@ ptr S_ffi_closure(ptr types, ptr proc) {
 
 static void closure_callback(UNUSED ffi_cif *cif, void *ret, void **args, void *user_data) {
   ptr caller_saved[4]; /* first four registers are preserved */
-  ptr vec = (ptr)user_data;
+  ptr vec = TO_PTR(user_data);
   ptr types = Svector_ref(vec, 1), type;
   ptr tc;
   ptr *arena_start, *arena;
@@ -638,16 +638,16 @@ static void closure_callback(UNUSED ffi_cif *cif, void *ret, void **args, void *
         break;
       case ffi_typerep_uint64:
         if (sizeof(U64) > sizeof(ptr)) {
-          arena[0] = (ptr)((*(U64 *)args[i]) >> 32);
-          arena[1] = (ptr)*(U64 *)args[i];
+          arena[1] = (ptr)((*(U64 *)args[i]) >> 32);
+          arena[0] = (ptr)*(U64 *)args[i];
           arena++;
         } else
           *arena = *(U64*)args[i];
         break;
       case ffi_typerep_sint64:
         if (sizeof(I64) > sizeof(ptr)) {
-          arena[0] = (ptr)((*(I64 *)args[i]) >> 32);
-          arena[1] = (ptr)*(I64 *)args[i];
+          arena[1] = (ptr)((*(I64 *)args[i]) >> 32);
+          arena[0] = (ptr)*(I64 *)args[i];
           arena++;
         } else
           *arena = *(I64*)args[i];
@@ -691,11 +691,11 @@ static void closure_callback(UNUSED ffi_cif *cif, void *ret, void **args, void *
       case ffi_typerep_sint64:
         if (sizeof(U64) > sizeof(ptr)) {
 #        ifdef PORTABLE_BYTECODE_BIGENDIAN
-          ((U32 *)ret)[0] = arena_start[0];
-          ((U32 *)ret)[1] = arena_start[1];
-#        else
           ((U32 *)ret)[1] = arena_start[0];
           ((U32 *)ret)[0] = arena_start[1];
+#        else
+          ((U32 *)ret)[0] = arena_start[0];
+          ((U32 *)ret)[1] = arena_start[1];
 #        endif
         } else {
           *(ptr *)ret = *arena_start;

mats/ftype.ms

@@ -59,12 +59,14 @@
   (begin
     (define max-integer-alignment
       (if (or (> (fixnum-width) 32)
-              (memq (machine-type) '(i3nt ti3nt i3qnx ti3qnx arm32le tarm32le ppc32le tppc32le)))
+              (memq (machine-type) '(i3nt ti3nt i3qnx ti3qnx arm32le tarm32le ppc32le tppc32le
+                                          pb32l tpb32l pb32b tpb32b)))
           8
           4))
     (define max-float-alignment
       (if (or (> (fixnum-width) 32)
-              (memq (machine-type) '(i3nt ti3nt arm32le tarm32le ppc32le tppc32le)))
+              (memq (machine-type) '(i3nt ti3nt arm32le tarm32le ppc32le tppc32le
+                                          pb32l tpb32l pb32b tpb32b)))
           8
           4))
     (define-syntax fptr-free

s/pb.ss

@@ -1661,7 +1661,7 @@
                 (%seq
                  (set! ,%Carg1 ,lo)
                  ,(%inline call-arena-in ,%Carg1 (immediate ,off))
-                 (set! ,%Carg1 ,lo)
+                 (set! ,%Carg1 ,hi)
                  ,(%inline call-arena-in ,%Carg1 (immediate ,(fx+ off 4)))))))
           (define save-double/unboxed
             (lambda (off)
@@ -1726,10 +1726,7 @@
                                          e
                                          (box e)))
                                    encs)
-                             (fx+ off (if ($ftd-compound? ftd)
-                                          (constant ptr-bytes)
-                                          (max (constant ptr-bytes)
-                                               ($ftd-size ftd)))))]
+                             (fx+ off (constant ptr-bytes)))]
                       [(fp-void)
                        (loop types
                              (cons (lambda () `(nop)) locs)

s/prims.ss

@@ -666,7 +666,8 @@
       [(pb)
        (unless (vector? x)
          ($oops 'foreign-callable-entry-point "~s is not a vector" x))
-       (bitwise-arithmetic-shift-left (vector-ref x 2) (constant fixnum-offset))]
+       (bitwise-and (bitwise-arithmetic-shift-left (vector-ref x 2) (constant fixnum-offset))
+                    (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1))]
       [else
        (unless ($code? x)
          ($oops 'foreign-callable-entry-point "~s is not a code object" x))