X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=3299c2108a75e0b015f20f2b7dc24688432c9bf2;hb=fe962ba01d267b92f638c8f0d19be41054219f04;hp=33afd27e6d48f77e7ccead2bc5db3fb84e0c4ed0;hpb=02a50d510572990c2b836e37ec1c0b23dac41b1a;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 33afd27..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))
@@ -675,11 +700,11 @@
                   (error "Something is broken.")))
         (lvar (node-lvar call))
         (args args)
-        #!+win32 (stack-pointer (make-stack-pointer-tn)))
+        #!+(or (and x86 darwin) win32) (stack-pointer (make-stack-pointer-tn)))
     (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
         (make-call-out-tns type)
       #!+x86 (vop set-fpu-word-for-c call block)
-      #!+win32 (vop current-stack-pointer call block stack-pointer)
+      #!+(or (and x86 darwin) win32) (vop current-stack-pointer call block stack-pointer)
       (vop alloc-number-stack-space call block stack-frame-size nsp)
       (dolist (tn arg-tns)
         ;; On PPC, TN might be a list. This is used to indicate
@@ -734,7 +759,7 @@
               ((lvar-tn call block function)
                (reference-tn-list arg-tns nil))
               ((reference-tn-list result-tns t))))
-      #!-win32 (vop dealloc-number-stack-space call block stack-frame-size)
-      #!+win32 (vop reset-stack-pointer call block stack-pointer)
+      #!-(or (and darwin x86) win32) (vop dealloc-number-stack-space call block stack-frame-size)
+      #!+(or (and darwin x86) win32) (vop reset-stack-pointer call block stack-pointer)
       #!+x86 (vop set-fpu-word-for-lisp call block)
       (move-lvar-result call block result-tns lvar))))