FFI support for 64bit architectures.

* src/ffi/generator.scm: Declare long callback IDs, large enough to
avoid truncation warnings when the toolkit type is also large.  Use
%ld instead of %d for sizeof and member offsets, and cast them to
long.  On x86_64, these have types ulong and long respectively.

* src/microcode/: pruxffi.c, pruxffi.h: (callback_run_kernel)
(callback_run_handler): Declare long callback_id params.  Use %ld.

* src/runtime/ffi.scm (radix): Parameterize alien operations to
support 64bit or 32bit addresses.

diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm
index 9ba9a3713d0cf027fce2b08f9322ac61924cb154..f1f2627697057b79fb22b4c6e910027231c4382d 100644 (file)
--- a/src/ffi/generator.scm
+++ b/src/ffi/generator.scm
@@ -375,7 +375,7 @@ Scm_kernel_"name" (void)
 
   /* Construct. */
   "args-var" = empty_list();"constructs"
-  callback_run_handler ((int)ID, "args-var");
+  callback_run_handler ((long)ID, "args-var");
 
   callback_return ("tos-var");
 }"))))
@@ -392,7 +392,7 @@ Scm_kernel_"name" (void)
 "ret-decl"
 Scm_"name" ("arglist")
 \{"saves"
-  callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_"name");"return"
+  callback_run_kernel ((long)ID, (CallbackKernel)&Scm_kernel_"name");"return"
 }
 ")))))
 
@@ -542,7 +542,7 @@ grovel_basics (FILE * out)
                        (decl (decl-string name))
                        (name (symbol-name name)))
                   (string-append "
-  fprintf (out, \"   ((sizeof "name") . %d)\\n\", sizeof ("decl"));")))
+  fprintf (out, \"   ((sizeof "name") . %ld)\\n\", (long) sizeof ("decl"));")))
                    peek-poke-primitives))
    "
 \}
@@ -618,7 +618,7 @@ void
 "fname" (FILE * out)
 \{
   "decl" S;
-  fprintf (out, \"   (")(write key)(_" . %d)\\n\", sizeof ("decl"));"))
+  fprintf (out, \"   (")(write key)(_" . %ld)\\n\", (long) sizeof ("decl"));"))
     (for-each-member-path
      ctype includes
      (lambda (path brief-type)
@@ -626,7 +626,7 @@ void
                    "" "." "" (map symbol-name path)))
             (key (cons* 'OFFSET name path)))
         (_ "
-  fprintf (out, \"   (")(write key)(_" %d . ")(write brief-type)(_")\\n\", (char*)&(S."path") - (char*)&S);"))))
+  fprintf (out, \"   (")(write key)(_" %ld . ")(write brief-type)(_")\\n\", (long)((char*)&(S."path") - (char*)&S));"))))
     (_ "
 \}
 ")

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 477c46c2356b88aaeb72b0e698090bce3ac571f2..02c1df3a259c69f6df19038087119fefba1ad217 100644 (file)
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -498,7 +498,7 @@ static SCM run_callback = SHARP_F;
 static SCM return_to_c = SHARP_F;
 
 void
-callback_run_kernel (int callback_id, CallbackKernel kernel)
+callback_run_kernel (long callback_id, CallbackKernel kernel)
 {
   /* Used by callback trampolines.
 
@@ -513,7 +513,7 @@ callback_run_kernel (int callback_id, CallbackKernel kernel)
       if (run_callback == SHARP_F || return_to_c == SHARP_F)
        {
          outf_error
-           ("\nWarning: punted callback #%d.  Missing primitives!\n",
+           ("\nWarning: punted callback #%ld.  Missing primitives!\n",
             callback_id);
          outf_flush_error ();
          SET_VAL (FIXNUM_ZERO);
@@ -525,7 +525,7 @@ callback_run_kernel (int callback_id, CallbackKernel kernel)
   if (! CAN_PUSH_P (2 * (1 + 1 + CONTINUATION_SIZE)))
     {
       outf_error
-       ("\nWarning: punted callback #%d.  No room on stack!\n", callback_id);
+       ("\nWarning: punted callback #%ld.  No room on stack!\n", callback_id);
       outf_flush_error ();
       SET_VAL (FIXNUM_ZERO);
       return;
@@ -617,10 +617,10 @@ callback_lunseal (CallbackKernel expected)
 }
 
 static SCM valid_callback_handler (void);
-static SCM valid_callback_id (int id);
+static SCM valid_callback_id (long id);
 
 void
-callback_run_handler (int callback_id, SCM arglist)
+callback_run_handler (long callback_id, SCM arglist)
 {
   /* Used by callback kernels, inside the interpreter.  Thus it MAY GC
      abort.
@@ -666,7 +666,7 @@ valid_callback_handler (void)
 }
 
 static SCM
-valid_callback_id (int id)
+valid_callback_id (long id)
 {
   /* Validate the callback ID and convert to a fixnum. */
 

diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index 008b9084ebc9c4b477f17f60a7830b4d1a65c5bb..a8ef3c09f8720d234610a1d6e8a3ecc3539f36c7 100644 (file)
--- a/src/microcode/pruxffi.h
+++ b/src/microcode/pruxffi.h
@@ -56,9 +56,9 @@ extern char* callout_lunseal (CalloutTrampIn expected);
 extern void callout_pop (char* tos);
 
 typedef void (*CallbackKernel)(void);
-extern void callback_run_kernel (int callback_id, CallbackKernel kernel);
+extern void callback_run_kernel (long callback_id, CallbackKernel kernel);
 extern char* callback_lunseal (CallbackKernel expected);
-extern void callback_run_handler (int callback_id, SCM arglist);
+extern void callback_run_handler (long callback_id, SCM arglist);
 extern void callback_return (char* tos);
 
 /* Converters. */

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 2ab9c878d96d6b5e916614d89f9258746819e15b..55d38d578bf4ec8da0e2c164b3cad3e3de8b2b81 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -38,6 +38,27 @@ USA.
   ;; A symbol or list.
   ctype)
 
