0.8.18.20:

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 5126c04..5d74523 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -325,6 +325,26 @@
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+  (declare (type node next) (type lvar lvar) (type ctype type))
+  (with-ir1-environment-from-node next
+    (let* ((ctran (node-prev next))
+           (cast (make-cast lvar type policy))
+           (internal-ctran (make-ctran)))
+      (setf (ctran-next ctran) cast
+            (node-prev cast) ctran)
+      (use-ctran cast internal-ctran)
+      (link-node-to-previous-ctran next internal-ctran)
+      (setf (lvar-dest lvar) cast)
+      (reoptimize-lvar lvar)
+      (when (return-p next)
+        (node-ends-block cast))
+      (setf (block-attributep (block-flags (node-block cast))
+                              type-check type-asserted)
+            t)
+      cast)))
 \f
 ;;;; miscellaneous shorthand functions
 
@@ -984,6 +1004,9 @@
        (when (optional-dispatch-more-entry leaf)
          (frob (optional-dispatch-more-entry leaf)))
        (let ((main (optional-dispatch-main-entry leaf)))
+          (when entry
+            (setf (functional-entry-fun entry) main)
+            (setf (functional-entry-fun main) entry))
          (when (eq (functional-kind main) :optional)
            (frob main))))))
 
@@ -1330,15 +1353,21 @@
               (setf (node-prev node) nil)
               t)))))))
 
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+  (declare (type ctran ctran))
+  (let ((block (ctran-block ctran)))
+    (or (not (block-component block))
+        (block-delete-p block))))
+
 ;;; Return true if NODE has been deleted, false if it is still a valid
 ;;; part of IR1.
 (defun node-deleted (node)
   (declare (type node node))
   (let ((prev (node-prev node)))
-    (not (and prev
-             (let ((block (ctran-block prev)))
-               (and (block-component block)
-                    (not (block-delete-p block))))))))
+    (or (not prev)
+        (ctran-deleted-p prev))))
 
 ;;; Delete all the blocks and functions in COMPONENT. We scan first
 ;;; marking the blocks as DELETE-P to prevent weird stuff from being