X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=5d0036a285a33f649f3827e954ede4edec225261;hb=7e24349c17298e2959e853ea411b5f65d9f7f332;hp=e664b37fd7c13717eb18861a8d0e0b9d49f0bfcc;hpb=dcb73f3edef1e31078fbe585e2fafbd26743efd7;p=sbcl.git

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index e664b37..5d0036a 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -213,6 +213,52 @@
 
 ;;;; allocation/deallocation of heap aliens
 
+(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''."
+  (let ((alien-type (if (alien-type-p type)
+                        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 (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)))
+        ;; 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.
 #!-sb-fluid (declaim (inline %make-alien))
@@ -417,6 +463,8 @@
 
 (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)
@@ -427,8 +475,10 @@
             (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)
@@ -488,28 +538,38 @@
 
 ;;;; 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))
 
 ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE