[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-13-gcf48b6d
Raymond Toy
rtoy at common-lisp.net
Sun Dec 23 19:36:22 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via cf48b6dccb205acec059a87602f3f1182c781a6e (commit)
via 5d37fbf143530c391429d52fa07873e648675d86 (commit)
via 0df4a14d0f2e83c6b6fdd9a5fd2b7cb024100660 (commit)
from abc43728326721c0862a483035ad328400eca845 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cf48b6dccb205acec059a87602f3f1182c781a6e
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Dec 23 11:25:48 2012 -0800
Move the alien callback support into its own files.
compiler/ppc/c-callback.lisp::
compiler/sparc/c-callback.lisp::
compiler/x86/c-callback.lisp::
New file containing the callback code from c-call.lisp.
compiler/ppc/c-call.lisp::
compiler/sparc/c-call.lisp::
compiler/x86/c-call.lisp::
Removed the callback code.
code/alien-callback.lisp::
New file containing the alien callback code.
code/alieneval.lisp::
Removed the alien callback code.
tools/comcom.lisp::
Compile c-callback.lisp
tools/worldcom.lisp:
Compile alien-callback.lisp.
diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
new file mode 100644
index 0000000..b6e73be
--- /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))))
+ , at 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))
+ , at 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 , at 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 c8f0fb8..124f74e 100644
--- a/src/code/alieneval.lisp
+++ b/src/code/alieneval.lisp
@@ -2078,296 +2078,3 @@ If so return true; otherwise call ALTERNATIVE."
(values , at 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))))
- , at 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))
- , at 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 , at 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 4fd20b6..1d08a2e 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 0000000..2ebd6f4
--- /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 at 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 042854e..c3a18be 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 0000000..ac97f9c
--- /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 7efd0b9..4554a0e 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 0000000..b9e27fc
--- /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 at 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 a968506..0953dc0 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 fac9428..9a74818 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")
commit 5d37fbf143530c391429d52fa07873e648675d86
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Dec 23 10:57:48 2012 -0800
Get rid of the unused bit-bash-<foo> symbols.
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index 5a9bdaf..b127c27 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -2110,10 +2110,7 @@
"ARRAY-RANK" "ARRAY-TOTAL-SIZE" "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP"
"ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" "ARRAY-TYPE-P"
"ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX" "BASE-CHAR-P"
- "BINDING-STACK-POINTER-SAP" "BIT-BASH-AND" "BIT-BASH-ANDC1"
- "BIT-BASH-ANDC2" "BIT-BASH-CLEAR" "BIT-BASH-COPY" "BIT-BASH-EQV"
- "BIT-BASH-IOR" "BIT-BASH-LOGNAND" "BIT-BASH-LOGNOR" "BIT-BASH-NOT"
- "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET" "BIT-BASH-XOR" "BIT-INDEX"
+ "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX"
"BYTE-BASH-COPY"
"BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE"
"BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT"
commit 0df4a14d0f2e83c6b6fdd9a5fd2b7cb024100660
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Dec 23 10:56:50 2012 -0800
Use BYTE-BASH-COPY in the string transforms for SUBSEQ and COPY-SEQ.
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index aa8cd4f..f8ecf24 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -218,25 +218,25 @@
(size (- end start))
(result (make-string size)))
(declare (optimize (safety 0)))
- (bit-bash-copy string
- (the index
- (+ (the index (* start vm:char-bits))
- vector-data-bit-offset))
- result
- vector-data-bit-offset
- (the index (* size vm:char-bits)))
- result))
+ (byte-bash-copy string
+ (the vm::offset
+ (+ (the vm::offset (* start vm:char-bytes))
+ vector-data-byte-offset))
+ result
+ vector-data-byte-offset
+ (the vm::offset (* size vm:char-bytes)))
+ result))
(deftransform copy-seq ((seq) (simple-string))
'(let* ((len (length seq))
(res (make-string len)))
(declare (optimize (safety 0)))
(bit-bash-copy seq
- vector-data-bit-offset
+ vector-data-byte-offset
res
- vector-data-bit-offset
- (the index (* len vm:char-bits)))
- res))
+ vector-data-byte-offset
+ (the vm::offset (* len vm:char-bytes)))
+ res))
(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
end1 end2)
@@ -254,7 +254,7 @@
(locally
(declare (optimize (safety 0)))
- (byte-bash-copy string2
+ (vm::byte-bash-copy string2
(the vm::offset
(+ (the vm::offset (* start2 vm:char-bytes))
vector-data-byte-offset))
-----------------------------------------------------------------------
Summary of changes:
src/code/alien-callback.lisp | 417 ++++++++++++++++++++++++++++++++++++
src/code/alieneval.lisp | 293 -------------------------
src/code/exports.lisp | 5 +-
src/compiler/generic/vm-tran.lisp | 26 ++--
src/compiler/ppc/c-call.lisp | 247 ---------------------
src/compiler/ppc/c-callback.lisp | 266 +++++++++++++++++++++++
src/compiler/sparc/c-call.lisp | 202 -----------------
src/compiler/sparc/c-callback.lisp | 215 +++++++++++++++++++
src/compiler/x86/c-call.lisp | 65 ------
src/compiler/x86/c-callback.lisp | 80 +++++++
src/tools/comcom.lisp | 1 +
src/tools/worldcom.lisp | 1 +
12 files changed, 994 insertions(+), 824 deletions(-)
create mode 100644 src/code/alien-callback.lisp
create mode 100644 src/compiler/ppc/c-callback.lisp
create mode 100644 src/compiler/sparc/c-callback.lisp
create mode 100644 src/compiler/x86/c-callback.lisp
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list