0.8.21.28:

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

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 794e135..a721dee 100644 (file)
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -98,8 +98,12 @@
     (cond
      ((lvar-delayed-leaf lvar)
       (setf (ir2-lvar-kind info) :delayed))
-     (t (setf (ir2-lvar-locs info)
-              (list (make-normal-tn (ir2-lvar-primitive-type info)))))))
+     (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)))))))
   (ltn-annotate-casts lvar)
   (values))
 
@@ -118,6 +122,7 @@
 ;;; reference, otherwise we annotate for a single value.
 (defun annotate-fun-lvar (lvar &optional (delay t))
   (declare (type lvar lvar))
+  (aver (not (lvar-dynamic-extent lvar)))
   (let* ((tn-ptype (primitive-type (lvar-type lvar)))
         (info (make-ir2-lvar tn-ptype)))
     (setf (lvar-info lvar) info)
@@ -195,6 +200,7 @@
 (defun annotate-unknown-values-lvar (lvar)
   (declare (type lvar lvar))
 
+  (aver (not (lvar-dynamic-extent lvar)))
   (let ((2lvar (make-ir2-lvar nil)))
     (setf (ir2-lvar-kind 2lvar) :unknown)
     (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
@@ -219,9 +225,14 @@
 ;;; specified primitive TYPES.
 (defun annotate-fixed-values-lvar (lvar types)
   (declare (type lvar lvar) (list types))
-  (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))
+      #!+stack-grows-downward-not-upward
+      (setf (ir2-lvar-stack-pointer info)
+            (make-stack-pointer-tn))))
   (ltn-annotate-casts lvar)
   (values))
 \f
@@ -313,8 +324,7 @@
           (setf (node-tail-p call) nil))
          (t
           (setf (basic-combination-info call) :full)
-          (annotate-fun-lvar (basic-combination-fun call)
-                                     nil)
+          (annotate-fun-lvar (basic-combination-fun call) nil)
           (dolist (arg (reverse args))
             (annotate-unknown-values-lvar arg))
           (flush-full-call-tail-transfer call))))
@@ -396,6 +406,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)
+
 \f
 ;;;; known call annotation
 
@@ -434,6 +455,7 @@
 (defun template-args-ok (template call safe-p)
   (declare (type template template)
           (type combination call))
+  (declare (ignore safe-p))
   (let ((mtype (template-more-args-type template)))
     (do ((args (basic-combination-args call) (cdr args))
         (types (template-arg-types template) (cdr types)))
@@ -695,13 +717,13 @@
 
     (when (losers)
       (collect ((messages)
-               (count 0 +))
+               (notes 0 +))
        (flet ((lose1 (string &rest stuff)
                 (messages string)
                 (messages stuff)))
          (dolist (loser (losers))
            (when (and *efficiency-note-limit*
-                      (>= (count) *efficiency-note-limit*))
+                      (>= (notes) *efficiency-note-limit*))
              (lose1 "etc.")
              (return))
            (let* ((type (template-type loser))
@@ -720,7 +742,7 @@
               (t
                (aver (ltn-policy-safe-p ltn-policy))
                (lose1 "can't trust output type assertion under safe policy")))
-             (count 1))))
+             (notes 1))))
 
        (let ((*compiler-error-context* call))
          (compiler-notify "~{~?~^~&~6T~}"
@@ -802,7 +824,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))