',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)))))
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
:sap-form `(foreign-symbol-sap ',initial-value
,datap))))
`((symbol-macrolet
- ((,symbol (%heap-alien ',info)))
- ,@body))))
+ ((,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)))
+ (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''."
+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''."
(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 (eval 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))
+ (%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.
(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 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)
(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)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(type alien-type type))
- (funcall (coerce (compute-deposit-lambda type) 'function)
+ (funcall (coerce-to-interpreted-function (compute-deposit-lambda type))
sap offset type value))
\f
;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
(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)
(t
(error "~S is not an alien function." alien)))))
-(defun alien-funcall-stdcall (alien &rest args)
- #!+sb-doc
- "Call the foreign function ALIEN with the specified arguments. ALIEN's
- type specifies the argument and result types."
- (declare (type alien-value alien))
- (let ((type (alien-value-type alien)))
- (typecase type
- (alien-pointer-type
- (apply #'alien-funcall-stdcall (deref 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-stdcall ,fun ,@parms)))))
- (setf (alien-fun-type-stub type) stub))
- (apply stub alien args)))
- (t
- (error "~S is not an alien function." alien)))))
-
(defmacro define-alien-routine (name result-type
&rest args
&environment lexenv)
((,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
(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
(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
- for offset = 0 ; FIXME: Should this not be AND OFFSET ...?
- then (+ offset (alien-callback-argument-bytes spec env))
collect `(,(pop argument-names) ,spec
:local ,(alien-callback-accessor-form
- spec 'args-sap offset)))
+ 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)))
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)
,function
(or (gethash ',specifier *alien-callback-wrappers*)
(setf (gethash ',specifier *alien-callback-wrappers*)
- ,(alien-callback-lisp-wrapper-lambda
- specifier result-type argument-types env))))
+ (compile nil
+ ',(alien-callback-lisp-wrapper-lambda
+ specifier result-type argument-types env)))))
',(parse-alien-type specifier env))))
(defun alien-callback-p (alien)
(setf (callback-info-function info) nil)
t)))
-;;; FIXME: This calls assembles a new callback for every closure,
-;;; which suck hugely. ...not that I can think of an obvious
+;;; 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?
;;;
projects / sbcl.git / blobdiff