+;; Breaking a word in two produces high and low fixnums.  If they are
+;; two digits representing a larger number, then RADIX is their base.
+;; For a 32 bit word, (radix) is #x10000.
+;;
+;; This substitutes a constant when there is a compiler, per its
+;; target.  Else this is a reference to %radix.
+(define-syntax radix
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (declare (ignore rename compare))
+     (if (not (null? (cdr form)))
+        (syntax-error "No sub-forms allowed:" form))
+     (cond ((get-subsystem-version "LIAR/i386") #x10000)
+          ((get-subsystem-version "LIAR/x86-64") #x100000000)
+          (else
+           '%RADIX)))))
+
+;; This is only needed when the target machine's word size is unknown
+;; (e.g. when compiling to C, or when there is no compiler).
+(define %radix)
+
 (set-record-type-unparser-method! rtd:alien
   (standard-unparser-method
    'alien
@@ -57,13 +78,14 @@ USA.
   alien)
 
 (define (alien/address-string alien)
-  ;; Returns a string of length 8, e.g. "081adc60".
-  (let ((high (%alien/high-bits alien)))
-    (if (eq? high #f) "< null >"
-       (let ((low (%alien/low-bits alien))
-             (4hex (lambda (n)
-                     (string-pad-left (number->string n 16) 4 #\0))))
-         (string-append (4hex high) (4hex low))))))
+  ;; Returns a string, e.g. "081adc60".
+  (let ((high (%alien/high-bits alien))
+       (low (%alien/low-bits alien))
+       (hex (lambda (n)
+              (string-pad-left (number->string n 16)
+                               (if (fix:= (radix) #x10000) 4 8)
+                               #\0))))
+    (string-append (hex high) (hex low))))
 
 (define (make-alien #!optional ctype)
   (let ((ctype (if (default-object? ctype) #f ctype)))
@@ -71,7 +93,7 @@ USA.
 
 (declare (integrate-operator alien/address))
 (define (alien/address alien)
-  (+ (* (%alien/high-bits alien) #x10000)
+  (+ (* (%alien/high-bits alien) (radix))
      (%alien/low-bits alien)))
 
 (declare (integrate-operator copy-alien-address!))
@@ -117,7 +139,7 @@ USA.
   ;; This procedure returns ALIEN after modifying it to have an
   ;; address INCREMENT bytes away from its previous address.  If CTYPE
   ;; is specified, the type slot of ALIEN is set.
-  (let ((quotient.remainder (fix:divide increment #x10000)))
+  (let ((quotient.remainder (fix:divide increment (radix))))
     (let ((new-high (fix:+ (%alien/high-bits alien)
                           (integer-divide-quotient quotient.remainder)))
          (new-low (fix:+ (%alien/low-bits alien)
@@ -128,10 +150,10 @@ USA.
             (if (fix:zero? new-high)
                 (error:bad-range-argument increment 'alien-byte-increment!)
                 (begin
-                  (set-%alien/low-bits! alien (fix:+ new-low #x10000))
+                  (set-%alien/low-bits! alien (fix:+ new-low (radix)))
                   (set-%alien/high-bits! alien (fix:-1+ new-high)))))
-           ((fix:>= new-low #x10000)
-            (set-%alien/low-bits! alien (fix:- new-low #x10000))
+           ((fix:>= new-low (radix))
+            (set-%alien/low-bits! alien (fix:- new-low (radix)))
             (set-%alien/high-bits! alien (fix:1+ new-high)))
            (else
             (set-%alien/low-bits! alien new-low)
@@ -212,7 +234,7 @@ USA.
   (string-tail (%alien-function/name alienf) 4)) 
 
 (define (%set-alien-function/address! alienf address)
-  (let ((qr (integer-divide address #x10000)))
+  (let ((qr (integer-divide address (radix))))
     (set-%alien-function/high-bits! alienf (integer-divide-quotient qr))
     (set-%alien-function/low-bits! alienf (integer-divide-remainder qr))))
 
@@ -488,6 +510,7 @@ USA.
   (reset-alien-functions!)
   (reset-malloced-aliens!)
   (reset-callbacks!)
+  (set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
   (set! trace? #f)
   (set! calloutback-stack '()))