(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 (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))
+ (%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.
(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
(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
,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