X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=3299c2108a75e0b015f20f2b7dc24688432c9bf2;hb=f68aae04c952d9e9749c0f7cc8cf3768e82f15a8;hp=03de07c3a6c4089622c3f041ed8d51e57c917139;hpb=3d2165e67f9ad1443f6e7d8ad24810000b0436e8;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 03de07c..3299c21 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -61,6 +61,8 @@
   (flushable movable))
 (defknown deport (alien alien-type) t
   (flushable movable))
+(defknown deport-alloc (alien alien-type) t
+  (flushable movable))
 (defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t
   (flushable))
 (defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
@@ -469,7 +471,7 @@
   (let ((alien-node (lvar-uses alien)))
     (typecase alien-node
       (combination
-       (extract-fun-args alien '%sap-alien 2)
+       (splice-fun-args alien '%sap-alien 2)
        '(lambda (sap type)
           (declare (ignore type))
           sap))
@@ -506,6 +508,8 @@
     (%computed-lambda #'compute-naturalize-lambda type))
   (deftransform deport ((alien type) * * :important t)
     (%computed-lambda #'compute-deport-lambda type))
+  (deftransform deport-alloc ((alien type) * * :important t)
+    (%computed-lambda #'compute-deport-alloc-lambda type))
   (deftransform extract-alien-value ((sap offset type) * * :important t)
     (%computed-lambda #'compute-extract-lambda type))
   (deftransform deposit-alien-value ((sap offset type value) * * :important t)
@@ -590,7 +594,7 @@
             (unless (and (constant-lvar-p inside-amount)
                          (not (minusp (lvar-value inside-amount))))
               (give-up-ir1-transform)))
-          (extract-fun-args value inside-fun-name 2)
+          (splice-fun-args value inside-fun-name 2)
           (if width
               `(lambda (value amount1 amount2)
                  (logand (ash value (+ amount1 amount2))
@@ -627,10 +631,31 @@
             (let ((param (gensym)))
               (params param)
               (deports `(deport ,param ',arg-type))))
+          ;; Build BODY from the inside out.
           (let ((return-type (alien-fun-type-result-type alien-type))
+                ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
+                ;; to them) and do the call.
                 (body `(%alien-funcall (deport function ',alien-type)
                                        ',alien-type
                                        ,@(deports))))
+            ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
+            ;; the SAPs are taken for won't be moved by the GC. (If
+            ;; needed: some alien types won't need it).
+            (setf body `(maybe-with-pinned-objects ,(params) ,arg-types
+                          ,body))
+            ;; Around that handle any memory allocation that's needed.
+            ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
+            ;; identity operation, but for example for deporting a
+            ;; Unicode string we need to convert the string into an
+            ;; octet array. This step needs to be done before the pinning
+            ;; to ensure we pin the right objects, so it can't be combined
+            ;; with the deporting.
+            ;; -- JES 2006-03-16
+            (loop for param in (params)
+                  for arg-type in arg-types
+                  do (setf body
+                           `(let ((,param (deport-alloc ,param ',arg-type)))
+                              ,body)))
             (if (alien-values-type-p return-type)
                 (collect ((temps) (results))
                   (dolist (type (alien-values-type-values return-type))