X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=5d74523af8a4ada18b832eff22d42fefa6b2e1c3;hb=fae139755a81c0431e7f12f2af9b5f3abc1326dc;hp=a5e8c16bee8239aa6c1d009347b91c22dc84d2f8;hpb=b3e7d6608689a639cb774e2ce15bb5bacaed5179;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index a5e8c16..5d74523 100644
--- 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)))
 
 ;;;; 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))))))