From 47df5ecb4109844237e56e445379f8bca4915b9c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 15 Jun 2005 06:13:13 +0000 Subject: [PATCH] 0.9.1.42: partial callback implementation * SB-ALIEN-INTERNALS:ALIEN-CALLBACK (to be exported from SB-ALIEN at a later date) makes callbacks for functions designators that can be ALIEN-FUNCALLed or passes as function pointers to C-code. Based on patch by Thomas F. Burdick based on work for CMUCL by Helmut Eller. PPC/Darwin only for now. --- package-data-list.lisp-expr | 12 +++- src/code/target-alieneval.lisp | 129 ++++++++++++++++++++++++++++++++++++++++ src/compiler/ppc/c-call.lisp | 128 +++++++++++++++++++++++++++++++++++++++ src/compiler/ppc/insts.lisp | 9 +-- version.lisp-expr | 2 +- 5 files changed, 268 insertions(+), 12 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a44e070..7ff4ef7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -42,7 +42,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "SYSTEM-AREA-POINTER" "UNION" "VALUES" "*") :export ("ADDR" - "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" + "ALIEN" + "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" "CAST" "C-STRING" "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE" @@ -67,7 +68,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "UTF8-STRING" "VOID" "WITH-ALIEN")) - + #s(sb-cold:package-data :name "SB!ALIEN-INTERNALS" :doc "private: stuff for implementing ALIENs and friends" @@ -79,6 +80,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" + "ALIEN-CALLBACK" + "ALIEN-CALLBACK-ACCESSOR-FORM" + "ALIEN-CALLBACK-ASSEMBLER-WRAPPER" "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" "ALIEN-FLOAT-TYPE-P" "ALIEN-FUN-TYPE" @@ -103,7 +107,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS" "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" "DEPORT" - "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" + "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" + "ENTER-ALIEN-CALLBACK" + "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 63f7f2c..5e93461 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -723,3 +723,132 @@ (typep object lisp-rep-type) (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) + +;;;; ALIEN-CALLBACKS +;;;; +;;;; An alien callback has 4 parts / stages: +;;;; +;;;; * ASSEMBLER WRAPPER that saves the arguments from the C-call +;;;; according to the alien-fun-type of the callback, and calls +;;;; #'ENTER-ALIEN-CALLBACK with the index indentifying the +;;;; callback, a pointer to the arguments copied on the stack and a +;;;; pointer to return value storage. When control returns to the +;;;; wrapper it returns the value to C. There is one assembler +;;;; wrapper per callback.[1] The SAP to the wrapper code vector +;;;; is what is passed to foreign code as a callback. +;;;; +;;;; * #'ENTER-ALIEN-CALLBACK pulls the LISP TRAMPOLINE for the given +;;;; index, and calls it with the argument and result pointers. +;;;; +;;;; * LISP TRAMPOLINE that calls the LISP WRAPPER with the argument +;;;; and result pointers, and the function designator for the +;;;; callback. There is one lisp trampoline per callback. +;;;; +;;;; * LISP WRAPPER parses the arguments from stack, calls the actual +;;;; callback with the arguments, and saves the return value at the +;;;; result pointer. The lisp wrapper is shared between all the +;;;; callbacks having the same same alien-fun-type. +;;;; +;;;; [1] As assembler wrappers need to be allocated in static +;;;; addresses and are (in the current scheme of things) never +;;;; released it might be worth it to split it into two parts: +;;;; per-callback trampoline that pushes the index of the lisp +;;;; trampoline on the stack, and jumps to the appropriate assembler +;;;; wrapper. The assembler wrapper could then be shared between all +;;;; the callbacks with the same alien-fun-type. This would amortize +;;;; most of the static allocation costs between multiple callbacks. + +(defvar *alien-callbacks* (make-hash-table :test #'equal) + "Maps (SPECIFIER . FUNCTION) to callbacks.") + +(defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t) + "Maps alien callback indexes to lisp trampolines.") + +(defparameter *alien-callback-wrappers* (make-hash-table :test #'equal) + "Maps SPECIFIER to lisp wrappers.") + +(defun alien-callback (specifier function &optional env) + "Returns an SAP to an alien callback corresponding to the function and +alien-ftype-specifier." + (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + (let ((key (cons specifier function))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types)) + (lisp-wrapper (alien-callback-lisp-wrapper + specifier result-type argument-types env))) + (vector-push-extend + (lambda (args-pointer result-pointer) + (funcall lisp-wrapper args-pointer result-pointer function)) + *alien-callback-trampolines*) + (%sap-alien (vector-sap assembler-wrapper) + (parse-alien-type specifier env)))))))) + +(defun alien-callback-lisp-wrapper (specifier result-type argument-types env) + (or (gethash specifier *alien-callback-wrappers*) + (setf (gethash specifier *alien-callback-wrappers*) + (compile + nil + (let* ((arguments (make-gensym-list (length argument-types))) + (argument-names arguments) + (argument-specs (cddr specifier))) + `(lambda (args-pointer result-pointer function) + (let ((args-sap (int-sap + (sb!kernel:get-lisp-obj-address args-pointer))) + (res-sap (int-sap + (sb!kernel:get-lisp-obj-address result-pointer)))) + (with-alien + ,(loop + for spec in argument-specs + for offset = 0 ; FIXME: Should this not be AND OFFSET ...? + then (+ offset (alien-callback-argument-bytes spec env)) + collect `(,(pop argument-names) ,spec + :local ,(alien-callback-accessor-form + spec 'args-sap offset))) + ,(flet ((store (spec) + (if spec + `(setf (deref (sap-alien res-sap (* ,spec))) + (funcall function ,@arguments)) + `(funcall function ,@arguments)))) + (cond ((alien-void-type-p result-type) + (store nil)) + ((alien-integer-type-p result-type) + (if (alien-integer-type-signed result-type) + (store `(signed + ,(alien-type-word-aligned-bits result-type))) + (store + `(unsigned + ,(alien-type-word-aligned-bits result-type))))) + (t + (store (unparse-alien-type result-type))))))) + (values))))))) + +(defun parse-alien-ftype (specifier env) + (destructuring-bind (function result-type &rest argument-types) + specifier + (aver (eq 'function function)) + (values (parse-alien-type result-type env) + (mapcar (lambda (spec) + (parse-alien-type spec env)) + argument-types)))) + +(defun alien-void-type-p (type) + (and (alien-values-type-p type) (not (alien-values-type-values type)))) + +(defun alien-type-word-aligned-bits (type) + (align-offset (alien-type-bits type) sb!vm:n-word-bits)) + +(defun alien-callback-argument-bytes (spec env) + (let ((type (parse-alien-type spec env))) + (if (or (alien-integer-type-p type) + (alien-float-type-p type) + (alien-pointer-type-p type)) + (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits) + (error "Unsupported callback argument type: ~A" type)))) + +(defun enter-alien-callback (index return arguments) + (funcall (aref *alien-callback-trampolines* index) + return + arguments)) diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index 3543dc4..fa4df33 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -382,3 +382,131 @@ (inst addi nsp-tn nsp-tn delta)) (t (inst lwz nsp-tn nsp-tn 0))))))) + +#-sb-xc-host +(progn + (defun alien-callback-accessor-form (type sap offset) + ;; Unaligned access is slower, but possible, so this is nice and simple. + `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))) + + ;;; 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). + (defconstant n-foreign-linkage-area-bytes 24) + + ;;; Returns a vector in static space containing machine code for the + ;;; callback wrapper + (defun alien-callback-assembler-wrapper (index result-type argument-types) + (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))) + (let* ((segment (make-segment))) + (assemble (segment) + ;; 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))) + (stack-pointer (make-gpr 1))) + (labels ((out-of-registers-error () + (error "Too many arguments in callback")) + (save-arg (type words) + (let ((integerp (not (alien-float-type-p type))) + (offset (+ (* words-processed n-word-bytes) + n-foreign-linkage-area-bytes))) + (cond (integerp + (loop repeat words + for gpr = (pop gprs) + do + (if gpr + (inst stw gpr stack-pointer offset) + (out-of-registers-error)) + (incf words-processed))) + ;; 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))) + (if fpr + (inst stfs fpr stack-pointer offset) + (out-of-registers-error))) + (incf words-processed)) + ((alien-double-float-type-p type) + (setf gprs (cddr gprs)) + (let ((fpr (pop fprs))) + (if fpr + (inst stfd fpr stack-pointer offset) + (out-of-registers-error))) + (incf words-processed 2)) + (t + (bug "Unknown alien floating point type: ~S" type)))))) + (mapc #'save-arg + argument-types + (mapcar (lambda (arg) + (ceiling (alien-type-bits arg) n-word-bits)) + argument-types)))) + ;; Set aside room for the return area just below sp, then + ;; actually call funcall3: funcall3 (call-alien-function, + ;; index, args, return-area) + ;; + ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be + ;; because they're word-aligned. Kinda gross, but hey ... + (let* ((n-return-area-words + (ceiling (or (alien-type-bits result-type) 0) n-word-bits)) + (n-return-area-bytes (* n-return-area-words n-word-bytes)) + ;; FIXME: magic constant, and probably n-args-bytes + (args-size (* 3 n-word-bytes)) + ;; FIXME: n-frame-bytes? + (frame-size + (+ n-foreign-linkage-area-bytes n-return-area-bytes args-size))) + (destructuring-bind (sp r0 arg1 arg2 arg3 arg4) + (mapcar #'make-gpr '(1 0 3 4 5 6)) + (flet ((load-address-into (reg addr) + (let ((high (ldb (byte 16 16) addr)) + (low (ldb (byte 16 0) addr))) + (inst li reg high) + (inst slwi reg reg 16) + (inst ori reg reg low)))) + ;; Setup the args + (load-address-into + arg1 (get-lisp-obj-address #'enter-alien-callback)) + (inst li arg2 (fixnumize index)) + (inst addi arg3 sp n-foreign-linkage-area-bytes) + ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while + ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES): + ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows? + ;; --NS 2005-06-11 + (inst addi arg4 sp (- n-return-area-bytes)) + ;; FIXME! FIXME FIXME: What does this FIXME refer to? + ;; Save sp, setup the frame + (inst mflr r0) + (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant + (inst stwu sp sp (- frame-size)) + ;; Make the call + (load-address-into r0 (foreign-symbol-address-as-integer "funcall3")) + (inst mtlr r0) + (inst blrl)) + ;; We're back! Restore sp and lr, load the return value from just + ;; under sp, and return. + (inst lwz sp sp 0) + (inst lwz r0 sp (* 2 n-word-bytes)) + (inst mtlr r0) + (loop with gprs = (mapcar #'make-gpr '(3 4)) + repeat n-return-area-words + for gpr = (pop gprs) + for offset downfrom (- n-word-bytes) by n-word-bytes + do + (unless gpr + (bug "Out of return registers in alien-callback trampoline.")) + (inst lwz gpr sp offset)) + (inst blr)))) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb!assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer)))))) + \ No newline at end of file diff --git a/src/compiler/ppc/insts.lisp b/src/compiler/ppc/insts.lisp index b31d85c..1ce960f 100644 --- a/src/compiler/ppc/insts.lisp +++ b/src/compiler/ppc/insts.lisp @@ -1971,18 +1971,11 @@ (define-instruction-macro bula (target) `(inst bcla :bo-u 0 ,target)) - +|# (define-instruction-macro blrl () `(inst bclrl :bo-u 0)) - - -|# - - - - ;;; Some more macros diff --git a/version.lisp-expr b/version.lisp-expr index 0fe1c4e..edae304 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.41" +"0.9.1.42" -- 1.7.10.4