X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=3299c2108a75e0b015f20f2b7dc24688432c9bf2;hb=fe5d3fcb66a417311359101a77da4a691e649622;hp=487b61985412be369f5bf3e41e257155a1c06b8b;hpb=9489abab7f981b8eea2aec8a883f2eb48d4cb138;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 487b619..3299c21 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -61,9 +61,11 @@
   (flushable movable))
 (defknown deport (alien alien-type) t
   (flushable movable))
-(defknown extract-alien-value (system-area-pointer index alien-type) t
+(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 index alien-type t) t
+(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
   ())
 
 (defknown alien-funcall (alien-value &rest *) *
@@ -72,84 +74,84 @@
 ;;;; cosmetic transforms
 
 (deftransform slot ((object slot)
-		    ((alien (* t)) symbol))
+                    ((alien (* t)) symbol))
   '(slot (deref object) slot))
 
 (deftransform %set-slot ((object slot value)
-			 ((alien (* t)) symbol t))
+                         ((alien (* t)) symbol t))
   '(%set-slot (deref object) slot value))
 
 (deftransform %slot-addr ((object slot)
-			  ((alien (* t)) symbol))
+                          ((alien (* t)) symbol))
   '(%slot-addr (deref object) slot))
 
 ;;;; SLOT support
 
 (defun find-slot-offset-and-type (alien slot)
-  (unless (constant-continuation-p slot)
+  (unless (constant-lvar-p slot)
     (give-up-ir1-transform
      "The slot is not constant, so access cannot be open coded."))
-  (let ((type (continuation-type alien)))
+  (let ((type (lvar-type alien)))
     (unless (alien-type-type-p type)
       (give-up-ir1-transform))
     (let ((alien-type (alien-type-type-alien-type type)))
       (unless (alien-record-type-p alien-type)
-	(give-up-ir1-transform))
-      (let* ((slot-name (continuation-value slot))
-	     (field (find slot-name (alien-record-type-fields alien-type)
-			  :key #'alien-record-field-name)))
-	(unless field
-	  (abort-ir1-transform "~S doesn't have a slot named ~S"
-			       alien
-			       slot-name))
-	(values (alien-record-field-offset field)
-		(alien-record-field-type field))))))
+        (give-up-ir1-transform))
+      (let* ((slot-name (lvar-value slot))
+             (field (find slot-name (alien-record-type-fields alien-type)
+                          :key #'alien-record-field-name)))
+        (unless field
+          (abort-ir1-transform "~S doesn't have a slot named ~S"
+                               alien
+                               slot-name))
+        (values (alien-record-field-offset field)
+                (alien-record-field-type field))))))
 
 #+nil ;; Shouldn't be necessary.
 (defoptimizer (slot derive-type) ((alien slot))
   (block nil
     (catch 'give-up-ir1-transform
       (multiple-value-bind (slot-offset slot-type)
-	  (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(return (make-alien-type-type slot-type))))
+          (find-slot-offset-and-type alien slot)
+        (declare (ignore slot-offset))
+        (return (make-alien-type-type slot-type))))
     *wild-type*))
 
 (deftransform slot ((alien slot) * * :important t)
   (multiple-value-bind (slot-offset slot-type)
       (find-slot-offset-and-type alien slot)
     `(extract-alien-value (alien-sap alien)
-			  ,slot-offset
-			  ',slot-type)))
+                          ,slot-offset
+                          ',slot-type)))
 
 #+nil ;; ### But what about coercions?
 (defoptimizer (%set-slot derive-type) ((alien slot value))
   (block nil
     (catch 'give-up-ir1-transform
       (multiple-value-bind (slot-offset slot-type)
-	  (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(let ((type (make-alien-type-type slot-type)))
-	  (assert-continuation-type value type)
-	  (return type))))
+          (find-slot-offset-and-type alien slot)
+        (declare (ignore slot-offset))
+        (let ((type (make-alien-type-type slot-type)))
+          (assert-lvar-type value type)
+          (return type))))
     *wild-type*))
 
 (deftransform %set-slot ((alien slot value) * * :important t)
   (multiple-value-bind (slot-offset slot-type)
       (find-slot-offset-and-type alien slot)
     `(deposit-alien-value (alien-sap alien)
-			  ,slot-offset
-			  ',slot-type
-			  value)))
+                          ,slot-offset
+                          ',slot-type
+                          value)))
 
 (defoptimizer (%slot-addr derive-type) ((alien slot))
   (block nil
     (catch 'give-up-ir1-transform
       (multiple-value-bind (slot-offset slot-type)
-	  (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(return (make-alien-type-type
-		 (make-alien-pointer-type :to slot-type)))))
+          (find-slot-offset-and-type alien slot)
+        (declare (ignore slot-offset))
+        (return (make-alien-type-type
+                 (make-alien-pointer-type :to slot-type)))))
     *wild-type*))
 
 (deftransform %slot-addr ((alien slot) * * :important t)
@@ -157,18 +159,18 @@
       (find-slot-offset-and-type alien slot)
     (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
     `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
-		 ',(make-alien-pointer-type :to slot-type))))
+                 ',(make-alien-pointer-type :to slot-type))))
 
 ;;;; DEREF support
 
 (defun find-deref-alien-type (alien)
-  (let ((alien-type (continuation-type alien)))
+  (let ((alien-type (lvar-type alien)))
     (unless (alien-type-type-p alien-type)
       (give-up-ir1-transform))
     (let ((alien-type (alien-type-type-alien-type alien-type)))
       (if (alien-type-p alien-type)
-	  alien-type
-	  (give-up-ir1-transform)))))
+          alien-type
+          (give-up-ir1-transform)))))
 
 (defun find-deref-element-type (alien)
   (let ((alien-type (find-deref-alien-type alien)))
@@ -185,48 +187,48 @@
     (typecase alien-type
       (alien-pointer-type
        (when (cdr indices)
-	 (abort-ir1-transform "too many indices for pointer deref: ~W"
-			      (length indices)))
+         (abort-ir1-transform "too many indices for pointer deref: ~W"
+                              (length indices)))
        (let ((element-type (alien-pointer-type-to alien-type)))
-	 (if indices
-	     (let ((bits (alien-type-bits element-type))
-		   (alignment (alien-type-alignment element-type)))
-	       (unless bits
-		 (abort-ir1-transform "unknown element size"))
-	       (unless alignment
-		 (abort-ir1-transform "unknown element alignment"))
-	       (values '(offset)
-		       `(* offset
-			   ,(align-offset bits alignment))
-		       element-type))
-	     (values nil 0 element-type))))
+         (if indices
+             (let ((bits (alien-type-bits element-type))
+                   (alignment (alien-type-alignment element-type)))
+               (unless bits
+                 (abort-ir1-transform "unknown element size"))
+               (unless alignment
+                 (abort-ir1-transform "unknown element alignment"))
+               (values '(offset)
+                       `(* offset
+                           ,(align-offset bits alignment))
+                       element-type))
+             (values nil 0 element-type))))
       (alien-array-type
        (let* ((element-type (alien-array-type-element-type alien-type))
-	      (bits (alien-type-bits element-type))
-	      (alignment (alien-type-alignment element-type))
-	      (dims (alien-array-type-dimensions alien-type)))
-	 (unless (= (length indices) (length dims))
-	   (give-up-ir1-transform "incorrect number of indices"))
-	 (unless bits
-	   (give-up-ir1-transform "Element size is unknown."))
-	 (unless alignment
-	   (give-up-ir1-transform "Element alignment is unknown."))
-	 (if (null dims)
-	     (values nil 0 element-type)
-	     (let* ((arg (gensym))
-		    (args (list arg))
-		    (offsetexpr arg))
-	       (dolist (dim (cdr dims))
-		 (let ((arg (gensym)))
-		   (push arg args)
-		   (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
-	       (values (reverse args)
-		       `(* ,offsetexpr
-			   ,(align-offset bits alignment))
-		       element-type)))))
+              (bits (alien-type-bits element-type))
+              (alignment (alien-type-alignment element-type))
+              (dims (alien-array-type-dimensions alien-type)))
+         (unless (= (length indices) (length dims))
+           (give-up-ir1-transform "incorrect number of indices"))
+         (unless bits
+           (give-up-ir1-transform "Element size is unknown."))
+         (unless alignment
+           (give-up-ir1-transform "Element alignment is unknown."))
+         (if (null dims)
+             (values nil 0 element-type)
+             (let* ((arg (gensym))
+                    (args (list arg))
+                    (offsetexpr arg))
+               (dolist (dim (cdr dims))
+                 (let ((arg (gensym)))
+                   (push arg args)
+                   (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
+               (values (reverse args)
+                       `(* ,offsetexpr
+                           ,(align-offset bits alignment))
+                       element-type)))))
       (t
        (abort-ir1-transform "~S not either a pointer or array type."
-			    alien-type)))))
+                            alien-type)))))
 
 #+nil ;; Shouldn't be necessary.
 (defoptimizer (deref derive-type) ((alien &rest noise))
@@ -241,8 +243,8 @@
       (compute-deref-guts alien indices)
     `(lambda (alien ,@indices-args)
        (extract-alien-value (alien-sap alien)
-			    ,offset-expr
-			    ',element-type))))
+                            ,offset-expr
+                            ',element-type))))
 
 #+nil ;; ### Again, the value might be coerced.
 (defoptimizer (%set-deref derive-type) ((alien value &rest noise))
@@ -250,10 +252,10 @@
   (block nil
     (catch 'give-up-ir1-transform
       (let ((type (make-alien-type-type
-		   (make-alien-pointer-type
-		    :to (find-deref-element-type alien)))))
-	(assert-continuation-type value type)
-	(return type)))
+                   (make-alien-pointer-type
+                    :to (find-deref-element-type alien)))))
+        (assert-lvar-type value type)
+        (return type)))
     *wild-type*))
 
 (deftransform %set-deref ((alien value &rest indices) * * :important t)
@@ -261,17 +263,17 @@
       (compute-deref-guts alien indices)
     `(lambda (alien value ,@indices-args)
        (deposit-alien-value (alien-sap alien)
-			    ,offset-expr
-			    ',element-type
-			    value))))
+                            ,offset-expr
+                            ',element-type
+                            value))))
 
 (defoptimizer (%deref-addr derive-type) ((alien &rest noise))
   (declare (ignore noise))
   (block nil
     (catch 'give-up-ir1-transform
       (return (make-alien-type-type
-	       (make-alien-pointer-type
-		:to (find-deref-element-type alien)))))
+               (make-alien-pointer-type
+                :to (find-deref-element-type alien)))))
     *wild-type*))
 
 (deftransform %deref-addr ((alien &rest indices) * * :important t)
@@ -280,24 +282,24 @@
     (/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
     `(lambda (alien ,@indices-args)
        (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:n-byte-bits))
-		   ',(make-alien-pointer-type :to element-type)))))
+                   ',(make-alien-pointer-type :to element-type)))))
 
 ;;;; support for aliens on the heap
 
 (defun heap-alien-sap-and-type (info)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (give-up-ir1-transform "info not constant; can't open code"))
-  (let ((info (continuation-value info)))
+  (let ((info (lvar-value info)))
     (values (heap-alien-info-sap-form info)
-	    (heap-alien-info-type info))))
+            (heap-alien-info-type info))))
 
 #+nil ; shouldn't be necessary
 (defoptimizer (%heap-alien derive-type) ((info))
   (block nil
     (catch 'give-up
       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(return (make-alien-type-type type))))
+        (declare (ignore sap))
+        (return (make-alien-type-type type))))
     *wild-type*))
 
 (deftransform %heap-alien ((info) * * :important t)
@@ -309,10 +311,10 @@
   (block nil
     (catch 'give-up-ir1-transform
       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(let ((type (make-alien-type-type type)))
-	  (assert-continuation-type value type)
-	  (return type))))
+        (declare (ignore sap))
+        (let ((type (make-alien-type-type type)))
+          (assert-lvar-type value type)
+          (return type))))
     *wild-type*))
 
 (deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
@@ -323,8 +325,8 @@
   (block nil
     (catch 'give-up-ir1-transform
       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(return (make-alien-type-type (make-alien-pointer-type :to type)))))
+        (declare (ignore sap))
+        (return (make-alien-type-type (make-alien-pointer-type :to type)))))
     *wild-type*))
 
 (deftransform %heap-alien-addr ((info) * * :important t)
@@ -335,151 +337,151 @@
 ;;;; support for local (stack or register) aliens
 
 (deftransform make-local-alien ((info) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info))
-	 (bits (alien-type-bits alien-type)))
+  (let* ((info (lvar-value info))
+         (alien-type (local-alien-info-type info))
+         (bits (alien-type-bits alien-type)))
     (unless bits
       (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
     (/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
     (/noshow (local-alien-info-force-to-memory-p info))
     (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
     (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(truly-the system-area-pointer
-			 (%primitive alloc-alien-stack-space
-				     ,(ceiling (alien-type-bits alien-type)
-					       sb!vm:n-byte-bits)))
-      #!-x86 `(truly-the system-area-pointer
-			 (%primitive alloc-number-stack-space
-				     ,(ceiling (alien-type-bits alien-type)
-					       sb!vm:n-byte-bits)))
+      #!+(or x86 x86-64) `(truly-the system-area-pointer
+                         (%primitive alloc-alien-stack-space
+                                     ,(ceiling (alien-type-bits alien-type)
+                                               sb!vm:n-byte-bits)))
+      #!-(or x86 x86-64) `(truly-the system-area-pointer
+                         (%primitive alloc-number-stack-space
+                                     ,(ceiling (alien-type-bits alien-type)
+                                               sb!vm:n-byte-bits)))
       (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
-	     (alien-rep-type (specifier-type alien-rep-type-spec)))
-	(cond ((csubtypep (specifier-type 'system-area-pointer)
-			  alien-rep-type)
-	       '(int-sap 0))
-	      ((ctypep 0 alien-rep-type) 0)
-	      ((ctypep 0.0f0 alien-rep-type) 0.0f0)
-	      ((ctypep 0.0d0 alien-rep-type) 0.0d0)
-	      (t
-	       (compiler-error
-		"Aliens of type ~S cannot be represented immediately."
-		(unparse-alien-type alien-type))))))))
+             (alien-rep-type (specifier-type alien-rep-type-spec)))
+        (cond ((csubtypep (specifier-type 'system-area-pointer)
+                          alien-rep-type)
+               '(int-sap 0))
+              ((ctypep 0 alien-rep-type) 0)
+              ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+              ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+              (t
+               (compiler-error
+                "Aliens of type ~S cannot be represented immediately."
+                (unparse-alien-type alien-type))))))))
 
 (deftransform note-local-alien-type ((info var) * * :important t)
   ;; FIXME: This test and error occur about a zillion times. They
   ;; could be factored into a function.
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let ((info (continuation-value info)))
+  (let ((info (lvar-value info)))
     (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info)
     (/noshow (local-alien-info-force-to-memory-p info))
     (unless (local-alien-info-force-to-memory-p info)
-      (let ((var-node (continuation-use var)))
-	(/noshow var-node (ref-p var-node))
-	(when (ref-p var-node)
-	  (propagate-to-refs (ref-leaf var-node)
-			     (specifier-type
-			      (compute-alien-rep-type
-			       (local-alien-info-type info))))))))
+      (let ((var-node (lvar-uses var)))
+        (/noshow var-node (ref-p var-node))
+        (when (ref-p var-node)
+          (propagate-to-refs (ref-leaf var-node)
+                             (specifier-type
+                              (compute-alien-rep-type
+                               (local-alien-info-type info))))))))
   nil)
 
 (deftransform local-alien ((info var) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
+  (let* ((info (lvar-value info))
+         (alien-type (local-alien-info-type info)))
     (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
     (/noshow (local-alien-info-force-to-memory-p info))
     (if (local-alien-info-force-to-memory-p info)
-	`(extract-alien-value var 0 ',alien-type)
-	`(naturalize var ',alien-type))))
+        `(extract-alien-value var 0 ',alien-type)
+        `(naturalize var ',alien-type))))
 
 (deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let ((info (continuation-value info)))
+  (let ((info (lvar-value info)))
     (local-alien-info-force-to-memory-p info)))
 
 (deftransform %set-local-alien ((info var value) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
+  (let* ((info (lvar-value info))
+         (alien-type (local-alien-info-type info)))
     (if (local-alien-info-force-to-memory-p info)
-	`(deposit-alien-value var 0 ',alien-type value)
-	'(error "This should be eliminated as dead code."))))
+        `(deposit-alien-value var 0 ',alien-type value)
+        '(error "This should be eliminated as dead code."))))
 
 (defoptimizer (%local-alien-addr derive-type) ((info var))
-  (if (constant-continuation-p info)
-      (let* ((info (continuation-value info))
-	     (alien-type (local-alien-info-type info)))
-	(make-alien-type-type (make-alien-pointer-type :to alien-type)))
+  (if (constant-lvar-p info)
+      (let* ((info (lvar-value info))
+             (alien-type (local-alien-info-type info)))
+        (make-alien-type-type (make-alien-pointer-type :to alien-type)))
       *wild-type*))
 
 (deftransform %local-alien-addr ((info var) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
+  (let* ((info (lvar-value info))
+         (alien-type (local-alien-info-type info)))
     (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
     (if (local-alien-info-force-to-memory-p info)
-	`(%sap-alien var ',(make-alien-pointer-type :to alien-type))
-	(error "This shouldn't happen."))))
+        `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
+        (error "This shouldn't happen."))))
 
 (deftransform dispose-local-alien ((info var) * * :important t)
-  (unless (constant-continuation-p info)
+  (unless (constant-lvar-p info)
     (abort-ir1-transform "Local alien info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
+  (let* ((info (lvar-value info))
+         (alien-type (local-alien-info-type info)))
     (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(%primitive dealloc-alien-stack-space
-			  ,(ceiling (alien-type-bits alien-type)
-				    sb!vm:n-byte-bits))
-      #!-x86 `(%primitive dealloc-number-stack-space
-			  ,(ceiling (alien-type-bits alien-type)
-				    sb!vm:n-byte-bits))
+      #!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space
+                          ,(ceiling (alien-type-bits alien-type)
+                                    sb!vm:n-byte-bits))
+      #!-(or x86 x86-64) `(%primitive dealloc-number-stack-space
+                          ,(ceiling (alien-type-bits alien-type)
+                                    sb!vm:n-byte-bits))
       nil)))
 
 ;;;; %CAST
 
 (defoptimizer (%cast derive-type) ((alien type))
-  (or (when (constant-continuation-p type)
-	(let ((alien-type (continuation-value type)))
-	  (when (alien-type-p alien-type)
-	    (make-alien-type-type alien-type))))
+  (or (when (constant-lvar-p type)
+        (let ((alien-type (lvar-value type)))
+          (when (alien-type-p alien-type)
+            (make-alien-type-type alien-type))))
       *wild-type*))
 
 (deftransform %cast ((alien target-type) * * :important t)
-  (unless (constant-continuation-p target-type)
+  (unless (constant-lvar-p target-type)
     (give-up-ir1-transform
      "The alien type is not constant, so access cannot be open coded."))
-  (let ((target-type (continuation-value target-type)))
+  (let ((target-type (lvar-value target-type)))
     (cond ((or (alien-pointer-type-p target-type)
-	       (alien-array-type-p target-type)
-	       (alien-fun-type-p target-type))
-	   `(naturalize (alien-sap alien) ',target-type))
-	  (t
-	   (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
+               (alien-array-type-p target-type)
+               (alien-fun-type-p target-type))
+           `(naturalize (alien-sap alien) ',target-type))
+          (t
+           (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
 
 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
 
 (deftransform alien-sap ((alien) * * :important t)
-  (let ((alien-node (continuation-use alien)))
+  (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))
+          (declare (ignore type))
+          sap))
       (t
        (give-up-ir1-transform)))))
 
 (defoptimizer (%sap-alien derive-type) ((sap type))
   (declare (ignore sap))
-  (if (constant-continuation-p type)
-      (make-alien-type-type (continuation-value type))
+  (if (constant-lvar-p type)
+      (make-alien-type-type (lvar-value type))
       *wild-type*))
 
 (deftransform %sap-alien ((sap type) * * :important t)
@@ -492,20 +494,22 @@
 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
 
 (flet ((%computed-lambda (compute-lambda type)
-	 (declare (type function compute-lambda))
-	 (unless (constant-continuation-p type)
-	   (give-up-ir1-transform
-	    "The type is not constant at compile time; can't open code."))
-	 (handler-case
-	     (let ((result (funcall compute-lambda (continuation-value type))))
-	       (/noshow "in %COMPUTED-LAMBDA" (continuation-value type) result)
-	       result)
-	   (error (condition)
-		  (compiler-error "~A" condition)))))
+         (declare (type function compute-lambda))
+         (unless (constant-lvar-p type)
+           (give-up-ir1-transform
+            "The type is not constant at compile time; can't open code."))
+         (handler-case
+             (let ((result (funcall compute-lambda (lvar-value type))))
+               (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
+               result)
+           (error (condition)
+                  (compiler-error "~A" condition)))))
   (deftransform naturalize ((object type) * * :important t)
     (%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)
@@ -515,128 +519,162 @@
 
 (defun count-low-order-zeros (thing)
   (typecase thing
-    (continuation
-     (if (constant-continuation-p thing)
-	 (count-low-order-zeros (continuation-value thing))
-	 (count-low-order-zeros (continuation-use thing))))
+    (lvar
+     (if (constant-lvar-p thing)
+         (count-low-order-zeros (lvar-value thing))
+         (count-low-order-zeros (lvar-uses thing))))
     (combination
-     (case (continuation-fun-name (combination-fun thing))
+     (case (let ((name (lvar-fun-name (combination-fun thing))))
+             (or (modular-version-info name :unsigned) name))
        ((+ -)
-	(let ((min most-positive-fixnum)
-	      (itype (specifier-type 'integer)))
-	  (dolist (arg (combination-args thing) min)
-	    (if (csubtypep (continuation-type arg) itype)
-		(setf min (min min (count-low-order-zeros arg)))
-		(return 0)))))
+        (let ((min most-positive-fixnum)
+              (itype (specifier-type 'integer)))
+          (dolist (arg (combination-args thing) min)
+            (if (csubtypep (lvar-type arg) itype)
+                (setf min (min min (count-low-order-zeros arg)))
+                (return 0)))))
        (*
-	(let ((result 0)
-	      (itype (specifier-type 'integer)))
-	  (dolist (arg (combination-args thing) result)
-	    (if (csubtypep (continuation-type arg) itype)
-		(setf result (+ result (count-low-order-zeros arg)))
-		(return 0)))))
+        (let ((result 0)
+              (itype (specifier-type 'integer)))
+          (dolist (arg (combination-args thing) result)
+            (if (csubtypep (lvar-type arg) itype)
+                (setf result (+ result (count-low-order-zeros arg)))
+                (return 0)))))
        (ash
-	(let ((args (combination-args thing)))
-	  (if (= (length args) 2)
-	      (let ((amount (second args)))
-		(if (constant-continuation-p amount)
-		    (max (+ (count-low-order-zeros (first args))
-			    (continuation-value amount))
-			 0)
-		    0))
-	      0)))
+        (let ((args (combination-args thing)))
+          (if (= (length args) 2)
+              (let ((amount (second args)))
+                (if (constant-lvar-p amount)
+                    (max (+ (count-low-order-zeros (first args))
+                            (lvar-value amount))
+                         0)
+                    0))
+              0)))
        (t
-	0)))
+        0)))
     (integer
      (if (zerop thing)
-	 most-positive-fixnum
-	 (do ((result 0 (1+ result))
-	      (num thing (ash num -1)))
-	     ((logbitp 0 num) result))))
+         most-positive-fixnum
+         (do ((result 0 (1+ result))
+              (num thing (ash num -1)))
+             ((logbitp 0 num) result))))
+    (cast
+     (count-low-order-zeros (cast-value thing)))
     (t
      0)))
 
 (deftransform / ((numerator denominator) (integer integer))
-  (unless (constant-continuation-p denominator)
+  "convert x/2^k to shift"
+  (unless (constant-lvar-p denominator)
     (give-up-ir1-transform))
-  (let* ((denominator (continuation-value denominator))
-	 (bits (1- (integer-length denominator))))
-    (unless (= (ash 1 bits) denominator)
+  (let* ((denominator (lvar-value denominator))
+         (bits (1- (integer-length denominator))))
+    (unless (and (> denominator 0) (= (ash 1 bits) denominator))
       (give-up-ir1-transform))
     (let ((alignment (count-low-order-zeros numerator)))
       (unless (>= alignment bits)
-	(give-up-ir1-transform))
+        (give-up-ir1-transform))
       `(ash numerator ,(- bits)))))
 
 (deftransform ash ((value amount))
-  (let ((value-node (continuation-use value)))
-    (unless (and (combination-p value-node)
-		 (eq (continuation-fun-name (combination-fun value-node))
-		     'ash))
+  (let ((value-node (lvar-uses value)))
+    (unless (combination-p value-node)
       (give-up-ir1-transform))
-    (let ((inside-args (combination-args value-node)))
-      (unless (= (length inside-args) 2)
-	(give-up-ir1-transform))
-      (let ((inside-amount (second inside-args)))
-	(unless (and (constant-continuation-p inside-amount)
-		     (not (minusp (continuation-value inside-amount))))
-	  (give-up-ir1-transform)))))
-  (extract-fun-args value 'ash 2)
-  '(lambda (value amount1 amount2)
-     (ash value (+ amount1 amount2))))
+    (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
+      (multiple-value-bind (prototype width)
+          (modular-version-info inside-fun-name :unsigned)
+        (unless (eq (or prototype inside-fun-name) 'ash)
+          (give-up-ir1-transform))
+        (when (and width (not (constant-lvar-p amount)))
+          (give-up-ir1-transform))
+        (let ((inside-args (combination-args value-node)))
+          (unless (= (length inside-args) 2)
+            (give-up-ir1-transform))
+          (let ((inside-amount (second inside-args)))
+            (unless (and (constant-lvar-p inside-amount)
+                         (not (minusp (lvar-value inside-amount))))
+              (give-up-ir1-transform)))
+          (splice-fun-args value inside-fun-name 2)
+          (if width
+              `(lambda (value amount1 amount2)
+                 (logand (ash value (+ amount1 amount2))
+                         ,(1- (ash 1 (+ width (lvar-value amount))))))
+              `(lambda (value amount1 amount2)
+                 (ash value (+ amount1 amount2)))))))))
 
 ;;;; ALIEN-FUNCALL support
 
 (deftransform alien-funcall ((function &rest args)
-			     ((alien (* t)) &rest *) *
-			     :important t)
+                             ((alien (* t)) &rest *) *
+                             :important t)
   (let ((names (make-gensym-list (length args))))
     (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
     `(lambda (function ,@names)
        (alien-funcall (deref function) ,@names))))
 
 (deftransform alien-funcall ((function &rest args) * * :important t)
-  (let ((type (continuation-type function)))
+  (let ((type (lvar-type function)))
     (unless (alien-type-type-p type)
       (give-up-ir1-transform "can't tell function type at compile time"))
     (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
     (let ((alien-type (alien-type-type-alien-type type)))
       (unless (alien-fun-type-p alien-type)
-	(give-up-ir1-transform))
+        (give-up-ir1-transform))
       (let ((arg-types (alien-fun-type-arg-types alien-type)))
-	(unless (= (length args) (length arg-types))
-	  (abort-ir1-transform
-	   "wrong number of arguments; expected ~W, got ~W"
-	   (length arg-types)
-	   (length args)))
-	(collect ((params) (deports))
-	  (dolist (arg-type arg-types)
-	    (let ((param (gensym)))
-	      (params param)
-	      (deports `(deport ,param ',arg-type))))
-	  (let ((return-type (alien-fun-type-result-type alien-type))
-		(body `(%alien-funcall (deport function ',alien-type)
-				       ',alien-type
-				       ,@(deports))))
-	    (if (alien-values-type-p return-type)
-		(collect ((temps) (results))
-		  (dolist (type (alien-values-type-values return-type))
-		    (let ((temp (gensym)))
-		      (temps temp)
-		      (results `(naturalize ,temp ',type))))
-		  (setf body
-			`(multiple-value-bind ,(temps) ,body
-			   (values ,@(results)))))
-		(setf body `(naturalize ,body ',return-type)))
-	    (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
-	    `(lambda (function ,@(params))
-	       ,body)))))))
+        (unless (= (length args) (length arg-types))
+          (abort-ir1-transform
+           "wrong number of arguments; expected ~W, got ~W"
+           (length arg-types)
+           (length args)))
+        (collect ((params) (deports))
+          (dolist (arg-type arg-types)
+            (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))
+                    (let ((temp (gensym)))
+                      (temps temp)
+                      (results `(naturalize ,temp ',type))))
+                  (setf body
+                        `(multiple-value-bind ,(temps) ,body
+                           (values ,@(results)))))
+                (setf body `(naturalize ,body ',return-type)))
+            (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
+            `(lambda (function ,@(params))
+               ,body)))))))
 
 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
   (declare (ignore function args))
-  (unless (constant-continuation-p type)
+  (unless (constant-lvar-p type)
     (error "Something is broken."))
-  (let ((type (continuation-value type)))
+  (let ((type (lvar-value type)))
     (unless (alien-fun-type-p type)
       (error "Something is broken."))
     (values-specifier-type
@@ -644,56 +682,84 @@
       (alien-fun-type-result-type type)))))
 
 (defoptimizer (%alien-funcall ltn-annotate)
-	      ((function type &rest args) node ltn-policy)
+              ((function type &rest args) node ltn-policy)
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation function)
+  (annotate-ordinary-lvar function)
   (dolist (arg args)
-    (annotate-ordinary-continuation arg)))
+    (annotate-ordinary-lvar arg)))
 
+;;; We support both the stdcall and cdecl calling conventions on win32 by
+;;; resetting ESP after the foreign function returns. This way it works
+;;; correctly whether the party that is supposed to pop arguments from
+;;; the stack is the caller (cdecl) or the callee (stdcall).
 (defoptimizer (%alien-funcall ir2-convert)
-	      ((function type &rest args) call block)
-  (let ((type (if (constant-continuation-p type)
-		  (continuation-value type)
-		  (error "Something is broken.")))
-	(cont (node-cont call))
-	(args args))
+              ((function type &rest args) call block)
+  (let ((type (if (constant-lvar-p type)
+                  (lvar-value type)
+                  (error "Something is broken.")))
+        (lvar (node-lvar call))
+        (args args)
+        #!+(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)
+        (make-call-out-tns type)
+      #!+x86 (vop set-fpu-word-for-c call block)
+      #!+(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)
-	(let* ((arg (pop args))
-	       (sc (tn-sc tn))
-	       (scn (sc-number sc))
-	       #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
-						       scn))
-	       (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
-	  (aver arg)
-	  (unless (= (length move-arg-vops) 1)
-	    (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
-	  #!+x86 (emit-move-arg-template call
-					 block
-					 (first move-arg-vops)
-					 (continuation-tn call block arg)
-					 nsp
-					 tn)
-	  #!-x86 (progn
-		   (emit-move call
-			      block
-			      (continuation-tn call block arg)
-			      temp-tn)
-		   (emit-move-arg-template call
-					   block
-					   (first move-arg-vops)
-					   temp-tn
-					   nsp
-					   tn))))
+        ;; On PPC, TN might be a list. This is used to indicate
+        ;; something special needs to happen. See below.
+        ;;
+        ;; FIXME: We should implement something better than this.
+        (let* ((first-tn (if (listp tn) (car tn) tn))
+               (arg (pop args))
+               (sc (tn-sc first-tn))
+               (scn (sc-number sc))
+               #!-(or x86 x86-64) (temp-tn (make-representation-tn
+                                            (tn-primitive-type first-tn) scn))
+               (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+          (aver arg)
+          (unless (= (length move-arg-vops) 1)
+            (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
+          #!+(or x86 x86-64) (emit-move-arg-template call
+                                         block
+                                         (first move-arg-vops)
+                                         (lvar-tn call block arg)
+                                         nsp
+                                         first-tn)
+          #!-(or x86 x86-64) (progn
+                   (emit-move call
+                              block
+                              (lvar-tn call block arg)
+                              temp-tn)
+                   (emit-move-arg-template call
+                                           block
+                                           (first move-arg-vops)
+                                           temp-tn
+                                           nsp
+                                           first-tn))
+          #!+(and ppc darwin)
+          (when (listp tn)
+            ;; This means that we have a float arg that we need to
+            ;; also copy to some int regs. The list contains the TN
+            ;; for the float as well as the TNs to use for the int
+            ;; arg.
+            (destructuring-bind (float-tn i1-tn &optional i2-tn)
+                tn
+              (if i2-tn
+                  (vop sb!vm::move-double-to-int-arg call block
+                       float-tn i1-tn i2-tn)
+                  (vop sb!vm::move-single-to-int-arg call block
+                       float-tn i1-tn))))))
       (aver (null args))
       (unless (listp result-tns)
-	(setf result-tns (list result-tns)))
-      (vop* call-out call block
-	    ((continuation-tn call block function)
-	     (reference-tn-list arg-tns nil))
-	    ((reference-tn-list result-tns t)))
-      (vop dealloc-number-stack-space call block stack-frame-size)
-      (move-continuation-result call block result-tns cont))))
+        (setf result-tns (list result-tns)))
+      (let ((arg-tns (flatten-list arg-tns)))
+        (vop* call-out call block
+              ((lvar-tn call block function)
+               (reference-tn-list arg-tns nil))
+              ((reference-tn-list result-tns t))))
+      #!-(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))))