X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=e746b72ec9dd3eaa395dc8950059c65e01da3c60;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=091841f211b84f4db9efb9e22d41106a9fc9e6ba;hpb=6c765578c8dc4bcc7798e37c9918715f198b30da;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 091841f..e746b72 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -35,53 +35,70 @@ ;;; guess the other. (eval-when (:compile-toplevel :load-toplevel :execute) (defun pick-lisp-and-alien-names (name) - (etypecase name - (string - (values (guess-lisp-name-from-alien-name name) name)) - (symbol - (values name (guess-alien-name-from-lisp-name name))) - (list - (unless (proper-list-of-length-p name 2) - (error "badly formed alien name")) - (values (cadr name) (car name)))))) - -(defmacro def-alien-variable (name type &environment env) + (flet ((oops () + (error "~@<~:IMalformed alien name. Acceptable formats are:~ + ~:@_ (\"alien_name\" LISP-NAME)~ + ~:@_ FOO-BAR - equivalent to (\"foo_bar\" FOO-BAR)~ + ~:@_ \"foo_bar\" - equivalent to (\"foo_bar\" FOO-BAR)~:@>"))) + (etypecase name + (string + (values (guess-lisp-name-from-alien-name name) + (coerce name 'simple-string))) + (symbol + (values name (guess-alien-name-from-lisp-name name))) + (list + (unless (and (proper-list-of-length-p name 2) + (symbolp (second name)) + (stringp (first name))) + (oops)) + (values (second name) (coerce (first name) 'simple-string))) + (t + (oops)))))) + +(defmacro define-alien-variable (name type &environment env) #!+sb-doc - "Define NAME as an external alien variable of type TYPE. NAME should be - a list of a string holding the alien name and a symbol to use as the Lisp - name. If NAME is just a symbol or string, then the other name is guessed - from the one supplied." + "Define NAME as an external alien variable of type TYPE. NAME should +be a list of a string holding the alien name and a symbol to use as +the Lisp name. If NAME is just a symbol or string, then the other name +is guessed from the one supplied." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - (%def-alien-variable ',lisp-name - ',alien-name - ',alien-type)))))) - -;;; Do the actual work of DEF-ALIEN-VARIABLE. + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) + (%define-alien-variable ',lisp-name + ',alien-name + ',alien-type)))))) + +;;; Do the actual work of DEFINE-ALIEN-VARIABLE. (eval-when (:compile-toplevel :load-toplevel :execute) - (defun %def-alien-variable (lisp-name alien-name type) + (defun %define-alien-variable (lisp-name alien-name type) (setf (info :variable :kind lisp-name) :alien) (setf (info :variable :where-from lisp-name) :defined) - (clear-info :variable :constant-value lisp-name) (setf (info :variable :alien-info lisp-name) - (make-heap-alien-info :type type - :sap-form `(foreign-symbol-address - ',alien-name))))) + (make-heap-alien-info :type type + :alien-name alien-name + :datap t)))) + +(defun alien-value (symbol) + #!+sb-doc + "Returns the value of the alien variable bound to SYMBOL. Signals an +error if SYMBOL is not bound to an alien variable, or if the alien +variable is undefined." + (%heap-alien (or (info :variable :alien-info symbol) + (error 'unbound-variable :name symbol)))) (defmacro extern-alien (name type &environment env) #!+sb-doc - "Access the alien variable named NAME, assuming it is of type TYPE. This - is SETFable." - (let ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name)))) - `(%heap-alien ',(make-heap-alien-info - :type (parse-alien-type type env) - :sap-form `(foreign-symbol-address ',alien-name))))) + "Access the alien variable named NAME, assuming it is of type TYPE. +This is SETFable." + (let* ((alien-name (etypecase name + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) + `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -90,70 +107,98 @@ ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. - :STATIC - The alien is allocated on the heap, and has infinite extent. The alien - is allocated at load time, so the same piece of memory is used each time - this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." + ;; FIXME: + ;; :STATIC + ;; The alien is allocated on the heap, and has infinite extent. The alien + ;; is allocated at load time, so the same piece of memory is used each time + ;; this form executes. + (/show "entering WITH-ALIEN" bindings) (with-auxiliary-alien-types env (dolist (binding (reverse bindings)) + (/show binding) (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) - binding - (let ((alien-type (parse-alien-type type env))) - (multiple-value-bind (allocation initial-value) - (if opt2p - (values opt1 opt2) - (case opt1 - (:extern - (values opt1 (guess-alien-name-from-lisp-name symbol))) - (:static - (values opt1 nil)) - (t - (values :local opt1)))) - (setf body - (ecase allocation - #+nil - (:static - (let ((sap - (make-symbol (concatenate 'string "SAP-FOR-" - (symbol-name symbol))))) - `((let ((,sap (load-time-value (%make-alien ...)))) - (declare (type system-area-pointer ,sap)) - (symbol-macrolet - ((,symbol (sap-alien ,sap ,type))) - ,@(when initial-value - `((setq ,symbol ,initial-value))) - ,@body))))) - (:extern - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-address - ',initial-value)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) - (:local - (let ((var (gensym)) - (initval (if initial-value (gensym))) - (info (make-local-alien-info :type alien-type))) - `((let ((,var (make-local-alien ',info)) - ,@(when initial-value - `((,initval ,initial-value)))) - (note-local-alien-type ',info ,var) - (multiple-value-prog1 - (symbol-macrolet - ((,symbol (local-alien ',info ,var))) - ,@(when initial-value - `((setq ,symbol ,initval))) - ,@body) - (dispose-local-alien ',info ,var)))))))))))) + (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + binding + (/show symbol type opt1 opt2) + (let* ((alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) + (/show alien-type) + (multiple-value-bind (allocation initial-value) + (if opt2p + (values opt1 opt2) + (case opt1 + (:extern + (values opt1 (guess-alien-name-from-lisp-name symbol))) + (:static + (values opt1 nil)) + (t + (values :local opt1)))) + (/show allocation initial-value) + (setf body + (ecase allocation + #+nil + (:static + (let ((sap + (make-symbol (concatenate 'string "SAP-FOR-" + (symbol-name symbol))))) + `((let ((,sap (load-time-value (%make-alien ...)))) + (declare (type system-area-pointer ,sap)) + (symbol-macrolet + ((,symbol (sap-alien ,sap ,type))) + ,@(when initial-value + `((setq ,symbol ,initial-value))) + ,@body))))) + (:extern + (/show0 ":EXTERN case") + `((symbol-macrolet + ((,symbol + (%alien-value + (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type))) + ,@body))) + (:local + (/show0 ":LOCAL case") + (let* ((var (sb!xc:gensym "VAR")) + (initval (if initial-value (sb!xc:gensym "INITVAL"))) + (info (make-local-alien-info :type alien-type)) + (inner-body + `((note-local-alien-type ',info ,var) + (symbol-macrolet ((,symbol (local-alien ',info ,var))) + ,@(when initial-value + `((setq ,symbol ,initval))) + ,@body))) + (body-forms + (if initial-value + `((let ((,initval ,initial-value)) + ,@inner-body)) + inner-body))) + (/show var initval info) + #!+(or x86 x86-64) + `((let ((,var (make-local-alien ',info))) + ,@body-forms)) + ;; FIXME: This version is less efficient then it needs to be, since + ;; it could just save and restore the number-stack pointer once, + ;; instead of doing multiple decrements if there are multiple bindings. + #!-(or x86 x86-64) + `((let (,var) + (unwind-protect + (progn + (setf ,var (make-local-alien ',info)) + (let ((,var ,var)) + ,@body-forms)) + (dispose-local-alien ',info ,var)))))))))))) + (/show "revised" body) (verify-local-auxiliaries-okay) + (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& - ,(append *new-auxiliary-types* - (auxiliary-type-definitions env)))) + ,(append *new-auxiliary-types* + (auxiliary-type-definitions env)))) + #!+(or x86 x86-64) + (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*)) + ,@body) + #!-(or x86 x86-64) ,@body))) ;;;; runtime C values that don't correspond directly to Lisp types @@ -164,9 +209,10 @@ (def!method print-object ((value alien-value) stream) (print-unreadable-object (value stream) (format stream - "~S :SAP #X~8,'0X" - 'alien-value - (sap-int (alien-value-sap value))))) + "~S ~S #X~8,'0X ~S ~S" + 'alien-value + :sap (sap-int (alien-value-sap value)) + :type (unparse-alien-type (alien-value-type value))))) #!-sb-fluid (declaim (inline null-alien)) (defun null-alien (x) @@ -180,12 +226,12 @@ evaluated.) TYPE must be pointer-like." (let ((alien-type (parse-alien-type type env))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) - `(%sap-alien ,sap ',alien-type) - (error "cannot make aliens of type ~S out of SAPs" type)))) + `(%sap-alien ,sap ',alien-type) + (error "cannot make an alien of type ~S out of a SAP" type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) - (type alien-type type)) + (type alien-type type)) (make-alien-value :sap sap :type type)) (defun alien-sap (alien) @@ -198,73 +244,153 @@ (defmacro make-alien (type &optional size &environment env) #!+sb-doc - "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE - is supplied, how it is interpreted depends on TYPE. If TYPE is an array - type, SIZE is used as the first dimension for the allocated array. If TYPE - is not an array, then SIZE is the number of elements to allocate. The - memory is allocated using ``malloc'', so it can be passed to foreign - functions which use ``free''." + "Allocate an alien of type TYPE in foreign heap, and return an alien +pointer to it. The allocated memory is not initialized, and may +contain garbage. The memory is allocated using malloc(3), so it can be +passed to foreign functions which use free(3), or released using +FREE-ALIEN. + +For alien stack allocation, see macro WITH-ALIEN. + +The TYPE argument is not evaluated. If SIZE is supplied, how it is +interpreted depends on TYPE: + + * When TYPE is a foreign array type, an array of that type is + allocated, and a pointer to it is returned. Note that you + must use DEREF to first access the arrey through the pointer. + + If supplied, SIZE is used as the first dimension for the array. + + * When TYPE is any other foreign type, then an object for that + type is allocated, and a pointer to it is returned. So + (make-alien int) returns a (* int). + + If SIZE is specified, then a block of that many objects is + allocated, with the result pointing to the first one. + +Examples: + + (defvar *foo* (make-alien (array char 10))) + (type-of *foo*) ; => (alien (* (array (signed 8) 10))) + (setf (deref (deref foo) 0) 10) ; => 10 + + (make-alien char 12) ; => (alien (* (signed 8))) +" (let ((alien-type (if (alien-type-p type) - type - (parse-alien-type type env)))) + type + (parse-alien-type type env)))) (multiple-value-bind (size-expr element-type) - (if (alien-array-type-p alien-type) - (let ((dims (alien-array-type-dimensions alien-type))) - (cond - (size - (unless dims - (error - "cannot override the size of zero-dimensional arrays")) - (when (constantp size) - (setf alien-type (copy-alien-array-type alien-type)) - (setf (alien-array-type-dimensions alien-type) - (cons (eval size) (cdr dims))))) - (dims - (setf size (car dims))) - (t - (setf size 1))) - (values `(* ,size ,@(cdr dims)) - (alien-array-type-element-type alien-type))) - (values (or size 1) alien-type)) + (if (alien-array-type-p alien-type) + (let ((dims (alien-array-type-dimensions alien-type))) + (cond + (size + (unless dims + (error + "cannot override the size of zero-dimensional arrays")) + (when (constantp size) + (setf alien-type (copy-alien-array-type alien-type)) + (setf (alien-array-type-dimensions alien-type) + (cons (constant-form-value size) (cdr dims))))) + (dims + (setf size (car dims))) + (t + (setf size 1))) + (values `(* ,size ,@(cdr dims)) + (alien-array-type-element-type alien-type))) + (values (or size 1) alien-type)) (let ((bits (alien-type-bits element-type)) - (alignment (alien-type-alignment element-type))) - (unless bits - (error "The size of ~S is unknown." - (unparse-alien-type element-type))) - (unless alignment - (error "The alignment of ~S is unknown." - (unparse-alien-type element-type))) - `(%sap-alien (%make-alien (* ,(align-offset bits alignment) - ,size-expr)) - ',(make-alien-pointer-type :to alien-type)))))) + (alignment (alien-type-alignment element-type))) + (unless bits + (error "The size of ~S is unknown." + (unparse-alien-type element-type))) + (unless alignment + (error "The alignment of ~S is unknown." + (unparse-alien-type element-type))) + ;; This is the one place where the %SAP-ALIEN note is quite + ;; undesirable, in most uses of MAKE-ALIEN the %SAP-ALIEN + ;; cannot be optimized away. + `(locally (declare (muffle-conditions compiler-note)) + ;; FIXME: Do we really need the ASH/+7 here after ALIGN-OFFSET? + (%sap-alien (%make-alien (* ,(ash (+ 7 (align-offset bits alignment)) -3) + (the index ,size-expr))) + ',(make-alien-pointer-type :to alien-type))))))) + +(defun malloc-error (bytes errno) + (error 'simple-storage-condition + :format-control "~A: malloc() of ~S bytes failed." + :format-arguments (list (strerror errno) bytes))) ;;; Allocate a block of memory at least BITS bits long and return a ;;; system area pointer to it. #!-sb-fluid (declaim (inline %make-alien)) -(defun %make-alien (bits) - (declare (type index bits)) - (alien-funcall (extern-alien "malloc" - (function system-area-pointer unsigned)) - (ash (the index (+ bits 7)) -3))) +(defun %make-alien (bytes) + (declare (type index bytes) + (optimize (sb!c:alien-funcall-saves-fp-and-pc 0))) + (let ((sap (alien-funcall (extern-alien "malloc" + (function system-area-pointer size-t)) + bytes))) + (if (and (not (eql 0 bytes)) (eql 0 (sap-int sap))) + (malloc-error bytes (get-errno)) + sap))) #!-sb-fluid (declaim (inline free-alien)) (defun free-alien (alien) #!+sb-doc - "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated - by MAKE-ALIEN or malloc(3)." + "Dispose of the storage pointed to by ALIEN. The ALIEN must have been +allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) - (alien-sap alien)) + (alien-sap alien)) nil) + +(declaim (type (sfunction * system-area-pointer) %make-alien-string)) +(defun %make-alien-string (string &key (start 0) end + (external-format :default) + (null-terminate t)) + ;; FIXME: This is slow. We want a function to get the length of the + ;; encoded string so we can allocate the foreign memory first and + ;; encode directly there. + (let* ((octets (string-to-octets string + :start start :end end + :external-format external-format + :null-terminate null-terminate)) + (count (length octets)) + (buf (%make-alien count))) + (sb!kernel:copy-ub8-to-system-area octets 0 buf 0 count) + buf)) + +(defun make-alien-string (string &rest rest + &key (start 0) end + (external-format :default) + (null-terminate t)) + "Copy part of STRING delimited by START and END into freshly +allocated foreign memory, freeable using free(3) or FREE-ALIEN. +Returns the allocated string as a (* CHAR) alien, and the number of +bytes allocated as secondary value. + +The string is encoded using EXTERNAL-FORMAT. If NULL-TERMINATE is +true (the default), the alien string is terminated by an additional +null byte. +" + (declare (ignore start end external-format null-terminate)) + (multiple-value-bind (sap bytes) + (apply #'%make-alien-string string rest) + (values (%sap-alien sap (parse-alien-type '(* char) nil)) + bytes))) + +(define-compiler-macro make-alien-string (&rest args) + `(multiple-value-bind (sap bytes) (%make-alien-string ,@args) + (values (%sap-alien sap ',(parse-alien-type '(* char) nil)) + bytes))) ;;;; the SLOT operator ;;; Find the field named SLOT, or die trying. (defun slot-or-lose (type slot) (declare (type alien-record-type type) - (type symbol slot)) + (type symbol slot)) (or (find slot (alien-record-type-fields type) - :key #'alien-record-field-name) - (error "There is no slot named ~S in ~S" slot type))) + :key #'alien-record-field-name) + (error "There is no slot named ~S in ~S." slot type))) ;;; Extract the value from the named slot from the record ALIEN. If ;;; ALIEN is actually a pointer, then DEREF it first. @@ -272,51 +398,51 @@ #!+sb-doc "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF." (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) + (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field))))))) ;;; Deposit the value in the specified slot of the record ALIEN. If ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses ;;; this when it can't figure out anything better. (defun %set-slot (alien slot value) (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) + (setf (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field)) + value)))))) ;;; Compute the address of the specified slot and return a pointer to it. (defun %slot-addr (alien slot) (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%slot-addr (deref alien) slot)) (alien-record-type (let* ((field (slot-or-lose type slot)) - (offset (alien-record-field-offset field)) - (field-type (alien-record-field-type field))) - (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:byte-bits)) - (make-alien-pointer-type :to field-type))))))) + (offset (alien-record-field-offset field)) + (field-type (alien-record-field-type field))) + (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits)) + (make-alien-pointer-type :to field-type))))))) ;;;; the DEREF operator @@ -325,40 +451,40 @@ ;;; of the referred-to alien. (defun deref-guts (alien indices) (declare (type alien-value alien) - (type list indices) - (values alien-type integer)) + (type list indices) + (values alien-type integer)) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (when (cdr indices) - (error "too many indices when derefing ~S: ~D" - type - (length indices))) + (error "too many indices when DEREF'ing ~S: ~W" + type + (length indices))) (let ((element-type (alien-pointer-type-to type))) - (values element-type - (if indices - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (car indices)) - 0)))) + (values element-type + (if indices + (* (align-offset (alien-type-bits element-type) + (alien-type-alignment element-type)) + (car indices)) + 0)))) (alien-array-type (unless (= (length indices) (length (alien-array-type-dimensions type))) - (error "incorrect number of indices when derefing ~S: ~D" - type (length indices))) + (error "incorrect number of indices when DEREF'ing ~S: ~W" + type (length indices))) (labels ((frob (dims indices offset) - (if (null dims) - offset - (frob (cdr dims) (cdr indices) - (+ (if (zerop offset) - 0 - (* offset (car dims))) - (car indices)))))) - (let ((element-type (alien-array-type-element-type type))) - (values element-type - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (frob (alien-array-type-dimensions type) - indices 0))))))))) + (if (null dims) + offset + (frob (cdr dims) (cdr indices) + (+ (if (zerop offset) + 0 + (* offset (car dims))) + (car indices)))))) + (let ((element-type (alien-array-type-element-type type))) + (values element-type + (* (align-offset (alien-type-bits element-type) + (alien-type-alignment element-type)) + (frob (alien-array-type-dimensions type) + indices 0))))))))) ;;; Dereference the alien and return the results. (defun deref (alien &rest indices) @@ -367,65 +493,66 @@ as the indices of the array element to access. If a pointer, one index can optionally be specified, giving the equivalent of C pointer arithmetic." (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (extract-alien-value (alien-value-sap alien) - offset - target-type))) + (%alien-value (alien-value-sap alien) + offset + target-type))) (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) + (setf (%alien-value (alien-value-sap alien) + offset + target-type) + value))) (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:byte-bits)) - (make-alien-pointer-type :to target-type)))) + (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits)) + (make-alien-pointer-type :to target-type)))) ;;;; accessing heap alien variables (defun %heap-alien (info) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) + (optimize (inhibit-warnings 3))) + (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) + (optimize (inhibit-warnings 3))) + (setf (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info)) + value)) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) - (%sap-alien (eval (heap-alien-info-sap-form info)) - (make-alien-pointer-type :to (heap-alien-info-type info)))) + (optimize (inhibit-warnings 3))) + (%sap-alien (heap-alien-info-sap info) + (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; accessing local aliens (defun make-local-alien (info) (let* ((alien (eval `(make-alien ,(local-alien-info-type info)))) - (alien-sap (alien-sap alien))) + (alien-sap (alien-sap alien))) (finalize alien - #'(lambda () - (alien-funcall - (extern-alien "free" (function (values) system-area-pointer)) - alien-sap))) + (lambda () + (alien-funcall + (extern-alien "free" (function (values) system-area-pointer)) + alien-sap)) + :dont-save t) alien)) (defun note-local-alien-type (info alien) @@ -442,21 +569,23 @@ (define-setf-expander local-alien (&whole whole info alien) (let ((value (gensym)) - (info (if (and (consp info) - (eq (car info) 'quote)) - (second info) - (error "Something is wrong; local-alien-info not found: ~S" - whole)))) + (info-var (gensym)) + (alloc-tmp (gensym)) + (info (if (and (consp info) + (eq (car info) 'quote)) + (second info) + (error "Something is wrong; local-alien-info not found: ~S" + whole)))) (values nil - nil - (list value) - (if sb!c:*converting-for-interpreter* - `(%set-local-alien ',info ,alien ,value) - `(if (%local-alien-forced-to-memory-p ',info) - (%set-local-alien ',info ,alien ,value) - (setf ,alien - (deport ,value ',(local-alien-info-type info))))) - whole))) + nil + (list value) + `(if (%local-alien-forced-to-memory-p ',info) + (%set-local-alien ',info ,alien ,value) + (let* ((,info-var ',(local-alien-info-type info)) + (,alloc-tmp (deport-alloc ,value ,info-var))) + (maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info)) + (setf ,alien (deport ,alloc-tmp ,info-var))))) + whole))) (defun %local-alien-forced-to-memory-p (info) (local-alien-info-force-to-memory-p info)) @@ -482,18 +611,18 @@ (defun %cast (alien target-type) (declare (type alien-value alien) - (type alien-type target-type) - (optimize (safety 2)) - (optimize (inhibit-warnings 3))) + (type alien-type target-type) + (optimize (safety 2)) + (optimize (inhibit-warnings 3))) (if (or (alien-pointer-type-p target-type) - (alien-array-type-p target-type) - (alien-function-type-p target-type)) + (alien-array-type-p target-type) + (alien-fun-type-p target-type)) (let ((alien-type (alien-value-type alien))) - (if (or (alien-pointer-type-p alien-type) - (alien-array-type-p alien-type) - (alien-function-type-p alien-type)) - (naturalize (alien-value-sap alien) target-type) - (error "~S cannot be casted." alien))) + (if (or (alien-pointer-type-p alien-type) + (alien-array-type-p alien-type) + (alien-fun-type-p alien-type)) + (naturalize (alien-value-sap alien) target-type) + (error "~S cannot be casted." alien))) (error "cannot cast to alien type ~S" (unparse-alien-type target-type)))) ;;;; the ALIEN-SIZE macro @@ -503,43 +632,53 @@ "Return the size of the alien type TYPE. UNITS specifies the units to use and can be either :BITS, :BYTES, or :WORDS." (let* ((alien-type (parse-alien-type type env)) - (bits (alien-type-bits alien-type))) + (bits (alien-type-bits alien-type))) (if bits - (values (ceiling bits - (ecase units - (:bits 1) - (:bytes sb!vm:byte-bits) - (:words sb!vm:word-bits)))) - (error "unknown size for alien type ~S" - (unparse-alien-type alien-type))))) + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes sb!vm:n-byte-bits) + (:words sb!vm:n-word-bits)))) + (error "unknown size for alien type ~S" + (unparse-alien-type alien-type))))) ;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE +(defun coerce-to-interpreted-function (lambda-form) + (let (#!+sb-eval + (*evaluator-mode* :interpret)) + (coerce lambda-form 'function))) + (defun naturalize (alien type) (declare (type alien-type type)) - (funcall (coerce (compute-naturalize-lambda type) 'function) - alien type)) + (funcall (coerce-to-interpreted-function (compute-naturalize-lambda type)) + alien type)) (defun deport (value type) (declare (type alien-type type)) - (funcall (coerce (compute-deport-lambda type) 'function) - value type)) + (funcall (coerce-to-interpreted-function (compute-deport-lambda type)) + value type)) + +(defun deport-alloc (value type) + (declare (type alien-type type)) + (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type)) + value type)) -(defun extract-alien-value (sap offset type) +(defun %alien-value (sap offset type) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) - (funcall (coerce (compute-extract-lambda type) 'function) - sap offset type)) + (type unsigned-byte offset) + (type alien-type type)) + (funcall (coerce-to-interpreted-function (compute-extract-lambda type)) + sap offset type)) -(defun deposit-alien-value (sap offset type value) +(defun (setf %alien-value) (value sap offset type) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) - (funcall (coerce (compute-deposit-lambda type) 'function) - sap offset type value)) + (type unsigned-byte offset) + (type alien-type type)) + (funcall (coerce-to-interpreted-function (compute-deposit-lambda type)) + value sap offset type)) -;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE +;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE (defun alien-funcall (alien &rest args) #!+sb-doc @@ -550,112 +689,412 @@ (typecase type (alien-pointer-type (apply #'alien-funcall (deref alien) args)) - (alien-function-type - (unless (= (length (alien-function-type-arg-types type)) - (length args)) - (error "wrong number of arguments for ~S~%expected ~D, got ~D" - type - (length (alien-function-type-arg-types type)) - (length args))) - (let ((stub (alien-function-type-stub type))) - (unless stub - (setf stub - (let ((fun (gensym)) - (parms (make-gensym-list (length args)))) - (compile nil - `(lambda (,fun ,@parms) - (declare (type (alien ,type) ,fun)) - (alien-funcall ,fun ,@parms))))) - (setf (alien-function-type-stub type) stub)) - (apply stub alien args))) + (alien-fun-type + (unless (= (length (alien-fun-type-arg-types type)) + (length args)) + (error "wrong number of arguments for ~S~%expected ~W, got ~W" + type + (length (alien-fun-type-arg-types type)) + (length args))) + (let ((stub (alien-fun-type-stub type))) + (unless stub + (setf stub + (let ((fun (sb!xc:gensym "FUN")) + (parms (make-gensym-list (length args)))) + (compile nil + `(lambda (,fun ,@parms) + (declare (optimize (sb!c::insert-step-conditions 0))) + (declare (type (alien ,type) ,fun)) + (alien-funcall ,fun ,@parms))))) + (setf (alien-fun-type-stub type) stub)) + (apply stub alien args))) (t (error "~S is not an alien function." alien))))) -(defmacro def-alien-routine (name result-type &rest args &environment env) +(defmacro define-alien-routine (name result-type + &rest args + &environment lexenv) #!+sb-doc - "Def-C-Routine Name Result-Type - {(Arg-Name Arg-Type [Style])}* + "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* - Define a foreign interface function for the routine with the specified Name, - which may be either a string, symbol or list of the form (string symbol). - Return-Type is the Alien type for the function return value. VOID may be + Define a foreign interface function for the routine with the specified NAME. + Also automatically DECLAIM the FTYPE of the defined function. + + NAME may be either a string, a symbol, or a list of the form (string symbol). + + RETURN-TYPE is the alien type for the function return value. VOID may be used to specify a function with no result. - The remaining forms specifiy individual arguments that are passed to the - routine. Arg-Name is a symbol that names the argument, primarily for - documentation. Arg-Type is the C-Type of the argument. Style specifies the - say that the argument is passed. + The remaining forms specify individual arguments that are passed to the + routine. ARG-NAME is a symbol that names the argument, primarily for + documentation. ARG-TYPE is the C type of the argument. STYLE specifies the + way that the argument is passed. :IN - An :In argument is simply passed by value. The value to be passed is - obtained from argument(s) to the interface function. No values are - returned for :In arguments. This is the default mode. + An :IN argument is simply passed by value. The value to be passed is + obtained from argument(s) to the interface function. No values are + returned for :In arguments. This is the default mode. :OUT - The specified argument type must be a pointer to a fixed sized object. - A pointer to a preallocated object is passed to the routine, and the - the object is accessed on return, with the value being returned from - the interface function. :OUT and :IN-OUT cannot be used with pointers - to arrays, records or functions. + The specified argument type must be a pointer to a fixed sized object. + A pointer to a preallocated object is passed to the routine, and the + the object is accessed on return, with the value being returned from + the interface function. :OUT and :IN-OUT cannot be used with pointers + to arrays, records or functions. :COPY - Similar to :IN, except that the argument values are stored in on - the stack, and a pointer to the object is passed instead of - the values themselves. + This is similar to :IN, except that the argument values are stored + on the stack, and a pointer to the object is passed instead of + the value itself. :IN-OUT - A combination of :OUT and :COPY. A pointer to the argument is passed, - with the object being initialized from the supplied argument and - the return value being determined by accessing the object on return." + This is a combination of :OUT and :COPY. A pointer to the argument is + passed, with the object being initialized from the supplied argument + and the return value being determined by accessing the object on + return." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) - (collect ((docs) (lisp-args) (arg-types) (alien-vars) - (alien-args) (results)) + (collect ((docs) (lisp-args) (lisp-arg-types) + (lisp-result-types + (cond ((eql result-type 'void) + ;; What values does a function return, if it + ;; returns no values? Exactly one - NIL. -- APD, + ;; 2003-03-02 + (list 'null)) + (t + ;; FIXME: Check for VALUES. + (list `(alien ,result-type))))) + (arg-types) (alien-vars) + (alien-args) (results)) (dolist (arg args) - (if (stringp arg) - (docs arg) - (destructuring-bind (name type &optional (style :in)) arg - (unless (member style '(:in :copy :out :in-out)) - (error "bogus argument style ~S in ~S" style arg)) - (unless (eq style :out) - (lisp-args name)) - (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type env) - 'alien-pointer-type)) - (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" - type)) - (cond ((eq style :in) - (arg-types type) - (alien-args name)) - (t - (arg-types `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) - (when (or (eq style :out) (eq style :in-out)) - (results name))))) - `(defun ,lisp-name ,(lisp-args) - ,@(docs) - (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) - :extern ,alien-name) - ,@(alien-vars)) - ,(if (alien-values-type-p result-type) - (let ((temps (make-gensym-list - (length - (alien-values-type-values result-type))))) - `(multiple-value-bind ,temps - (alien-funcall ,lisp-name ,@(alien-args)) - (values ,@temps ,@(results)))) - `(values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results)))))))) + (if (stringp arg) + (docs arg) + (destructuring-bind (name type &optional (style :in)) arg + (unless (member style '(:in :copy :out :in-out)) + (error "bogus argument style ~S in ~S" style arg)) + (when (and (member style '(:out :in-out)) + (typep (parse-alien-type type lexenv) + 'alien-pointer-type)) + (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" + type)) + (let (arg-type) + (cond ((eq style :in) + (setq arg-type type) + (alien-args name)) + (t + (setq arg-type `(* ,type)) + (if (eq style :out) + (alien-vars `(,name ,type)) + (alien-vars `(,name ,type ,name))) + (alien-args `(addr ,name)))) + (arg-types arg-type) + (unless (eq style :out) + (lisp-args name) + (lisp-arg-types t + ;; FIXME: It should be something + ;; like `(ALIEN ,ARG-TYPE), except + ;; for we also accept SAPs where + ;; pointers are required. + ))) + (when (or (eq style :out) (eq style :in-out)) + (results name) + (lisp-result-types `(alien ,type)))))) + `(progn + ;; The theory behind this automatic DECLAIM is that (1) if + ;; you're calling C, static typing is what you're doing + ;; anyway, and (2) such a declamation can be (especially for + ;; alien values) both messy to do by hand and very important + ;; for performance of later code which uses the return value. + (declaim (ftype (function ,(lisp-arg-types) + (values ,@(lisp-result-types) &optional)) + ,lisp-name)) + (defun ,lisp-name ,(lisp-args) + ,@(docs) + (with-alien + ((,lisp-name (function ,result-type ,@(arg-types)) + :extern ,alien-name) + ,@(alien-vars)) + ,@(if (eq 'void result-type) + `((alien-funcall ,lisp-name ,@(alien-args)) + (values nil ,@(results))) + `((values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results)))))))))) (defun alien-typep (object type) #!+sb-doc "Return T iff OBJECT is an alien of type TYPE." (let ((lisp-rep-type (compute-lisp-rep-type type))) (if lisp-rep-type - (typep object lisp-rep-type) - (and (alien-value-p object) - (alien-subtype-p (alien-value-type object) type))))) + (typep object lisp-rep-type) + (and (alien-value-p object) + (alien-subtype-p (alien-value-type object) type))))) + +(defun alien-value-typep (object type) + (when (alien-value-p object) + (alien-subtype-p (alien-value-type object) type))) + +;;;; ALIEN CALLBACKS +;;;; +;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual. + +(defvar *alien-callback-info* nil + "Maps SAPs to corresponding CALLBACK-INFO structures: contains all the +information we need to manipulate callbacks after their creation. Used for +changing the lisp-side function they point to, invalidation, etc.") + +(defstruct callback-info + specifier + function ; NULL if invalid + wrapper + index) + +(defun callback-info-key (info) + (cons (callback-info-specifier info) (callback-info-function info))) + +(defun alien-callback-info (alien) + (cdr (assoc (alien-sap alien) *alien-callback-info* :test #'sap=))) + +(defvar *alien-callbacks* (make-hash-table :test #'equal) + "Cache of existing callback SAPs, indexed with (SPECIFER . FUNCTION). Used for +memoization: we don't create new callbacks if one pointing to the correct +function with the same specifier already exists.") + +(defvar *alien-callback-wrappers* (make-hash-table :test #'equal) + "Cache of existing lisp weappers, indexed with SPECIFER. Used for memoization: +we don't create new wrappers if one for the same specifier already exists.") + +(defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t) + "Lisp trampoline store: assembler wrappers contain indexes to this, and +ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper + &optional call-type) + (declare #!-x86 (ignore call-type)) + (let ((key (list specifier function))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper + (alien-callback-assembler-wrapper + index result-type argument-types + #!+x86 + (if (eq call-type :stdcall) + (ceiling + (apply #'+ + (mapcar 'alien-type-word-aligned-bits + argument-types)) + 8) + 0)))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + ;; Assembler-wrapper is static, so sap-taking is safe. + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(defun alien-callback-lisp-trampoline (wrapper function) + (declare (function wrapper) (optimize speed)) + (lambda (args-pointer result-pointer) + (funcall wrapper args-pointer result-pointer function))) + +(defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env) + (let* ((arguments (make-gensym-list (length argument-types))) + (argument-names arguments) + (argument-specs (cddr specifier))) + `(lambda (args-pointer result-pointer function) + ;; FIXME: the saps are not gc safe + (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)))) + (declare (ignorable args-sap res-sap)) + (with-alien + ,(loop + with offset = 0 + for spec in argument-specs + collect `(,(pop argument-names) ,spec + :local ,(alien-callback-accessor-form + spec 'args-sap offset)) + do (incf offset (alien-callback-argument-bytes spec env))) + ,(flet ((store (spec real-type) + (if spec + `(setf (deref (sap-alien res-sap (* ,spec))) + ,(if real-type + `(the ,real-type + (funcall function ,@arguments)) + `(funcall function ,@arguments))) + `(funcall function ,@arguments)))) + (cond ((alien-void-type-p result-type) + (store nil nil)) + ((alien-integer-type-p result-type) + ;; Integer types should be padded out to a full + ;; register width, to comply with most ABI calling + ;; conventions, but should be typechecked on the + ;; declared type width, hence the following: + (if (alien-integer-type-signed result-type) + (store `(signed + ,(alien-type-word-aligned-bits result-type)) + `(signed-byte ,(alien-type-bits result-type))) + (store + `(unsigned + ,(alien-type-word-aligned-bits result-type)) + `(unsigned-byte ,(alien-type-bits result-type))))) + (t + (store (unparse-alien-type result-type) nil)))))) + (values)))) + +(defun invalid-alien-callback (&rest arguments) + (declare (ignore arguments)) + (error "Invalid alien callback called.")) + + +(defun parse-callback-specification (result-type lambda-list) + (values + `(function ,result-type ,@(mapcar #'second lambda-list)) + (mapcar #'first lambda-list))) + + +(defun parse-alien-ftype (specifier env) + (destructuring-bind (function result-type &rest argument-types) + specifier + (aver (eq 'function function)) + (multiple-value-bind (bare-result-type calling-convention) + (typecase result-type + ((cons calling-convention *) + (values (second result-type) (first result-type))) + (t result-type)) + (values (let ((*values-type-okay* t)) + (parse-alien-type bare-result-type env)) + (mapcar (lambda (spec) + (parse-alien-type spec env)) + argument-types) + calling-convention)))) + +(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) + (alien-system-area-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)) + +;;; To ensure that callback wrapper functions continue working even +;;; if #'ENTER-ALIEN-CALLBACK moves in memory, access to it is indirected +;;; through the *ENTER-ALIEN-CALLBACK* static symbol. -- JES, 2006-01-01 +(defvar *enter-alien-callback* #'enter-alien-callback) + +;;;; interface (not public, yet) for alien callbacks + +(defmacro alien-callback (specifier function &environment env) + "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to +an alien function as a pointer to the FUNCTION. If a callback for the given +SPECIFIER and FUNCTION already exists, it is returned instead of consing a new +one." + ;; Pull out as much work as is convenient to macro-expansion time, specifically + ;; everything that can be done given just the SPECIFIER and ENV. + (multiple-value-bind (result-type argument-types call-type) + (parse-alien-ftype specifier env) + `(%sap-alien + (%alien-callback-sap ',specifier ',result-type ',argument-types + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + (compile nil + ',(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env)))) + ,call-type) + ',(parse-alien-type specifier env)))) + +(defun alien-callback-p (alien) + "Returns true if the alien is associated with a lisp-side callback, +and a secondary return value of true if the callback is still valid." + (let ((info (alien-callback-info alien))) + (when info + (values t (and (callback-info-function info) t))))) + +(defun alien-callback-function (alien) + "Returns the lisp function designator associated with the callback." + (let ((info (alien-callback-info alien))) + (when info + (callback-info-function info)))) + +(defun (setf alien-callback-function) (function alien) + "Changes the lisp function designated by the callback." + (let ((info (alien-callback-info alien))) + (unless info + (error "Not an alien callback: ~S" alien)) + ;; sap cache + (let ((key (callback-info-key info))) + (remhash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) (alien-sap alien))) + ;; trampoline + (setf (aref *alien-callback-trampolines* (callback-info-index info)) + (alien-callback-lisp-trampoline (callback-info-wrapper info) function)) + ;; metadata + (setf (callback-info-function info) function) + function)) + +(defun invalidate-alien-callback (alien) + "Invalidates the callback designated by the alien, if any, allowing the +associated lisp function to be GC'd, and causing further calls to the same +callback signal an error." + (let ((info (alien-callback-info alien))) + (when (and info (callback-info-function info)) + ;; sap cache + (remhash (callback-info-key info) *alien-callbacks*) + ;; trampoline + (setf (aref *alien-callback-trampolines* (callback-info-index info)) + #'invalid-alien-callback) + ;; metadata + (setf (callback-info-function info) nil) + t))) + +;;; FIXME: This call assembles a new callback for every closure, +;;; which sucks hugely. ...not that I can think of an obvious +;;; solution. Possibly maybe we could write a generalized closure +;;; callback analogous to closure_tramp, and share the actual wrapper? +;;; +;;; For lambdas that result in simple-funs we get the callback from +;;; the cache on subsequent calls. +(defmacro alien-lambda (result-type typed-lambda-list &body forms) + (multiple-value-bind (specifier lambda-list) + (parse-callback-specification result-type typed-lambda-list) + `(alien-callback ,specifier (lambda ,lambda-list ,@forms)))) + +;;; FIXME: Should subsequent (SETF FDEFINITION) affect the callback or not? +;;; What about subsequent DEFINE-ALIEN-CALLBACKs? My guess is that changing +;;; the FDEFINITION should invalidate the callback, and redefining the +;;; callback should change existing callbacks to point to the new defintion. +(defmacro define-alien-callback (name result-type typed-lambda-list &body forms) + "Defines #'NAME as a function with the given body and lambda-list, and NAME as +the alien callback for that function with the given alien type." + (declare (symbol name)) + (multiple-value-bind (specifier lambda-list) + (parse-callback-specification result-type typed-lambda-list) + `(progn + (defun ,name ,lambda-list ,@forms) + (defparameter ,name (alien-callback ,specifier #',name)))))