X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=7d12edbfdd0e7b3a23a7e53eb9d07b8f4a0465ac;hb=6535ee98644b8fd1cea3581adb25d4d8bf7c1110;hp=9dce8b504e9f0aaf02972994b192c3f80152ec5e;hpb=8902b8b6bd2e9285749dd39d313b33b6c69c5213;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 9dce8b5..7d12edb 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -100,7 +100,6 @@
       (setf (ir2-lvar-kind info) :delayed))
      (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
           (setf (ir2-lvar-locs info) (list tn))
-          #!+stack-grows-downward-not-upward
           (when (lvar-dynamic-extent lvar)
             (setf (ir2-lvar-stack-pointer info)
                   (make-stack-pointer-tn)))))))
@@ -225,10 +224,13 @@
 ;;; specified primitive TYPES.
 (defun annotate-fixed-values-lvar (lvar types)
   (declare (type lvar lvar) (list types))
-  (aver (not (lvar-dynamic-extent lvar)))   ; XXX
-  (let ((res (make-ir2-lvar nil)))
-    (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
-    (setf (lvar-info lvar) res))
+  (let ((info (make-ir2-lvar nil)))
+    (setf (ir2-lvar-locs info) (mapcar #'make-normal-tn types))
+    (setf (lvar-info lvar) info)
+    (when (lvar-dynamic-extent lvar)
+      (aver (proper-list-of-length-p types 1))
+      (setf (ir2-lvar-stack-pointer info)
+            (make-stack-pointer-tn))))
   (ltn-annotate-casts lvar)
   (values))
 
@@ -402,6 +404,17 @@
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil))
+
+;;; Make sure that arguments of magic functions are not annotated.
+;;; (Otherwise the compiler may dump its internal structures as
+;;; constants :-()
+(defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy)
+  %lvar node ltn-policy)
+(defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved
+                                                       &rest moved)
+                                          node ltn-policy)
+  last-nipped last-preserved moved node ltn-policy)
+
 
 ;;;; known call annotation
 
@@ -809,7 +822,7 @@
   (when (and (cast-type-check cast)
              (not (node-lvar cast)))
     ;; FIXME
-    (bug "IR2 type checking of unused values in not implemented.")
+    (bug "IR2 type checking of unused values is not implemented.")
     )
   (values))