diff --git a/code/alieneval.lisp b/code/alieneval.lisp index 08cf6ec56ec9d531886ea8bde24b3c897cf62c45..f658f93902e13cc840ace8219dea6f3b7749f2ae 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.53 2003/01/23 21:05:33 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.54 2003/05/14 13:22:16 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,7 +21,8 @@ system-area-pointer def-alien-type def-alien-variable sap-alien extern-alien with-alien slot deref addr cast alien-sap alien-size alien-funcall def-alien-routine make-alien free-alien - null-alien)) + null-alien + def-callback callback)) (in-package "ALIEN-INTERNALS") (in-package "ALIEN") @@ -2034,3 +2035,320 @@ (values ,@temps ,@(results)))) `(values (alien-funcall ,lisp-name ,@(alien-args)) ,@(results)))))))) + +;;;; Alien callback support +;;;; +;;;; This is basically the implementation posted by Helmut Eller, +;;;; posted to cmucl-imp on 04/13/2003. It has been modified to live +;;;; in the ALIEN package and to fit the same style as the ALIEN +;;;; package. + +;;; This package provides a mechanism for defining callbacks: lisp +;;; functions which can be called from foreign code. The user +;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See +;;; the doc-strings for details.) +;;; +;;; Below are two examples. The first example defines a callback FOO +;;; and calls it with alien-funcall. The second illustrates the use +;;; of the libc qsort function. +;;; +;;; The implementation generates a piece machine code -- a +;;; "trampoline" -- for each callback function. A pointer to this +;;; trampoline can then be passed to foreign code. The trampoline is +;;; allocated with malloc and is not moved by the GC. +;;; +;;; When called, the trampoline passes a pointer to the arguments +;;; (essentially the stack pointer) together with an index to +;;; CALL-CALLACK. CALL-CALLBACK uses the index to find the +;;; corresponding lisp function and calls this function with the +;;; argument pointer. The lisp function uses the pointer to copy the +;;; arguments form the stack to local variables. On return, the lisp +;;; function stores the result into the location given by the argument +;;; pointer, and the trampoline code copies the return value from +;;; there into the right return register. +;;; +;;; The address of CALL-CALLBACK is used in every trampoline and must +;;; not be moved by the gc. It is therefore necessary to either +;;; include this package into the image (core) or to purify before +;;; creating any trampolines (or to invent some other trick). +;;; +;;; Examples: + +#| +;;; Example 1: + +(defcallback foo (int (arg1 int) (arg2 int)) + (format t "~&foo: ~S, ~S~%" arg1 arg2) + (+ arg1 arg2)) + +(alien-funcall (sap-alien (callback foo) (function int int int)) + 555 444444) + +;;; Example 2: + +(def-alien-routine qsort void + (base (* t)) + (nmemb int) + (size int) + (compar (* (function int (* t) (* t))))) + +(defcallback my< (int (arg1 (* double)) + (arg2 (* double))) + (let ((a1 (deref arg1)) + (a2 (deref arg2))) + (cond ((= a1 a2) 0) + ((< a1 a2) -1) + (t +1)))) + +(let ((a (make-array 10 :element-type 'double-float + :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 + 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)))) + (print a) + (qsort (sys:vector-sap a) + (length a) + (alien-size double :bytes) + (callback my<)) + (print a)) + +|# + +(defstruct (callback + (:constructor make-callback (trampoline lisp-fn return-type))) + "A callback consists of a piece assembly code -- the trampoline -- +and a lisp function. We store the return-type, so we can detect +incompatible redefinitions." + (trampoline (required-argument) :type system-area-pointer) + (lisp-fn (required-argument) :type (function (fixnum) (values))) + (return-type (required-argument) :type alien::alien-type)) + +(declaim (type (vector callback) *callbacks*)) +(defvar *callbacks* (make-array 10 :element-type 'callback + :fill-pointer 0 :adjustable t) + "Vector of all callbacks.") + +(defun call-callback (index sp-fixnum ret-addr) + (declare (type fixnum index sp-fixnum ret-addr) + (optimize speed)) + (funcall (callback-lisp-fn (aref *callbacks* index)) + sp-fixnum ret-addr)) + +(defun create-callback (lisp-fn return-type) + (let* ((index (fill-pointer *callbacks*)) + (tramp (vm:make-callback-trampoline index return-type)) + (cb (make-callback tramp lisp-fn return-type))) + (vector-push-extend cb *callbacks*) + cb)) + +#+nil +(defun address-of-call-into-lisp () + (sys:sap-int (alien-sap (extern-alien "call_into_lisp" (function (* t)))))) + +(defun address-of-call-callback () + (kernel:get-lisp-obj-address #'call-callback)) + +(defun address-of-funcall3 () + (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t)))))) + +;;; Some abbreviations for alien-type classes. The $ suffix is there +;;; to prevent name clashes. + +(deftype void$ () '(satisfies alien-void-type-p)) +(deftype integer$ () 'alien::alien-integer-type) +(deftype integer-64$ () '(satisfies alien-integer-64-type-p)) +(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) +(deftype pointer$ () 'alien::alien-pointer-type) +(deftype single$ () 'alien::alien-single-float-type) +(deftype double$ () 'alien::alien-double-float-type) +(deftype sap$ () '(satisfies alien-sap-type=)) + +(defun alien-sap-type= (type) + (alien::alien-type-= type + (alien::parse-alien-type 'system-area-pointer))) + +(defun alien-void-type-p (type) + (and (alien::alien-values-type-p type) + (null (alien::alien-values-type-values type)))) + +(defun alien-integer-64-type-p (type) + (and (alien::alien-integer-type-p type) + (= (alien::alien-type-bits type) 64))) + +(defun alien-signed-integer-type-p (type) + (and (alien::alien-integer-type-p type) + (alien::alien-integer-type-signed type))) + +(defun segment-to-trampoline (segment length) + (let* ((code (alien-funcall + (extern-alien "malloc" (function system-area-pointer unsigned)) + length)) + (fill-pointer code)) + (new-assem:segment-map-output segment + (lambda (sap length) + (kernel:system-area-copy sap 0 fill-pointer 0 + (* length vm:byte-bits)) + (setf fill-pointer (sys:sap+ fill-pointer length)))) + code)) + +(defun symbol-trampoline (symbol) + (callback-trampoline (symbol-value symbol))) + +(defmacro callback (name) + "Return the trampoline pointer for the callback NAME." + `(symbol-trampoline ',name)) + +(defun compatible-return-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (integer-64$ :dword) + ((or integer$ pointer$ sap$) :word) + (single$ :single) + (double$ :double) + (void$ :void)))) + (eq (machine-rep type1) (machine-rep type2)))) + +(defun define-callback-function (name lisp-fn return-type) + (declare (type symbol name) + (type function lisp-fn)) + (flet ((register-new-callback () + (setf (symbol-value name) + (create-callback lisp-fn return-type)))) + (if (and (boundp name) + (callback-p (symbol-value name))) + ;; try do redefine the existing callback + (let ((callback (find (symbol-trampoline name) *callbacks* + :key #'callback-trampoline :test #'sys:sap=))) + (cond (callback + (let ((old-type (callback-return-type callback))) + (cond ((compatible-return-types-p old-type return-type) + ;; (format t "~&; Redefining callback ~A~%" name) + (setf (callback-lisp-fn callback) lisp-fn) + (setf (callback-return-type callback) return-type) + callback) + (t + (let ((e (format nil "~ +Attempt to redefine callback with incompatible return type. + Old type was: ~A + New type is: ~A" old-type return-type)) + (c (format nil "~ +Create new trampoline (old trampoline calls old lisp function)."))) + (cerror c e) + (register-new-callback)))))) + (t (register-new-callback)))) + (register-new-callback)))) + +(defun word-aligned-bits (type) + (alien::align-offset (alien::alien-type-bits type) vm:word-bits)) + +(defun argument-size (spec) + (let ((type (alien::parse-alien-type spec))) + (typecase type + ((or integer$ single$ double$ pointer$ sap$) + (ceiling (word-aligned-bits type) vm:byte-bits)) + (t (error "Unsupported argument type: ~A" spec))))) + +(defun parse-return-type (spec) + (let ((alien::*values-type-okay* t)) + (alien::parse-alien-type spec))) + +(defun return-exp (spec sap body) + (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body))) + (let ((type (parse-return-type spec))) + (typecase type + (void$ body) + (signed-integer$ + (store `(signed ,(word-aligned-bits type)))) + (integer$ + (store `(unsigned ,(word-aligned-bits type)))) + ((or single$ double$ pointer$ sap$) + (store spec)) + (t (error "Unsupported return type: ~A" spec)))))) + +#+nil +(defmacro def-callback (name (return-type &rest arg-specs) &body body) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*) + +Define a function which can be called by foreign code. The pointer +returned by (callback NAME), when called by foreign code, invokes the +lisp function. The lisp function expects alien arguments of the +specified ARG-TYPEs and returns an alien of type RETURN-TYPE. + +If (callback NAME) is already a callback function pointer, its value +is not changed (though it's arranged that an updated version of the +lisp callback function will be called). This feature allows for +incremental redefinition of callback functions." + (let ((sp-fixnum (gensym (string :sp-fixnum))) + (ret-addr (gensym (string :ret-addr))) + (sp (gensym (string :sp)))) + `(progn + (defun ,name (,sp-fixnum ,ret-addr) + (declare (type fixnum ,sp-fixnum) + (type fixnum ,ret-addr)) + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2))))) + (declare (ignorable ,sp)) + ;; Copy all arguments to local variables. + (with-alien ,(loop for offset = 0 then (+ offset + (argument-size type)) + for (name type) in arg-specs + collect `(,name ,type + :local (deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type))))) + ,(return-exp return-type `(sys:sap+ ,ret-addr 0) `(progn ,@body)) + (values)))) + (define-callback-function + ',name #',name ',(parse-return-type return-type))))) + +(defmacro def-callback (name (return-type &rest arg-specs) &body body) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*) + +Define a function which can be called by foreign code. The pointer +returned by (callback NAME), when called by foreign code, invokes the +lisp function. The lisp function expects alien arguments of the +specified ARG-TYPEs and returns an alien of type RETURN-TYPE. + +If (callback NAME) is already a callback function pointer, its value +is not changed (though it's arranged that an updated version of the +lisp callback function will be called). This feature allows for +incremental redefinition of callback functions." + (let ((sp-fixnum (gensym (string :sp-fixnum-))) + (ret-addr (gensym (string :ret-addr-))) + (sp (gensym (string :sp-))) + (ret (gensym (string :ret-)))) + `(progn + (defun ,name (,sp-fixnum ,ret-addr) + (declare (type fixnum ,sp-fixnum ,ret-addr)) + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2)))) + (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2))))) + (declare (ignorable ,sp)) + ;; Copy all arguments to local variables. + (with-alien ,(loop for offset = 0 then (+ offset + (alien::argument-size type)) + for (name type) in arg-specs + collect `(,name ,type + :local ,(vm:callback-accessor-form type sp offset))) + ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body)) + (values)))) + (alien::define-callback-function + ',name #',name ',(alien::parse-return-type return-type))))) + +;;; dumping support + +(defun restore-callbacks () + ;; Create new trampolines on reload. + (loop for cb across *callbacks* + for i from 0 + do (setf (callback-trampoline cb) + (vm:make-callback-trampoline i (callback-return-type cb))))) + +;; *after-save-initializations* contains +;; new-assem::forget-output-blocks, and the assembler may not work +;; before forget-output-blocks was called. We add 'restore-callback at +;; the end of *after-save-initializations* to sidestep this problem. +(setf *after-save-initializations* + (append *after-save-initializations* (list 'restore-callbacks))) + +;;; callback.lisp ends here diff --git a/code/exports.lisp b/code/exports.lisp index abc5f9f45c7d7feb64a0c9ca4addf3b070ac4541..c1dca5c9035e2bcc08393c905531657847e584ae 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.208 2003/05/13 15:22:49 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.209 2003/05/14 13:22:16 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -819,6 +819,8 @@ #+sparc "FIXNUM-TAG-BITS" #+sparc "FIXNUM-TAG-MASK" #+sparc "PSEUDO-ATOMIC-TRAP" + #+sparc "GET-FP-OPERANDS" + "CALLBACK-ACCESSOR-FORM" "MAKE-CALLBACK-TRAMPOLINE" )) (defpackage "CONDITIONS") @@ -1270,26 +1272,26 @@ "NOTE-NEXT-INSTRUCTION" "SET-SLOT" "LOCATION-NUMBER" -"BYTE-FASL-FILE-VERSION" -"*COMPILE-COMPONENT*" -"BLOCK-NUMBER" -"DYNCOUNT-INFO-COUNTS" -"BACKEND-BYTE-FASL-FILE-IMPLEMENTATION" -"IR2-BLOCK-BLOCK" -"DISASSEM-BYTE-COMPONENT" -"LITTLE-ENDIAN-FASL-FILE-IMPLEMENTATION" -"DYNCOUNT-INFO-COSTS" -"FUNCALLABLE-INSTANCE-LEXENV" -"DISASSEM-BYTE-FUN" -"VOP-BLOCK" -"BACKEND-BYTE-FASL-FILE-TYPE" -"BIG-ENDIAN-FASL-FILE-IMPLEMENTATION" -"*ASSEMBLY-OPTIMIZE*" -"LARGE-ALLOC" -"%SET-FUNCTION-SELF" -"IR2-COMPONENT-DYNCOUNT-INFO" -"DYNCOUNT-INFO" "DYNCOUNT-INFO-P") -) + "BYTE-FASL-FILE-VERSION" + "*COMPILE-COMPONENT*" + "BLOCK-NUMBER" + "DYNCOUNT-INFO-COUNTS" + "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION" + "IR2-BLOCK-BLOCK" + "DISASSEM-BYTE-COMPONENT" + "LITTLE-ENDIAN-FASL-FILE-IMPLEMENTATION" + "DYNCOUNT-INFO-COSTS" + "FUNCALLABLE-INSTANCE-LEXENV" + "DISASSEM-BYTE-FUN" + "VOP-BLOCK" + "BACKEND-BYTE-FASL-FILE-TYPE" + "BIG-ENDIAN-FASL-FILE-IMPLEMENTATION" + "*ASSEMBLY-OPTIMIZE*" + "LARGE-ALLOC" + "%SET-FUNCTION-SELF" + "IR2-COMPONENT-DYNCOUNT-INFO" + "DYNCOUNT-INFO" "DYNCOUNT-INFO-P") + ) (defpackage "XREF" (:export "INIT-XREF-DATABASE" "REGISTER-XREF" @@ -1377,13 +1379,15 @@ (defpackage "ALIEN" (:import-from "LISP" "*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION" "BOOLEAN" "INTEGER" "LONG-FLOAT" "SINGLE-FLOAT" "UNION" "VALUES") + (:import-from "VM" "CALLBACK-ACCESSOR-FORM" "MAKE-CALLBACK-TRAMPOLINE") (:export "*" "ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" "ARRAY" "BOOLEAN" "CAST" "DEF-ALIEN-ROUTINE" "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE" "DEREF" "DOUBLE-FLOAT" "ENUM" "EXTERN-ALIEN" "FUNCTION" "INTEGER" "LONG-FLOAT" "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT" "UNION" "UNSIGNED" "VALUES" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN" - "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER")) + "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER" + "DEF-CALLBACK" "CALLBACK")) (dolist (name diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp index 90c30d6859f7572aaf795e029d30ec8f37d39810..2188ce47078402a2805c25944ce5782e3b5aa950 100644 --- a/compiler/sparc/c-call.lisp +++ b/compiler/sparc/c-call.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.16 2002/10/24 20:38:58 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.17 2003/05/14 13:22:17 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -284,3 +284,213 @@ (t (inst li temp delta) (inst add nsp-tn temp))))))) + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form)) + +#+nil +(defun compute-accessor (type sp offset) + (cond ((eq type 'double) + ;; Due to sparc calling conventions, a double doesn't have to + ;; be aligned on a double word boundary. We have to get the + ;; two words separately and create the double from them. + `(kernel:make-double-float (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* int))) + (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset 4)) + (* c-call:unsigned-int))))) + (t + `(deref (sap-alien (sys:sap+ ,sp ,offset) (* ,type)))))) + +(defun callback-accessor-form (type sp offset) + (cond ((eq type 'double) + ;; Due to sparc calling conventions, a double doesn't have to + ;; be aligned on a double word boundary. We have to get the + ;; two words separately and create the double from them. + `(kernel:make-double-float (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* int))) + (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset 4)) + (* c-call:unsigned-int))))) + (t + `(deref (sap-alien (sys:sap+ ,sp ,offset) (* ,type)))))) + +#+nil +(defmacro def-callback (name (return-type &rest arg-specs) &body body) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*) + +Define a function which can be called by foreign code. The pointer +returned by (callback NAME), when called by foreign code, invokes the +lisp function. The lisp function expects alien arguments of the +specified ARG-TYPEs and returns an alien of type RETURN-TYPE. + +If (callback NAME) is already a callback function pointer, its value +is not changed (though it's arranged that an updated version of the +lisp callback function will be called). This feature allows for +incremental redefinition of callback functions." + (let ((sp-fixnum (gensym (string :sp-fixnum-))) + (ret-addr (gensym (string :ret-addr-))) + (sp (gensym (string :sp-))) + (ret (gensym (string :ret-)))) + `(progn + (defun ,name (,sp-fixnum ,ret-addr) + (declare (type fixnum ,sp-fixnum ,ret-addr)) + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2)))) + (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2))))) + (declare (ignorable ,sp)) + ;; Copy all arguments to local variables. + (with-alien ,(loop for offset = 0 then (+ offset + (alien::argument-size type)) + for (name type) in arg-specs + collect `(,name ,type + :local ,(compute-accessor type sp offset))) + ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body)) + (values)))) + (alien::define-callback-function + ',name #',name ',(alien::parse-return-type return-type))))) + +(defun make-callback-trampoline (index return-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (flet ((def-reg-tn (offset) + (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::unsigned-reg) + :offset offset))) + (let* ((segment (make-segment)) + ;; Window save area (16 registers) + (window-save-size (* 16 vm:word-bytes)) + ;; Structure return pointer area (1 register) + (struct-return-size vm:word-bytes) + ;; Register save area (6 registers) + (reg-save-area-size (* 6 vm:word-bytes)) + ;; Local var. Should be large enough to hold a double-float or long + (return-value-size (* 2 vm:word-bytes)) + ;; Frame size: the register window, the arg save area, the + ;; structure return area, and return-value-area, all + ;; rounded to a multiple of eight. + (framesize (* 8 (ceiling (+ window-save-size struct-return-size reg-save-area-size + return-value-size) + 8))) + ;; Offset from FP where the first arg is located. + (arg0-save-offset (+ window-save-size struct-return-size)) + ;; Establish the registers we need + (%g0 (def-reg-tn vm::zero-offset)) + (%o0 (def-reg-tn vm::nl0-offset)) + (%o1 (def-reg-tn vm::nl1-offset)) + (%o2 (def-reg-tn vm::nl2-offset)) + (%o3 (def-reg-tn vm::nl3-offset)) + (%o7 (def-reg-tn vm::nargs-offset)) + (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6 + (%l0 (def-reg-tn vm::a0-offset)) + (%i0 (def-reg-tn vm::cname-offset)) + (%i1 (def-reg-tn vm::lexenv-offset)) + (%i2 (def-reg-tn vm::l0-offset)) + (%i3 (def-reg-tn vm::nfp-offset)) + (%i4 (def-reg-tn vm::cfunc-offset)) + (%i5 (def-reg-tn vm::code-offset)) + (%fp (def-reg-tn 30 #+nil vm::fp-offset)) + (%i7 (def-reg-tn vm::lip-offset)) + (f0-s (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::single-reg) + :offset 0)) + (f0-d (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::double-reg) + :offset 0)) + ) + ;; The generated assembly roughly corresponds to this C code: + ;; + ;; tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...) + ;; { + ;; double result; + ;; funcall3(call-callback, <index>, &a0, &result); + ;; return <cast> result; + ;; } + ;; + ;; Except, of course, the result is the appropriate result type + ;; for the trampoline. + ;; + (assemble (segment) + ;; Save old %fp, etc. establish our call frame with local vars + ;; %i contains the input args + (inst save %sp %sp (- framesize)) + ;; The stack frame now looks like + ;; + ;; TOP (high memory) + ;; + ;; argn + ;; ... + ;; arg6 + ;; arg5 + ;; arg4 + ;; arg3 + ;; arg2 + ;; arg1 + ;; arg0 + ;; struct_return + ;; window-save-area <- %fp + 64 + ;; <- %fp + ;; local-vars-extra-args (8-bytes) + ;; arg5-save + ;; arg4-save + ;; arg3-save + ;; arg2-save + ;; arg1-save + ;; arg0-save + ;; struct_return + ;; window-save-area + ;; <- %sp + + ;; Save all %i arg register values on the stack. (We + ;; might not always need to save all, but this is safe + ;; and easy.) + (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes))) + (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes))) + (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes))) + (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes))) + (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes))) + (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes))) + + ;; Set up our args to call funcall3 + ;; + ;; %o0 = address of call-callback + ;; %o1 = index + ;; %o2 = pointer to the arguments of the caller (address + ;; of arg0 above) + ;; %o3 = pointer to return area + + (inst li %o0 (alien::address-of-call-callback)) + (inst li %o1 (ash index vm:fixnum-tag-bits)) + (inst add %o2 %fp arg0-save-offset) + (inst add %o3 %fp (- return-value-size)) + + ;; And away we go to funcall3! + (let ((addr (alien::address-of-funcall3))) + (inst sethi %l0 (ldb (byte 22 10) addr)) + (inst jal %o7 %l0 (ldb (byte 10 0) addr)) + ;;(inst li %l0 (address-of-funcall3)) + ;;(inst jal %o7 %l0) + (inst nop) + ) + + ;; Ok, we're back. The value returned is actually stored in the args + (etypecase return-type + (alien::integer-64$ + ;; A 64-bit bignum. + ) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst ld %i0 %fp (- return-value-size))) + (alien::single$ + ;; Get the FP value into F0 + (inst ldf f0-s %fp (- return-value-size)) + ) + (alien::double$ + (inst lddf f0-d %fp (- return-value-size))) + (alien::void$ + )) + + (inst jal %g0 %i7 8) + (inst restore %g0 %g0 %g0) + ) + (let ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment)))))) + + diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp index 1183fbdba4dd7e5bb66b581a1215dfefe58f97f7..1783b423df75206c3d588fc09a1e350216f53668 100644 --- a/compiler/x86/c-call.lisp +++ b/compiler/x86/c-call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.12 2002/08/27 22:18:28 moore Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.13 2003/05/14 13:22:17 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -299,3 +299,94 @@ (ash symbol-value-slot word-shift) (- other-pointer-type))) delta))))) + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form)) + +(defun callback-accessor-form (type sp offset) + `(alien:deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type)))) + +#+nil +(defmacro def-callback (name (return-type &rest arg-specs) &body body) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {FORM}*) + +Define a function which can be called by foreign code. The pointer +returned by (callback NAME), when called by foreign code, invokes the +lisp function. The lisp function expects alien arguments of the +specified ARG-TYPEs and returns an alien of type RETURN-TYPE. + +If (callback NAME) is already a callback function pointer, its value +is not changed (though it's arranged that an updated version of the +lisp callback function will be called). This feature allows for +incremental redefinition of callback functions." + (let ((sp-fixnum (gensym (string :sp-fixnum-))) + (ret-addr (gensym (string :ret-addr-))) + (sp (gensym (string :sp-))) + (ret (gensym (string :ret-)))) + `(progn + (defun ,name (,sp-fixnum ,ret-addr) + (declare (type fixnum ,sp-fixnum) + (type fixnum ,ret-addr)) + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,sp-fixnum 2)))) + (,ret (sys:int-sap (ldb (byte vm:word-bits 0) (ash ,ret-addr 2))))) + (declare (ignorable ,sp)) + ;; Copy all arguments to local variables. + (with-alien ,(loop for offset = 0 then (+ offset + (alien::argument-size type)) + for (name type) in arg-specs + collect `(,name ,type + :local (alien:deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type))))) + ,(alien::return-exp return-type `(sys:sap+ ,ret 0) `(progn ,@body)) + (values)))) + (alien::define-callback-function + ',name #',name ',(alien::parse-return-type return-type))))) + + +(defun make-callback-trampoline (index return-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let* ((segment (make-segment)) + (eax x86::eax-tn) + (edx x86::edx-tn) + (ebp x86::ebp-tn) + (esp x86::esp-tn) + ([ebp-8] (x86::make-ea :dword :base ebp :disp -8)) + ([ebp-4] (x86::make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (alien::address-of-call-callback)) ; function + (inst mov eax (alien::address-of-funcall3)) + (inst call eax) + ;; now put the result into the right register + (etypecase return-type + (alien::integer-64$ + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst mov eax [ebp-8])) + (alien::single$ + (inst fld [ebp-8])) + (alien::double$ + (inst fldd [ebp-8])) + (alien::void$ )) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret)) + (let* ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment))))) + +