UPGRADED-ARRAY-ELEMENT-TYPE: more thoroughly signal errors on unknown types.

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

diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp
index cd2525a..79ce6dc 100644 (file)
--- a/src/compiler/tn.lisp
+++ b/src/compiler/tn.lisp
@@ -204,15 +204,17 @@
   (let* ((immed (immediate-constant-sc (constant-value constant)))
          (use-immed-p (and immed
                            (or (not boxedp)
-                               (eql immed (sc-number-or-lose 'sb!vm::immediate))))))
+                               (boxed-immediate-sc-p immed)))))
     (cond
       ;; CONSTANT-TN uses two caches, one for boxed and one for unboxed uses.
       ;;
       ;; However, in the case of USE-IMMED-P we can have the same TN for both
       ;; uses. The first two legs here take care of that by cross-pollinating the
       ;; cached values.
-      ((and use-immed-p boxedp (leaf-info constant)))
-      ((and use-immed-p (not boxedp) (constant-boxed-tn constant)))
+      ;;
+      ;; Similarly, when there is no immediate SC.
+      ((and (or use-immed-p (not immed)) boxedp (leaf-info constant)))
+      ((and (or use-immed-p (not immed)) (not boxedp) (constant-boxed-tn constant)))
       (t
        (let* ((component (component-info *component-being-compiled*))
               (sc (svref *backend-sc-numbers*
@@ -341,11 +343,7 @@
            (type template template) (type tn x y))
   (let ((arg (reference-tn x nil))
         (result (reference-tn y t)))
-    (multiple-value-bind (first last)
-        (funcall (template-emit-function template) node block template arg
-                 result)
-      (insert-vop-sequence first last block before)
-      last)))
+    (emit-and-insert-vop node block template arg result before)))
 
 ;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
 (defun emit-load-template (node block template x y info &optional before)
@@ -353,11 +351,7 @@
            (type template template) (type tn x y))
   (let ((arg (reference-tn x nil))
         (result (reference-tn y t)))
-    (multiple-value-bind (first last)
-        (funcall (template-emit-function template) node block template arg
-                 result info)
-      (insert-vop-sequence first last block before)
-      last)))
+    (emit-and-insert-vop node block template arg result before info)))
 
 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
 (defun emit-move-arg-template (node block template x f y &optional before)
@@ -367,22 +361,14 @@
         (f-ref (reference-tn f nil))
         (y-ref (reference-tn y t)))
     (setf (tn-ref-across x-ref) f-ref)
-    (multiple-value-bind (first last)
-        (funcall (template-emit-function template) node block template x-ref
-                 y-ref)
-      (insert-vop-sequence first last block before)
-      last)))
+    (emit-and-insert-vop node block template x-ref y-ref before)))
 
 ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
 (defun emit-context-template (node block template y &optional before)
   (declare (type node node) (type ir2-block block)
            (type template template) (type tn y))
   (let ((y-ref (reference-tn y t)))
-    (multiple-value-bind (first last)
-        (funcall (template-emit-function template) node block template nil
-                 y-ref)
-      (insert-vop-sequence first last block before)
-      last)))
+    (emit-and-insert-vop node block template nil y-ref before)))
 
 ;;; Return the label marking the start of Block, assigning one if necessary.
 (defun block-label (block)
@@ -408,27 +394,33 @@
     (setf (ir2-block-dropped-thru-to 2block) t))
   nil)
 
-;;; Link a list of VOPs from First to Last into Block, Before the specified
-;;; VOP. If Before is NIL, insert at the end.
-(defun insert-vop-sequence (first last block before)
-  (declare (type vop first last) (type ir2-block block)
+;;; Insert a VOP into BLOCK, before the specified
+;;; BEFORE VOP. If BEFORE is NIL, insert at the end.
+(defun insert-vop (vop block before)
+  (declare (type vop vop) (type ir2-block block)
            (type (or vop null) before))
   (if before
       (let ((prev (vop-prev before)))
-        (setf (vop-prev first) prev)
+        (setf (vop-prev vop) prev)
         (if prev
-            (setf (vop-next prev) first)
-            (setf (ir2-block-start-vop block) first))
-        (setf (vop-next last) before)
-        (setf (vop-prev before) last))
+            (setf (vop-next prev) vop)
+            (setf (ir2-block-start-vop block) vop))
+        (setf (vop-next vop) before)
+        (setf (vop-prev before) vop))
       (let ((current (ir2-block-last-vop block)))
-        (setf (vop-prev first) current)
-        (setf (ir2-block-last-vop block) last)
+        (setf (vop-prev vop) current)
+        (setf (ir2-block-last-vop block) vop)
         (if current
-            (setf (vop-next current) first)
-            (setf (ir2-block-start-vop block) first))))
+            (setf (vop-next current) vop)
+            (setf (ir2-block-start-vop block) vop))))
   (values))
 
+(defun emit-and-insert-vop (node block template arg result before
+                            &optional info)
+  (let ((vop (emit-vop node block template arg result info)))
+    (insert-vop vop block before)
+    vop))
+
 ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
 (defun delete-vop (vop)
   (declare (type vop vop))