(values name (guess-alien-name-from-lisp-name name)))
(list
(unless (proper-list-of-length-p name 2)
- (error "badly formed alien name"))
+ (error "badly formed alien name"))
(values (cadr name) (car name))))))
-(defmacro def-alien-variable (name type &environment env)
+(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
(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))))))
+
+(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 %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
+ :sap-form `(foreign-symbol-sap ',alien-name t)))))
(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))))
+ (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 (parse-alien-type type env)
- :sap-form `(foreign-symbol-address ',alien-name)))))
+ :type alien-type
+ :sap-form `(foreign-symbol-sap ',alien-name ,datap)))))
(defmacro with-alien (bindings &body body &environment env)
#!+sb-doc
(dolist (binding (reverse bindings))
(/show binding)
(destructuring-bind
- (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
- binding
- (/show symbol type opt1 opt2)
- (let ((alien-type (parse-alien-type type env)))
- (/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
- (/show ":EXTERN case")
- (let ((info (make-heap-alien-info
- :type alien-type
- :sap-form `(foreign-symbol-address
- ',initial-value))))
- `((symbol-macrolet
- ((,symbol (%heap-alien ',info)))
- ,@body))))
- (:local
- (/show ":LOCAL case")
- (let ((var (gensym))
- (initval (if initial-value (gensym)))
- (info (make-local-alien-info :type alien-type)))
- (/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))))))))))))
+ (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")
+ (let ((info (make-heap-alien-info
+ :type alien-type
+ :sap-form `(foreign-symbol-sap ',initial-value
+ ,datap))))
+ `((symbol-macrolet
+ ((,symbol (%heap-alien ',info)))
+ ,@body))))
+ (:local
+ (/show0 ":LOCAL case")
+ (let ((var (gensym))
+ (initval (if initial-value (gensym)))
+ (info (make-local-alien-info :type alien-type)))
+ (/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))))))))))))
(/show "revised" body)
(verify-local-auxiliaries-okay)
- (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
+ (/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))))
,@body)))
\f
;;;; runtime C values that don't correspond directly to Lisp types
(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)
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)
memory is allocated using ``malloc'', so it can be passed to foreign
functions which use ``free''."
(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)))
+ `(%sap-alien (%make-alien (* ,(align-offset bits alignment)
+ ,size-expr))
+ ',(make-alien-pointer-type :to alien-type))))))
;;; Allocate a block of memory at least BITS bits long and return a
;;; system area pointer to it.
(defun %make-alien (bits)
(declare (type index bits))
(alien-funcall (extern-alien "malloc"
- (function system-area-pointer unsigned))
- (ash (the index (+ bits 7)) -3)))
+ (function system-area-pointer unsigned))
+ (ash (the index (+ bits 7)) -3)))
#!-sb-fluid (declaim (inline free-alien))
(defun free-alien (alien)
"Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated
by MAKE-ALIEN or malloc(3)."
(alien-funcall (extern-alien "free" (function (values) system-area-pointer))
- (alien-sap alien))
+ (alien-sap alien))
nil)
\f
;;;; 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)
+ :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
#!+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)))))))
+ (extract-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))))))
+ (deposit-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)))))))
\f
;;;; the DEREF operator
;;; 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)
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)))
+ 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)))
+ 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))))
\f
;;;; accessing heap alien variables
(defun %heap-alien (info)
(declare (type heap-alien-info info)
- (optimize (inhibit-warnings 3)))
+ (optimize (inhibit-warnings 3)))
(extract-alien-value (eval (heap-alien-info-sap-form info))
- 0
- (heap-alien-info-type info)))
+ 0
+ (heap-alien-info-type info)))
(defun %set-heap-alien (info value)
(declare (type heap-alien-info info)
- (optimize (inhibit-warnings 3)))
+ (optimize (inhibit-warnings 3)))
(deposit-alien-value (eval (heap-alien-info-sap-form info))
- 0
- (heap-alien-info-type info)
- value))
+ 0
+ (heap-alien-info-type info)
+ value))
(defun %heap-alien-addr (info)
(declare (type heap-alien-info info)
- (optimize (inhibit-warnings 3)))
+ (optimize (inhibit-warnings 3)))
(%sap-alien (eval (heap-alien-info-sap-form info))
- (make-alien-pointer-type :to (heap-alien-info-type info))))
+ (make-alien-pointer-type :to (heap-alien-info-type info))))
\f
;;;; 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)))
alien))
(defun note-local-alien-type (info alien)
(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 (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 (%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)
+ (setf ,alien
+ (deport ,value ',(local-alien-info-type info))))
+ whole)))
(defun %local-alien-forced-to-memory-p (info)
(local-alien-info-force-to-memory-p info))
(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))))
\f
;;;; the ALIEN-SIZE macro
"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)))))
\f
;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
(defun naturalize (alien type)
(declare (type alien-type type))
(funcall (coerce (compute-naturalize-lambda type) 'function)
- alien type))
+ alien type))
(defun deport (value type)
(declare (type alien-type type))
(funcall (coerce (compute-deport-lambda type) 'function)
- value type))
+ value type))
(defun extract-alien-value (sap offset type)
(declare (type system-area-pointer sap)
- (type unsigned-byte offset)
- (type alien-type type))
+ (type unsigned-byte offset)
+ (type alien-type type))
(funcall (coerce (compute-extract-lambda type) 'function)
- sap offset type))
+ sap offset type))
(defun deposit-alien-value (sap offset type value)
(declare (type system-area-pointer sap)
- (type unsigned-byte offset)
- (type alien-type type))
+ (type unsigned-byte offset)
+ (type alien-type type))
(funcall (coerce (compute-deposit-lambda type) 'function)
- sap offset type value))
+ sap offset type value))
\f
-;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE
+;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
(defun alien-funcall (alien &rest args)
#!+sb-doc
(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 (gensym))
+ (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))
+ #-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))
\f
(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)))))
+
+;;;; 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)
+ (let ((key (cons 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)))
+ (vector-push-extend
+ (alien-callback-lisp-trampoline wrapper function)
+ *alien-callback-trampolines*)
+ (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)
+ (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 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))
+ (values (let ((*values-type-okay* t))
+ (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)
+ (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) (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*)
+ ,(alien-callback-lisp-wrapper-lambda
+ specifier result-type argument-types env))))
+ ',(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)))))