--- /dev/null
+;;; -*- 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
(values ,@temps ,@(results))))
`(values (alien-funcall ,lisp-name ,@(alien-args))
,@(results))))))))
-\f
-;;;; 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
(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))))))
--- /dev/null
+;;; -*- 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))))))
(t
(inst li temp delta)
(inst add nsp-tn temp)))))))
-\f
-;;; 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)))))))
-
-
--- /dev/null
+;;; -*- 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")
+\f
+;;; 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)))))))
+
+
(ash symbol-value-slot word-shift)
(- other-pointer-type)))
delta)))))
-\f
-;;; 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)))))
-
-
--- /dev/null
+;;; -*- 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)))))
+
+
(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"))
(setf (fdefinition 'lisp::%deftype) *original-%deftype*)
(comf "target:code/alieneval")
+(comf "target:code/alien-callback")
(comf "target:code/c-call")
(comf "target:code/sap")
common-lisp.net / projects/cmucl/cmucl.git / commitdiff
