X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=92c529c49496531361c0b22c04c46ac4cb453561;hb=96bb2dc76dddb1a21b3886fa7522796879e9ed9d;hp=dea6d47ceb5e2852f4c2786a32abe53d35e7271f;hpb=9015efbd1be6387a31514c2abd4dbdba4330d2a7;p=sbcl.git

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index dea6d47..92c529c 100644
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -43,6 +43,8 @@
   (deposit-gen nil :type (or null function))
   (naturalize-gen nil :type (or null function))
   (deport-gen nil :type (or null function))
+  (deport-alloc-gen nil :type (or null function))
+  (deport-pin-p nil :type (or null function))
   ;; Cast?
   (arg-tn nil :type (or null function))
   (result-tn nil :type (or null function))
@@ -73,6 +75,8 @@
     (:deposit-gen . alien-type-class-deposit-gen)
     (:naturalize-gen . alien-type-class-naturalize-gen)
     (:deport-gen . alien-type-class-deport-gen)
+    (:deport-alloc-gen . alien-type-class-deport-alloc-gen)
+    (:deport-pin-p . alien-type-class-deport-pin-p)
     ;; cast?
     (:arg-tn . alien-type-class-arg-tn)
     (:result-tn . alien-type-class-result-tn)))
@@ -281,9 +285,6 @@
              `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
          ,@(when name
              `((%define-alien-type ',name ',alien-type)))))))
-(def!macro def-alien-type (&rest rest)
-  (deprecation-warning 'def-alien-type 'define-alien-type)
-  `(define-alien-type ,@rest))
 
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun %def-auxiliary-alien-types (types)
@@ -445,6 +446,11 @@
                 (ignore ignore))
        ,form)))
 
+(defun compute-deport-alloc-lambda (type)
+  `(lambda (value ignore)
+     (declare (ignore ignore))
+     ,(invoke-alien-type-method :deport-alloc-gen type 'value)))
+
 (defun compute-extract-lambda (type)
   `(lambda (sap offset ignore)
      (declare (type system-area-pointer sap)
@@ -453,20 +459,39 @@
      (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
                  ',type)))
 
+(def!macro maybe-with-pinned-objects (variables types &body body)
+  (declare (ignorable variables types))
+  (let ((pin-variables
+         ;; Only pin things on x86/x86-64, since on non-conservative
+         ;; gcs it'd imply disabling the GC. Which is something we
+         ;; don't want to do every time we're calling to C.
+         #!+(or x86 x86-64)
+         (loop for variable in variables
+            for type in types
+            when (invoke-alien-type-method :deport-pin-p type)
+            collect variable)))
+    (if pin-variables
+        `(with-pinned-objects ,pin-variables
+           ,@body)
+        `(progn
+           ,@body))))
+
 (defun compute-deposit-lambda (type)
   (declare (type alien-type type))
   `(lambda (sap offset ignore value)
      (declare (type system-area-pointer sap)
               (type unsigned-byte offset)
               (ignore ignore))
-     (let ((value (deport value ',type)))
-       ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
-       ;; Note: the reason we don't just return the pre-deported value
-       ;; is because that would inhibit any (deport (naturalize ...))
-       ;; optimizations that might have otherwise happen. Re-naturalizing
-       ;; the value might cause extra consing, but is flushable, so probably
-       ;; results in better code.
-       (naturalize value ',type))))
+     (let ((alloc-tmp (deport-alloc value ',type)))
+       (maybe-with-pinned-objects (alloc-tmp) (,type)
+         (let ((value (deport alloc-tmp  ',type)))
+           ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
+           ;; Note: the reason we don't just return the pre-deported value
+           ;; is because that would inhibit any (deport (naturalize ...))
+           ;; optimizations that might have otherwise happen. Re-naturalizing
+           ;; the value might cause extra consing, but is flushable, so probably
+           ;; results in better code.
+           (naturalize value ',type))))))
 
 (defun compute-lisp-rep-type (type)
   (invoke-alien-type-method :lisp-rep type))
@@ -502,6 +527,16 @@
   (declare (ignore object))
   (error "cannot represent ~S typed aliens" type))
 
+(define-alien-type-method (root :deport-alloc-gen) (type object)
+  (declare (ignore type))
+  object)
+
+(define-alien-type-method (root :deport-pin-p) (type)
+  (declare (ignore type))
+  ;; Override this method to return T for classes which take a SAP to a
+  ;; GCable lisp object when deporting.
+  nil)
+
 (define-alien-type-method (root :extract-gen) (type sap offset)
   (declare (ignore sap offset))
   (error "cannot represent ~S typed aliens" type))