From: Matt Birkholz Date: Tue, 21 Dec 2010 17:28:03 +0000 (-0700) Subject: FFI support for 64bit architectures. X-Git-Tag: 20101221-Gtk~10 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bbc491c2d415927bd8415951936459782bcea966;p=mit-scheme.git 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 9ba9a3713..f1f262769 100644 --- 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 477c46c23..02c1df3a2 100644 --- 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 008b9084e..a8ef3c09f 100644 --- 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 2ab9c878d..55d38d578 100644 --- 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 '()))