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

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 9dce8b5..619ebbc 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -67,13 +67,24 @@
 ;;; Return true if a constant LEAF is of a type which we can legally
 ;;; directly reference in code. Named constants with arbitrary pointer
 ;;; values cannot, since we must preserve EQLness.
+;;;
+;;; FIXME: why not?  The values in a function's constant vector are
+;;; subject to being moved by the garbage collector.  Having arbitrary
+;;; values in said vector doesn't seem like a problem.
 (defun legal-immediate-constant-p (leaf)
   (declare (type constant leaf))
   (or (not (leaf-has-source-name-p leaf))
-      (typecase (constant-value leaf)
-	((or number character) t)
-	(symbol (symbol-package (constant-value leaf)))
-	(t nil))))
+      ;; Specialized arrays are legal, too.  KLUDGE: this would be
+      ;; *much* cleaner if SIMPLE-UNBOXED-ARRAY was defined on the host.
+      #.(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+              unless (eq t (sb!vm:saetp-specifier saetp))
+              collect `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) t) into cases
+              finally (return
+                        `(typecase (constant-value leaf)
+                           ((or number character) t)
+                           (symbol (symbol-package (constant-value leaf)))
+                           ,@cases
+                           (t nil))))))
 
 ;;; If LVAR is used only by a REF to a leaf that can be delayed, then
 ;;; return the leaf, otherwise return NIL.
@@ -100,7 +111,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 +235,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 +415,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 +833,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))