;;; 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))))))
+ (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)))
',alien-name
',alien-type))))))
-(defmacro def-alien-variable (&rest rest)
- (deprecation-warning 'def-alien-variable 'define-alien-variable)
- `(define-alien-variable ,@rest))
-
;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
(eval-when (:compile-toplevel :load-toplevel :execute)
(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-sap ',alien-name t)))))
+ :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."
+ "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))))
- `(%heap-alien ',(make-heap-alien-info
- :type alien-type
- :sap-form `(foreign-symbol-sap ',alien-name ,datap)))))
+ `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type)))
(defmacro with-alien (bindings &body body &environment env)
#!+sb-doc
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))
+ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
binding
(/show symbol type opt1 opt2)
(let* ((alien-type (parse-alien-type type env))
`((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)))))
+ ((,symbol (sap-alien ,sap ,type)))
+ ,@(when initial-value
+ `((setq ,symbol ,initial-value)))
+ ,@body)))))
(:extern
(/show0 ":EXTERN case")
- (let ((info (make-heap-alien-info
- :type alien-type
- :sap-form `(foreign-symbol-sap ',initial-value
- ,datap))))
- `((symbol-macrolet
- ((,symbol (%heap-alien ',info)))
- ,@body))))
+ `((symbol-macrolet
+ ((,symbol
+ (%alien-value
+ (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type)))
+ ,@body)))
(:local
(/show0 ":LOCAL case")
- (let ((var (gensym))
- (initval (if initial-value (gensym)))
- (info (make-local-alien-info :type alien-type)))
+ (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)
- `((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))))))))))))
+ #!+(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))))
+ #!+(or x86 x86-64)
+ (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
+ ,@body)
+ #!-(or x86 x86-64)
,@body)))
\f
;;;; runtime C values that don't correspond directly to Lisp types
(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 array 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))))
(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)))
+ (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))
(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))))))
+ ;; 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))
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)))
\f
;;;; the SLOT operator
(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
(%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)
;;; Dereference the alien and return the results.
(defun deref (alien &rest indices)
#!+sb-doc
- "De-reference an Alien pointer or array. If an array, the indices are used
+ "Dereference an Alien pointer or array. If an array, the indices are used
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)))
(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)))
(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)
(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)))
+ (%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))
+ (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))
+ (%sap-alien (heap-alien-info-sap info)
(make-alien-pointer-type :to (heap-alien-info-type info))))
\f
;;;; accessing local aliens
(lambda ()
(alien-funcall
(extern-alien "free" (function (values) system-area-pointer))
- alien-sap)))
+ alien-sap))
+ :dont-save t)
alien))
(defun note-local-alien-type (info alien)
(define-setf-expander local-alien (&whole whole info alien)
(let ((value (gensym))
+ (info-var (gensym))
+ (alloc-tmp (gensym))
(info (if (and (consp info)
(eq (car info) 'quote))
(second info)
(list value)
`(if (%local-alien-forced-to-memory-p ',info)
(%set-local-alien ',info ,alien ,value)
- (setf ,alien
- (deport ,value ',(local-alien-info-type info))))
+ (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)
\f
;;;; 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)
+ (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)
+ (funcall (coerce-to-interpreted-function (compute-deport-lambda type))
value type))
-(defun extract-alien-value (sap offset type)
+(defun deport-alloc (value type)
+ (declare (type alien-type type))
+ (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type))
+ value 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)
+ (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))
+ (funcall (coerce-to-interpreted-function (compute-deposit-lambda type))
+ value sap offset type))
\f
;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
(defun alien-funcall (alien &rest args)
#!+sb-doc
"Call the foreign function ALIEN with the specified arguments. ALIEN's
- type specifies the argument and result types."
+type specifies the argument and result types."
(declare (type alien-value alien))
(let ((type (alien-value-type alien)))
(typecase type
(let ((stub (alien-fun-type-stub type)))
(unless stub
(setf stub
- (let ((fun (gensym))
+ (let ((fun (sb!xc:gensym "FUN"))
(parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
#!+sb-doc
"DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
- 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 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.
-
- :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.
-
- :COPY
- 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
- 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."
+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 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.
+
+: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.
+
+:COPY
+ 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
+ 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) (lisp-arg-types)
((,lisp-name (function ,result-type ,@(arg-types))
:extern ,alien-name)
,@(alien-vars))
- #-nil
- (values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results))
- #+nil
- (if (alien-values-type-p result-type)
- ;; FIXME: RESULT-TYPE is a type specifier, so it
- ;; cannot be of type ALIEN-VALUES-TYPE. Also note,
- ;; that if RESULT-TYPE is VOID, then this code
- ;; disagrees with the computation of the return type
- ;; and with all usages of this macro. -- APD,
- ;; 2002-03-02
- (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)))))))))
-
-(defmacro def-alien-routine (&rest rest)
- (deprecation-warning 'def-alien-routine 'define-alien-routine)
- `(define-alien-routine ,@rest))
+ ,@(if (eq 'void result-type)
+ `((alien-funcall ,lisp-name ,@(alien-args))
+ (values nil ,@(results)))
+ `((values (alien-funcall ,lisp-name ,@(alien-args))
+ ,@(results))))))))))
\f
(defun alien-typep (object type)
#!+sb-doc
(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.
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:
+ "Cache of existing lisp wrappers, 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.")
+ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.")
-(defun %alien-callback-sap (specifier result-type argument-types function wrapper)
- (let ((key (cons specifier function)))
+(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*))
;; 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)))
+ (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
:local ,(alien-callback-accessor-form
spec 'args-sap offset))
do (incf offset (alien-callback-argument-bytes spec env)))
- ,(flet ((store (spec)
+ ,(flet ((store (spec real-type)
(if spec
`(setf (deref (sap-alien res-sap (* ,spec)))
- (funcall function ,@arguments))
+ ,(if real-type
+ `(the ,real-type
+ (funcall function ,@arguments))
+ `(funcall function ,@arguments)))
`(funcall function ,@arguments))))
(cond ((alien-void-type-p result-type)
- (store nil))
+ (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)))
+ ,(alien-type-word-aligned-bits result-type))
+ `(signed-byte ,(alien-type-bits result-type)))
(store
`(unsigned
- ,(alien-type-word-aligned-bits result-type)))))
+ ,(alien-type-word-aligned-bits result-type))
+ `(unsigned-byte ,(alien-type-bits result-type)))))
(t
- (store (unparse-alien-type result-type)))))))
+ (store (unparse-alien-type result-type) nil))))))
(values))))
(defun invalid-alien-callback (&rest arguments)
(destructuring-bind (function result-type &rest argument-types)
specifier
(aver (eq 'function function))
- (values (let ((*values-type-okay* t))
- (parse-alien-type result-type env))
- (mapcar (lambda (spec)
- (parse-alien-type spec env))
- argument-types))))
+ (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))))
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) (parse-alien-ftype specifier 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
(setf (gethash ',specifier *alien-callback-wrappers*)
(compile nil
',(alien-callback-lisp-wrapper-lambda
- specifier result-type argument-types env)))))
+ specifier result-type argument-types env))))
+ ,call-type)
',(parse-alien-type specifier env))))
(defun alien-callback-p (alien)
projects / sbcl.git / blobdiff