diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b6e73bebf6c662d2b86468727e96ccc3a13b4928 --- /dev/null +++ b/src/code/alien-callback.lisp @@ -0,0 +1,417 @@ +;;; -*- Package: ALIEN -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/alieneval.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains any the part of the Alien implementation that +;;; is not part of the compiler. +;;; +(in-package "ALIEN") +(use-package "EXT") +(use-package "SYSTEM") + +(intl:textdomain "cmucl") + +(export '(alien * array struct union enum function integer signed unsigned + boolean values single-float double-float long-float + 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 + def-callback callback + callback-funcall)) + +(in-package "ALIEN-INTERNALS") +(in-package "ALIEN") + +(import '(alien alien-value alien-value-type parse-alien-type + unparse-alien-type alien-type-= alien-subtype-p alien-typep + + def-alien-type-class def-alien-type-translator def-alien-type-method + invoke-alien-type-method + + alien-type alien-type-p alien-type-bits alien-type-alignment + alien-integer-type alien-integer-type-p alien-integer-type-signed + alien-boolean-type alien-boolean-type-p + alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p + alien-long-float-type alien-long-float-type-p + alien-pointer-type alien-pointer-type-p alien-pointer-type-to + make-alien-pointer-type + alien-array-type alien-array-type-p alien-array-type-element-type + alien-array-type-dimensions + alien-record-type alien-record-type-p alien-record-type-fields + alien-record-field alien-record-field-p alien-record-field-name + alien-record-field-type alien-record-field-offset + alien-function-type alien-function-type-p make-alien-function-type + alien-function-type-result-type alien-function-type-arg-types + alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* + + %set-slot %slot-addr %set-deref %deref-addr + + %heap-alien %set-heap-alien %heap-alien-addr + heap-alien-info heap-alien-info-p heap-alien-info-type + heap-alien-info-sap-form + + local-alien %set-local-alien %local-alien-addr + local-alien-info local-alien-info-p local-alien-info-type + local-alien-info-force-to-memory-p + %local-alien-forced-to-memory-p + make-local-alien dispose-local-alien note-local-alien-type + + %cast %sap-alien align-offset + + extract-alien-value deposit-alien-value naturalize deport + compute-lisp-rep-type compute-alien-rep-type + compute-extract-lambda compute-deposit-lambda + compute-naturalize-lambda compute-deport-lambda) + "ALIEN-INTERNALS") + +(export '(alien alien-value alien-value-type parse-alien-type + unparse-alien-type alien-type-= alien-subtype-p alien-typep + + def-alien-type-class def-alien-type-translator def-alien-type-method + invoke-alien-type-method + + alien-type alien-type-p alien-type-bits alien-type-alignment + alien-integer-type alien-integer-type-p alien-integer-type-signed + alien-boolean-type alien-boolean-type-p + alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p + alien-long-float-type alien-long-float-type-p + alien-pointer-type alien-pointer-type-p alien-pointer-type-to + make-alien-pointer-type + alien-array-type alien-array-type-p alien-array-type-element-type + alien-array-type-dimensions + alien-record-type alien-record-type-p alien-record-type-fields + alien-record-field alien-record-field-p alien-record-field-name + alien-record-field-type alien-record-field-offset + alien-function-type alien-function-type-p make-alien-function-type + alien-function-type-result-type alien-function-type-arg-types + alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* + + %set-slot %slot-addr %set-deref %deref-addr + + %heap-alien %set-heap-alien %heap-alien-addr + heap-alien-info heap-alien-info-p heap-alien-info-type + heap-alien-info-sap-form + + local-alien %set-local-alien %local-alien-addr + local-alien-info local-alien-info-p local-alien-info-type + local-alien-info-force-to-memory-p + %local-alien-forced-to-memory-p + make-local-alien dispose-local-alien note-local-alien-type + + %cast %sap-alien align-offset + + extract-alien-value deposit-alien-value naturalize deport + compute-lisp-rep-type compute-alien-rep-type + compute-extract-lambda compute-deposit-lambda + compute-naturalize-lambda compute-deport-lambda) + "ALIEN-INTERNALS") + + +;;;; 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-CALLBACK. 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 from 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: + +(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) + (format t "~&foo: ~S, ~S~%" arg1 arg2) + (+ arg1 arg2)) + +(alien:alien-funcall (alien:sap-alien (alien:callback foo) + (function c-call:int c-call:int c-call:int)) + 555 444444) + +;;; Example 2: + +(alien:def-alien-routine qsort c-call:void + (base (* t)) + (nmemb c-call:int) + (size c-call:int) + (compar (* (function c-call:int (* t) (* t))))) + +(alien:def-callback my< (c-call:int (arg1 (* c-call:double)) + (arg2 (* c-call:double))) + (let ((a1 (alien:deref arg1)) + (a2 (alien: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:alien-size c-call:double :bytes) + (alien:callback my<)) + (print a)) + +||# + +(defstruct (callback + (:constructor make-callback (trampoline lisp-fn function-type))) + "A callback consists of a piece assembly code -- the trampoline -- +and a lisp function. We store the function type (including return +type and arg types), so we can detect incompatible redefinitions." + (trampoline (required-argument) :type system-area-pointer) + (lisp-fn (required-argument) :type (function (fixnum fixnum) (values))) + (function-type (required-argument) :type alien::alien-function-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 fn-type) + (let* ((index (fill-pointer *callbacks*)) + (tramp (vm:make-callback-trampoline index fn-type)) + (cb (make-callback tramp lisp-fn fn-type))) + (vector-push-extend cb *callbacks*) + cb)) + +(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-integer-type) +(deftype integer-64$ () '(satisfies alien-integer-64-type-p)) +(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) +(deftype pointer$ () 'alien-pointer-type) +(deftype single$ () 'alien-single-float-type) +(deftype double$ () 'alien-double-float-type) +(deftype sap$ () '(satisfies alien-sap-type=)) + +(defun alien-sap-type= (type) + (alien-type-= type (parse-alien-type 'system-area-pointer))) + +(defun alien-void-type-p (type) + (and (alien-values-type-p type) + (null (alien-values-type-values type)))) + +(defun alien-integer-64-type-p (type) + (and (alien-integer-type-p type) + (= (alien-type-bits type) 64))) + +(defun alien-signed-integer-type-p (type) + (and (alien-integer-type-p type) + (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)) + ;; Make sure the malloc'ed area is executable. + (let* ((page-size (get-page-size)) + ;; mprotect wants address on a page boundary, so round down + ;; the address and round up the length + (code-base (sys:int-sap (* page-size + (floor (sys:sap-int code) page-size)))) + (len (* page-size (ceiling length page-size)))) + (unless (unix::unix-mprotect code-base len + (logior unix:prot_exec unix:prot_read unix:prot_write)) + (warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work.") + len length code-base 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)) + +;; Convenience macro to make it easy to call callbacks. +(defmacro callback-funcall (name &rest args) + `(alien-funcall (sap-alien (callback ,name) + ,(unparse-alien-type + (callback-function-type (symbol-value name)))) + ,@args)) + +(defun define-callback-function (name lisp-fn fn-type) + (declare (type symbol name) + (type function lisp-fn)) + (flet ((register-new-callback () + (setf (symbol-value name) + (create-callback lisp-fn fn-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-function-type callback))) + (cond ((vm::compatible-function-types-p old-type fn-type) + ;; (format t "~&; Redefining callback ~A~%" name) + (setf (callback-lisp-fn callback) lisp-fn) + (setf (callback-function-type callback) fn-type) + callback) + (t + (let ((e (format nil (intl:gettext "~ +Attempt to redefine callback with incompatible return type. + Old type was: ~A + New type is: ~A") old-type fn-type)) + (c (format nil (intl:gettext "~ +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) + (align-offset (alien-type-bits type) vm:word-bits)) + +(defun argument-size (spec) + (let ((type (parse-alien-type spec))) + (typecase type + ((or integer$ single$ double$ pointer$ sap$) + (ceiling (word-aligned-bits type) vm:byte-bits)) + (t (error (intl:gettext "Unsupported argument type: ~A") spec))))) + +(defun parse-return-type (spec) + (let ((*values-type-okay* t)) + (parse-alien-type spec))) + +(defun parse-function-type (return-type arg-specs) + (parse-alien-type + `(function ,return-type ,@(mapcar #'second arg-specs)))) + +(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 (intl:gettext "Unsupported return type: ~A") spec)))))) + +(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc)) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) + {doc-string} {decls}* {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) + ,@(when doc (list doc)) + (declare (type fixnum ,sp-fixnum ,ret-addr)) + ,@decls + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum) + 2))) + (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr) + 2)))) + (declare (ignorable ,sp ,ret)) + ;; 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 ,(vm:callback-accessor-form type sp offset))) + ,(return-exp return-type ret `(progn ,@body)) + (values)))) + (define-callback-function + ',name #',name ',(parse-function-type return-type arg-specs))))) + +;;; 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-function-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/src/code/alieneval.lisp b/src/code/alieneval.lisp index c8f0fb8de486b33b634fbc224312097f5ae3b97c..124f74ea00c4b83d46731b7283c4fc03ab1572d3 100644 --- a/src/code/alieneval.lisp +++ b/src/code/alieneval.lisp @@ -2078,296 +2078,3 @@ If so return true; otherwise call ALTERNATIVE." (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-CALLBACK. 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 from 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: - -(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) - (format t "~&foo: ~S, ~S~%" arg1 arg2) - (+ arg1 arg2)) - -(alien:alien-funcall (alien:sap-alien (alien:callback foo) - (function c-call:int c-call:int c-call:int)) - 555 444444) - -;;; Example 2: - -(alien:def-alien-routine qsort c-call:void - (base (* t)) - (nmemb c-call:int) - (size c-call:int) - (compar (* (function c-call:int (* t) (* t))))) - -(alien:def-callback my< (c-call:int (arg1 (* c-call:double)) - (arg2 (* c-call:double))) - (let ((a1 (alien:deref arg1)) - (a2 (alien: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:alien-size c-call:double :bytes) - (alien:callback my<)) - (print a)) - -||# - -(defstruct (callback - (:constructor make-callback (trampoline lisp-fn function-type))) - "A callback consists of a piece assembly code -- the trampoline -- -and a lisp function. We store the function type (including return -type and arg types), so we can detect incompatible redefinitions." - (trampoline (required-argument) :type system-area-pointer) - (lisp-fn (required-argument) :type (function (fixnum fixnum) (values))) - (function-type (required-argument) :type alien::alien-function-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 fn-type) - (let* ((index (fill-pointer *callbacks*)) - (tramp (vm:make-callback-trampoline index fn-type)) - (cb (make-callback tramp lisp-fn fn-type))) - (vector-push-extend cb *callbacks*) - cb)) - -(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-integer-type) -(deftype integer-64$ () '(satisfies alien-integer-64-type-p)) -(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) -(deftype pointer$ () 'alien-pointer-type) -(deftype single$ () 'alien-single-float-type) -(deftype double$ () 'alien-double-float-type) -(deftype sap$ () '(satisfies alien-sap-type=)) - -(defun alien-sap-type= (type) - (alien-type-= type (parse-alien-type 'system-area-pointer))) - -(defun alien-void-type-p (type) - (and (alien-values-type-p type) - (null (alien-values-type-values type)))) - -(defun alien-integer-64-type-p (type) - (and (alien-integer-type-p type) - (= (alien-type-bits type) 64))) - -(defun alien-signed-integer-type-p (type) - (and (alien-integer-type-p type) - (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)) - ;; Make sure the malloc'ed area is executable. - (let* ((page-size (get-page-size)) - ;; mprotect wants address on a page boundary, so round down - ;; the address and round up the length - (code-base (sys:int-sap (* page-size - (floor (sys:sap-int code) page-size)))) - (len (* page-size (ceiling length page-size)))) - (unless (unix::unix-mprotect code-base len - (logior unix:prot_exec unix:prot_read unix:prot_write)) - (warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work.") - len length code-base 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)) - -;; Convenience macro to make it easy to call callbacks. -(defmacro callback-funcall (name &rest args) - `(alien-funcall (sap-alien (callback ,name) - ,(unparse-alien-type - (callback-function-type (symbol-value name)))) - ,@args)) - -(defun define-callback-function (name lisp-fn fn-type) - (declare (type symbol name) - (type function lisp-fn)) - (flet ((register-new-callback () - (setf (symbol-value name) - (create-callback lisp-fn fn-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-function-type callback))) - (cond ((vm::compatible-function-types-p old-type fn-type) - ;; (format t "~&; Redefining callback ~A~%" name) - (setf (callback-lisp-fn callback) lisp-fn) - (setf (callback-function-type callback) fn-type) - callback) - (t - (let ((e (format nil (intl:gettext "~ -Attempt to redefine callback with incompatible return type. - Old type was: ~A - New type is: ~A") old-type fn-type)) - (c (format nil (intl:gettext "~ -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) - (align-offset (alien-type-bits type) vm:word-bits)) - -(defun argument-size (spec) - (let ((type (parse-alien-type spec))) - (typecase type - ((or integer$ single$ double$ pointer$ sap$) - (ceiling (word-aligned-bits type) vm:byte-bits)) - (t (error (intl:gettext "Unsupported argument type: ~A") spec))))) - -(defun parse-return-type (spec) - (let ((*values-type-okay* t)) - (parse-alien-type spec))) - -(defun parse-function-type (return-type arg-specs) - (parse-alien-type - `(function ,return-type ,@(mapcar #'second arg-specs)))) - -(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 (intl:gettext "Unsupported return type: ~A") spec)))))) - -(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc)) - "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) - {doc-string} {decls}* {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) - ,@(when doc (list doc)) - (declare (type fixnum ,sp-fixnum ,ret-addr)) - ,@decls - ;; We assume sp-fixnum is word aligned and pass it untagged to - ;; this function. The shift compensates this. - (let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum) - 2))) - (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr) - 2)))) - (declare (ignorable ,sp ,ret)) - ;; 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 ,(vm:callback-accessor-form type sp offset))) - ,(return-exp return-type ret `(progn ,@body)) - (values)))) - (define-callback-function - ',name #',name ',(parse-function-type return-type arg-specs))))) - -;;; 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-function-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/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index 4fd20b685f8d60943b94d4040a3b119a453ffde3..1d08a2eb784ab61cc26349f5bdd2fb401b28618d 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -386,250 +386,3 @@ (inst addi nsp-tn nsp-tn delta)) (t (inst lwz nsp-tn nsp-tn 0))))))) - - -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - (let ((parsed-type (alien::parse-alien-type type))) - (typecase parsed-type - (alien::integer-64$ - ;; Get both words of a 64-bit integer and combine together, in - ;; a big-endian fashion. - `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) - ,(if (alien-integer-type-signed parsed-type) - '(* c-call:int) - '(* c-call:unsigned-int))))) - (lo (alien:deref (sap-alien (sys:sap+ ,sp - (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (+ (ash hi vm:word-bits) lo))) - (alien::integer$ - ;; We can access machine integers directly, but we need to get - ;; the offset right, since the offset we're given is the start - ;; of the object, and we're a big-endian machine. - (let ((byte-offset - (- vm:word-bytes - (ceiling (alien::alien-integer-type-bits parsed-type) - vm:byte-bits)))) - `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) - (* ,type))))) - (t - ;; This should work for everything else. - `(deref (sap-alien (sys:sap+ ,sp ,offset) - (* ,type))))))) - -(defun compatible-function-types-p (fun-type1 fun-type2) - (labels ((type-words (type) - (ceiling (alien-type-bits type) vm:word-bits)) - (compatible-type-p (type1 type2) - (let ((float1 (alien-float-type-p type1)) - (float2 (alien-float-type-p type2))) - (and (if float1 - float2 - (not float2)) - (= (type-words type1) (type-words type2)))))) - (let ((args1 (alien-function-type-arg-types fun-type1)) - (args2 (alien-function-type-arg-types fun-type2)) - (ret1 (alien-function-type-result-type fun-type1)) - (ret2 (alien-function-type-result-type fun-type2))) - (and (= (length args1) (length args2)) - (every #'compatible-type-p args1 args2) - (compatible-type-p ret1 ret2))))) - -(defun make-callback-trampoline (index fn-type) - (let ((return-type (alien-function-type-result-type fn-type)) - (arg-types (alien::alien-function-type-arg-types fn-type))) - (make-callback-trampoline-segment index arg-types return-type))) - -(defun make-callback-trampoline-segment (index argument-types return-type) - "Return an sb-assem:segment which calls call-callback with INDEX and -a pointer to the arguments." - (declare (type (unsigned-byte 16) index) - (optimize (debug 3))) - (flet ((make-gpr (n) - (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n)) - (make-fpr (n) - (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset n)) - (round-up-16 (n) - ;; Round up to a multiple of 16. Darwin wants that for the - ;; stack pointer. - (* 16 (ceiling n 16)))) - - ;; The "Mach-O Runtime Conventions" document for OS X almost specifies - ;; the calling convention (it neglects to mention that the linkage area - ;; is 24 bytes). - (let* ((segment (make-segment)) - (save-gprs (mapcar #'make-gpr '(13 24))) - - (argument-words - (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits)) - argument-types)) - (linkage-area-size 24)) - (assemble (segment) - - (let ((sp (make-gpr 1))) - - ;; To save our arguments, we follow the algorithm sketched in the - ;; "PowerPC Calling Conventions" section of that document. - (let ((words-processed 0) - (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10))) - (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))) - (flet ((handle-arg (type words) - (let ((integerp (not (alien-float-type-p type))) - (offset (+ (* words-processed vm:word-bytes) - linkage-area-size))) - (cond - (integerp - (dotimes (k words) - (let ((gpr (pop gprs))) - (when gpr - (inst stw gpr sp offset) - (incf words-processed) - (incf offset vm:word-bytes))))) - ;; The handling of floats is a little ugly because we - ;; hard-code the number of words for single- and - ;; double-floats. - ((alien-single-float-type-p type) - (pop gprs) - (let ((fpr (pop fprs))) - (inst stfs fpr sp offset)) - (incf words-processed)) - ((alien-double-float-type-p type) - (setf gprs (cddr gprs)) - (let ((fpr (pop fprs))) - (inst stfd fpr sp offset)) - (incf words-processed 2)))))) - (mapc #'handle-arg argument-types argument-words))) - - ;; The args have been saved to memory. - ;; - ;; The stack frame is something like this: - ;; - ;; stack arg n - ;; ... - ;; stack arg 1 - ;; stack arg 0 - ;; save arg 7 - ;; save arg 6 - ;; save arg 5 - ;; save arg 4 - ;; save arg 3 - ;; save arg 2 - ;; save arg 1 - ;; save arg 0 - ;; 24 bytes for linkage area - ;; -> sp points to the bottom of the linkage area - ;; - ;; Set aside space for our stack frame. We need enough room - ;; for the callback return area, some space to save the - ;; non-volatile (callee-saved) registers, space to save the - ;; args for the function we're calling, and the linkage - ;; area. The space is rounded up to a multiple of 16 bytes - ;; because the stack should be aligned to a multiple of 16 - ;; bytes. - ;; - ;; Our stack frame will look something like this now: - ;; - ;; Offset Value - ;; 64 Caller's frame (see above) - ;; 56/60 return area (1 or 2 words) - ;; 48 filler (unused) - ;; 44 save r24 - ;; 40 save r13 - ;; 36 save arg 3 - ;; 32 save arg 2 - ;; 28 save arg 1 - ;; 24 save arg 0 - ;; 0 linkage area (24 bytes) - ;; - ;; - ;; The return area is allocated at the top of the frame. - ;; When we call funcall3, the linkage table entry is used, - ;; which unconditionally uses r13 and r24. (See - ;; lisp/ppc-arch.c.) So these need to be saved. funcall3, - ;; which calls call_into_lisp, will take care of saving all - ;; the remaining registers that could be used. - - ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to - ;; be because they're word-aligned. Kinda gross, but - ;; hey.... - - (let* ((return-area-words (ceiling (or (alien-type-bits return-type) - 0) - vm:word-bits)) - (save-words (length save-gprs)) - (args-size (* 4 vm:word-bytes)) - (frame-size - (round-up-16 (+ linkage-area-size - (* return-area-words vm:word-bytes) - (* save-words vm:word-bytes) - args-size)))) - (destructuring-bind (r0 arg1 arg2 arg3 arg4) - (mapcar #'make-gpr '(0 3 4 5 6)) - ;; Setup the args for the call. We call - ;; funcall3(call-callback, index, arg-pointer, - ;; return-area-address) - (inst lr arg1 (alien::address-of-call-callback)) - (inst li arg2 (fixnumize index)) - (inst addi arg3 sp linkage-area-size) - (inst addi arg4 sp (- (* return-area-words vm:word-bytes))) - - ;; Save sp, setup the frame - (inst mflr r0) - (inst stw r0 sp (* 2 vm:word-bytes)) - (inst stwu sp sp (- frame-size)) - - ;; Save the caller-saved registers that the linkage - ;; table trampoline clobbers. - (let ((save-offset (+ linkage-area-size args-size))) - (dolist (r save-gprs) - (inst stw r sp save-offset) - (incf save-offset vm:word-bytes))) - - ;; Make the call - (inst lr r0 (alien::address-of-funcall3)) - (inst mtlr r0) - (inst blrl) - - (let ((return-offset (- frame-size - (* return-area-words vm:word-bytes)))) - (etypecase return-type - ((or alien::integer$ alien::pointer$ alien::sap$ - alien::integer-64$) - (loop repeat return-area-words - with gprs = (mapcar #'make-gpr '(3 4)) - for gpr = (pop gprs) - for offset from return-offset by vm:word-bytes - do (inst lwz gpr sp offset))) - (alien::single$ - ;; Get the FP value into F1 - (let ((f1 (make-fpr 1))) - (inst lfs f1 sp return-offset))) - (alien::double$ - ;; Get the FP value into F1 - (let ((f1 (make-fpr 1))) - (inst lfd f1 sp return-offset))) - (alien::void$ - ;; Nothing to do - ))) - - ;; Restore the GPRS we saved. - (let ((save-offset (+ linkage-area-size args-size))) - (dolist (r save-gprs) - (inst lwz r sp save-offset) - (incf save-offset vm:word-bytes))) - - ;; All done. Restore sp and lr and return. - (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes))) - (inst mtlr r0) - (inst addic sp sp frame-size) - - ;; And back we go! - (inst blr))))) - - (let ((length (finalize-segment segment))) - (prog1 (alien::segment-to-trampoline segment length) - (release-segment segment)))))) diff --git a/src/compiler/ppc/c-callback.lisp b/src/compiler/ppc/c-callback.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2ebd6f444f214bbd2a37196ab02e6fbd3986c52b --- /dev/null +++ b/src/compiler/ppc/c-callback.lisp @@ -0,0 +1,266 @@ +;;; -*- Package: PPC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/ppc/c-call.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +(in-package "PPC") + + +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + (let ((parsed-type (alien::parse-alien-type type))) + (typecase parsed-type + (alien::integer-64$ + ;; Get both words of a 64-bit integer and combine together, in + ;; a big-endian fashion. + `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) + ,(if (alien-integer-type-signed parsed-type) + '(* c-call:int) + '(* c-call:unsigned-int))))) + (lo (alien:deref (sap-alien (sys:sap+ ,sp + (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (+ (ash hi vm:word-bits) lo))) + (alien::integer$ + ;; We can access machine integers directly, but we need to get + ;; the offset right, since the offset we're given is the start + ;; of the object, and we're a big-endian machine. + (let ((byte-offset + (- vm:word-bytes + (ceiling (alien::alien-integer-type-bits parsed-type) + vm:byte-bits)))) + `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) + (* ,type))))) + (t + ;; This should work for everything else. + `(deref (sap-alien (sys:sap+ ,sp ,offset) + (* ,type))))))) + +(defun compatible-function-types-p (fun-type1 fun-type2) + (labels ((type-words (type) + (ceiling (alien-type-bits type) vm:word-bits)) + (compatible-type-p (type1 type2) + (let ((float1 (alien-float-type-p type1)) + (float2 (alien-float-type-p type2))) + (and (if float1 + float2 + (not float2)) + (= (type-words type1) (type-words type2)))))) + (let ((args1 (alien-function-type-arg-types fun-type1)) + (args2 (alien-function-type-arg-types fun-type2)) + (ret1 (alien-function-type-result-type fun-type1)) + (ret2 (alien-function-type-result-type fun-type2))) + (and (= (length args1) (length args2)) + (every #'compatible-type-p args1 args2) + (compatible-type-p ret1 ret2))))) + +(defun make-callback-trampoline (index fn-type) + (let ((return-type (alien-function-type-result-type fn-type)) + (arg-types (alien::alien-function-type-arg-types fn-type))) + (make-callback-trampoline-segment index arg-types return-type))) + +(defun make-callback-trampoline-segment (index argument-types return-type) + "Return an sb-assem:segment which calls call-callback with INDEX and +a pointer to the arguments." + (declare (type (unsigned-byte 16) index) + (optimize (debug 3))) + (flet ((make-gpr (n) + (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n)) + (make-fpr (n) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset n)) + (round-up-16 (n) + ;; Round up to a multiple of 16. Darwin wants that for the + ;; stack pointer. + (* 16 (ceiling n 16)))) + + ;; The "Mach-O Runtime Conventions" document for OS X almost specifies + ;; the calling convention (it neglects to mention that the linkage area + ;; is 24 bytes). + (let* ((segment (make-segment)) + (save-gprs (mapcar #'make-gpr '(13 24))) + + (argument-words + (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits)) + argument-types)) + (linkage-area-size 24)) + (assemble (segment) + + (let ((sp (make-gpr 1))) + + ;; To save our arguments, we follow the algorithm sketched in the + ;; "PowerPC Calling Conventions" section of that document. + (let ((words-processed 0) + (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10))) + (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))) + (flet ((handle-arg (type words) + (let ((integerp (not (alien-float-type-p type))) + (offset (+ (* words-processed vm:word-bytes) + linkage-area-size))) + (cond + (integerp + (dotimes (k words) + (let ((gpr (pop gprs))) + (when gpr + (inst stw gpr sp offset) + (incf words-processed) + (incf offset vm:word-bytes))))) + ;; The handling of floats is a little ugly because we + ;; hard-code the number of words for single- and + ;; double-floats. + ((alien-single-float-type-p type) + (pop gprs) + (let ((fpr (pop fprs))) + (inst stfs fpr sp offset)) + (incf words-processed)) + ((alien-double-float-type-p type) + (setf gprs (cddr gprs)) + (let ((fpr (pop fprs))) + (inst stfd fpr sp offset)) + (incf words-processed 2)))))) + (mapc #'handle-arg argument-types argument-words))) + + ;; The args have been saved to memory. + ;; + ;; The stack frame is something like this: + ;; + ;; stack arg n + ;; ... + ;; stack arg 1 + ;; stack arg 0 + ;; save arg 7 + ;; save arg 6 + ;; save arg 5 + ;; save arg 4 + ;; save arg 3 + ;; save arg 2 + ;; save arg 1 + ;; save arg 0 + ;; 24 bytes for linkage area + ;; -> sp points to the bottom of the linkage area + ;; + ;; Set aside space for our stack frame. We need enough room + ;; for the callback return area, some space to save the + ;; non-volatile (callee-saved) registers, space to save the + ;; args for the function we're calling, and the linkage + ;; area. The space is rounded up to a multiple of 16 bytes + ;; because the stack should be aligned to a multiple of 16 + ;; bytes. + ;; + ;; Our stack frame will look something like this now: + ;; + ;; Offset Value + ;; 64 Caller's frame (see above) + ;; 56/60 return area (1 or 2 words) + ;; 48 filler (unused) + ;; 44 save r24 + ;; 40 save r13 + ;; 36 save arg 3 + ;; 32 save arg 2 + ;; 28 save arg 1 + ;; 24 save arg 0 + ;; 0 linkage area (24 bytes) + ;; + ;; + ;; The return area is allocated at the top of the frame. + ;; When we call funcall3, the linkage table entry is used, + ;; which unconditionally uses r13 and r24. (See + ;; lisp/ppc-arch.c.) So these need to be saved. funcall3, + ;; which calls call_into_lisp, will take care of saving all + ;; the remaining registers that could be used. + + ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to + ;; be because they're word-aligned. Kinda gross, but + ;; hey.... + + (let* ((return-area-words (ceiling (or (alien-type-bits return-type) + 0) + vm:word-bits)) + (save-words (length save-gprs)) + (args-size (* 4 vm:word-bytes)) + (frame-size + (round-up-16 (+ linkage-area-size + (* return-area-words vm:word-bytes) + (* save-words vm:word-bytes) + args-size)))) + (destructuring-bind (r0 arg1 arg2 arg3 arg4) + (mapcar #'make-gpr '(0 3 4 5 6)) + ;; Setup the args for the call. We call + ;; funcall3(call-callback, index, arg-pointer, + ;; return-area-address) + (inst lr arg1 (alien::address-of-call-callback)) + (inst li arg2 (fixnumize index)) + (inst addi arg3 sp linkage-area-size) + (inst addi arg4 sp (- (* return-area-words vm:word-bytes))) + + ;; Save sp, setup the frame + (inst mflr r0) + (inst stw r0 sp (* 2 vm:word-bytes)) + (inst stwu sp sp (- frame-size)) + + ;; Save the caller-saved registers that the linkage + ;; table trampoline clobbers. + (let ((save-offset (+ linkage-area-size args-size))) + (dolist (r save-gprs) + (inst stw r sp save-offset) + (incf save-offset vm:word-bytes))) + + ;; Make the call + (inst lr r0 (alien::address-of-funcall3)) + (inst mtlr r0) + (inst blrl) + + (let ((return-offset (- frame-size + (* return-area-words vm:word-bytes)))) + (etypecase return-type + ((or alien::integer$ alien::pointer$ alien::sap$ + alien::integer-64$) + (loop repeat return-area-words + with gprs = (mapcar #'make-gpr '(3 4)) + for gpr = (pop gprs) + for offset from return-offset by vm:word-bytes + do (inst lwz gpr sp offset))) + (alien::single$ + ;; Get the FP value into F1 + (let ((f1 (make-fpr 1))) + (inst lfs f1 sp return-offset))) + (alien::double$ + ;; Get the FP value into F1 + (let ((f1 (make-fpr 1))) + (inst lfd f1 sp return-offset))) + (alien::void$ + ;; Nothing to do + ))) + + ;; Restore the GPRS we saved. + (let ((save-offset (+ linkage-area-size args-size))) + (dolist (r save-gprs) + (inst lwz r sp save-offset) + (incf save-offset vm:word-bytes))) + + ;; All done. Restore sp and lr and return. + (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes))) + (inst mtlr r0) + (inst addic sp sp frame-size) + + ;; And back we go! + (inst blr))))) + + (let ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment)))))) diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp index 042854eba186d3f5fcd9c7eec9b2b23e8b2a7cf2..c3a18becbf89abfab16597bf5802208561a4d8e8 100644 --- a/src/compiler/sparc/c-call.lisp +++ b/src/compiler/sparc/c-call.lisp @@ -312,205 +312,3 @@ (t (inst li temp delta) (inst add nsp-tn temp))))))) - -;;; Support for callbacks to Lisp. -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - (let ((parsed-type (alien::parse-alien-type type))) - (typecase parsed-type - (alien::double$ - ;; Due to sparc calling conventions, a double arg 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. Doubles are - ;; stored in big-endian order, naturally. - `(kernel:make-double-float - (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int))) - (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (alien::integer-64$ - ;; Same as for double, above - `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) - ,(if (alien-integer-type-signed parsed-type) - '(* c-call:int) - '(* c-call:unsigned-int))))) - (lo (alien:deref (sap-alien (sys:sap+ ,sp - (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (+ (ash hi vm:word-bits) lo))) - (alien::integer$ - ;; All other objects can be accessed directly. But we need to - ;; get the offset right, since the offset we're given is the - ;; start of the object, and we're a big-endian machine. - (let ((byte-offset - (- vm:word-bytes - (ceiling (alien::alien-integer-type-bits parsed-type) - vm:byte-bits)))) - `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) - (* ,type))))) - (t - `(deref (sap-alien (sys:sap+ ,sp ,offset) - (* ,type))))))) - -(defun compatible-function-types-p (type1 type2) - (flet ((machine-rep (type) - (etypecase type - (alien::integer-64$ :dword) - ((or alien::integer$ alien::pointer$ alien::sap$) :word) - (alien::single$ :single) - (alien::double$ :double) - (alien::void$ :void)))) - (let ((type1 (alien-function-type-result-type type1)) - (type2 (alien-function-type-result-type type2))) - (eq (machine-rep type1) (machine-rep type2))))) - -(defun make-callback-trampoline (index fn-type) - "Cons up a piece of code which calls call-callback with INDEX and a -pointer to the arguments." - (let ((return-type (alien-function-type-result-type fn-type))) - (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 26)) - (%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)) - (%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 nop)) - - ;; Ok, we're back. The value returned is actually - ;; stored in the return area. Need to get that into - ;; the right registers for return. - (etypecase return-type - (alien::integer-64$ - ;; A 64-bit bignum, stored big-endian - (inst ld %i0 %fp (- return-value-size)) - (inst ld %i1 %fp (- (- return-value-size vm:word-bytes)))) - ((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/src/compiler/sparc/c-callback.lisp b/src/compiler/sparc/c-callback.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ac97f9c26b3b74119dbcb70042737c691a2b9995 --- /dev/null +++ b/src/compiler/sparc/c-callback.lisp @@ -0,0 +1,215 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/compiler/sparc/c-call.lisp $") + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + (let ((parsed-type (alien::parse-alien-type type))) + (typecase parsed-type + (alien::double$ + ;; Due to sparc calling conventions, a double arg 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. Doubles are + ;; stored in big-endian order, naturally. + `(kernel:make-double-float + (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int))) + (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (alien::integer-64$ + ;; Same as for double, above + `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) + ,(if (alien-integer-type-signed parsed-type) + '(* c-call:int) + '(* c-call:unsigned-int))))) + (lo (alien:deref (sap-alien (sys:sap+ ,sp + (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (+ (ash hi vm:word-bits) lo))) + (alien::integer$ + ;; All other objects can be accessed directly. But we need to + ;; get the offset right, since the offset we're given is the + ;; start of the object, and we're a big-endian machine. + (let ((byte-offset + (- vm:word-bytes + (ceiling (alien::alien-integer-type-bits parsed-type) + vm:byte-bits)))) + `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) + (* ,type))))) + (t + `(deref (sap-alien (sys:sap+ ,sp ,offset) + (* ,type))))))) + +(defun compatible-function-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (alien::integer-64$ :dword) + ((or alien::integer$ alien::pointer$ alien::sap$) :word) + (alien::single$ :single) + (alien::double$ :double) + (alien::void$ :void)))) + (let ((type1 (alien-function-type-result-type type1)) + (type2 (alien-function-type-result-type type2))) + (eq (machine-rep type1) (machine-rep type2))))) + +(defun make-callback-trampoline (index fn-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let ((return-type (alien-function-type-result-type fn-type))) + (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 26)) + (%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)) + (%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 nop)) + + ;; Ok, we're back. The value returned is actually + ;; stored in the return area. Need to get that into + ;; the right registers for return. + (etypecase return-type + (alien::integer-64$ + ;; A 64-bit bignum, stored big-endian + (inst ld %i0 %fp (- return-value-size)) + (inst ld %i1 %fp (- (- return-value-size vm:word-bytes)))) + ((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/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 7efd0b969ee29f0d75fae9913605f36ffe70fe5e..4554a0e9c509c4874aa7f1b01ddfd378f3bdbe64 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -244,68 +244,3 @@ (ash symbol-value-slot word-shift) (- other-pointer-type))) delta))))) - -;;; Support for callbacks to Lisp. -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - `(alien:deref (sap-alien - (sys:sap+ ,sp ,offset) - (* ,type)))) - -(defun compatible-function-types-p (type1 type2) - (flet ((machine-rep (type) - (etypecase type - (alien::integer-64$ :dword) - ((or alien::integer$ alien::pointer$ alien::sap$) :word) - (alien::single$ :single) - (alien::double$ :double) - (alien::void$ :void)))) - (let ((type1 (alien-function-type-result-type type1)) - (type2 (alien-function-type-result-type type2))) - (eq (machine-rep type1) (machine-rep type2))))) - -(defun make-callback-trampoline (index fn-type) - "Cons up a piece of code which calls call-callback with INDEX and a -pointer to the arguments." - (let* ((return-type (alien-function-type-result-type fn-type)) - (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))))) - - diff --git a/src/compiler/x86/c-callback.lisp b/src/compiler/x86/c-callback.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b9e27fc687481ee20f5e08cc4df75291cd3b8cc5 --- /dev/null +++ b/src/compiler/x86/c-callback.lisp @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/x86/c-call.lisp $") + +(in-package :x86) +(use-package :alien) +(use-package :alien-internals) +(intl:textdomain "cmucl-x86-vm") + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + `(alien:deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type)))) + +(defun compatible-function-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (alien::integer-64$ :dword) + ((or alien::integer$ alien::pointer$ alien::sap$) :word) + (alien::single$ :single) + (alien::double$ :double) + (alien::void$ :void)))) + (let ((type1 (alien-function-type-result-type type1)) + (type2 (alien-function-type-result-type type2))) + (eq (machine-rep type1) (machine-rep type2))))) + +(defun make-callback-trampoline (index fn-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let* ((return-type (alien-function-type-result-type fn-type)) + (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))))) + + diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp index a968506652bd3b3cf3ac6c4dd9ec5c2bf4e2594a..0953dc07d83a261bd226cc4973d10a556bf1709e 100644 --- a/src/tools/comcom.lisp +++ b/src/tools/comcom.lisp @@ -197,6 +197,7 @@ (vmdir "target:compiler/sse2-c-call") (vmdir "target:compiler/x87-c-call")) :byte-compile *byte-compile*)) +(comf (vmdir "target:compiler/c-callback")) (comf (vmdir "target:compiler/cell")) (comf (vmdir "target:compiler/values") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/alloc")) diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp index fac94280ced33ec3a5ca9b2cd95ddf4ab6becce0..9a74818bd6f8d2297af9d4244edaf6ce651d784d 100644 --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -138,6 +138,7 @@ (setf (fdefinition 'lisp::%deftype) *original-%deftype*) (comf "target:code/alieneval") +(comf "target:code/alien-callback") (comf "target:code/c-call") (comf "target:code/sap")