1.0.16.35: improved TIME output

[sbcl.git] / src / compiler / aliencomp.lisp

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index fec6e5b..bc5b11a 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -332,7 +332,8 @@
 (deftransform %heap-alien-addr ((info) * * :important t)
   (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
     (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
-    `(%sap-alien ,sap ',type)))
+    `(%sap-alien ,sap ',(make-alien-pointer-type :to type))))
+
 \f
 ;;;; support for local (stack or register) aliens
 
@@ -348,14 +349,16 @@
     (/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)
-      #!+(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)))
+      #!+(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)
@@ -525,7 +528,7 @@
          (count-low-order-zeros (lvar-uses thing))))
     (combination
      (case (let ((name (lvar-fun-name (combination-fun thing))))
-             (or (modular-version-info name :unsigned) name))
+             (or (modular-version-info name :untagged nil) name))
        ((+ -)
         (let ((min most-positive-fixnum)
               (itype (specifier-type 'integer)))
@@ -582,7 +585,7 @@
       (give-up-ir1-transform))
     (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
       (multiple-value-bind (prototype width)
-          (modular-version-info inside-fun-name :unsigned)
+          (modular-version-info inside-fun-name :untagged nil)
         (unless (eq (or prototype inside-fun-name) 'ash)
           (give-up-ir1-transform))
         (when (and width (not (constant-lvar-p amount)))
@@ -700,11 +703,14 @@
                   (error "Something is broken.")))
         (lvar (node-lvar call))
         (args args)
-        #!+(or (and (or x86 x86-64) darwin) win32) (stack-pointer (make-stack-pointer-tn)))
+        #!+x86
+        (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)
-      #!+(or (and (or x86 x86-64) darwin) win32) (vop current-stack-pointer call block stack-pointer)
+      #!+x86
+      (progn
+        (vop set-fpu-word-for-c call block)
+        (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
@@ -722,22 +728,22 @@
           (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)
+                                                     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))
+                               (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
@@ -759,7 +765,10 @@
               ((lvar-tn call block function)
                (reference-tn-list arg-tns nil))
               ((reference-tn-list result-tns t))))
-      #!-(or (and darwin (or x86 x86-64)) win32) (vop dealloc-number-stack-space call block stack-frame-size)
-      #!+(or (and darwin (or x86 x86-64)) win32) (vop reset-stack-pointer call block stack-pointer)
-      #!+x86 (vop set-fpu-word-for-lisp call block)
+      #!-x86
+      (vop dealloc-number-stack-space call block stack-frame-size)
+      #!+x86
+      (progn
+        (vop reset-stack-pointer call block stack-pointer)
+        (vop set-fpu-word-for-lisp call block))
       (move-lvar-result call block result-tns lvar))))