X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=b62fb36b20659786f3c3aa9dc36911d114a9145e;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=1914d04a2cf1e6711a878872233444c3f695013a;hpb=4d5d7a4d8451095eac7384e3a8d14d10f59c5e0c;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 1914d04..b62fb36 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -276,8 +276,7 @@
         (dolist (block (block-pred old-block))
           (change-block-successor block old-block new-block))
 
-        (ir1-convert new-start ctran filtered-lvar
-                     `(locally (declare (optimize (insert-step-conditions 0))) ,form))
+        (ir1-convert new-start ctran filtered-lvar form)
 
         ;; KLUDGE: Comments at the head of this function in CMU CL
         ;; said that somewhere in here we
@@ -326,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
 
@@ -673,7 +692,7 @@
 	   (frob if-alternative)
            (when (eq (if-consequent last)
                      (if-alternative last))
-             (setf (component-reoptimize (block-component block)) t)))))
+             (reoptimize-component (block-component block) :maybe)))))
       (t
        (unless (memq new (block-succ block))
 	 (link-blocks block new)))))
@@ -721,7 +740,7 @@
                ((:block :tagbody)
                 (aver (entry-p mess-up))
                 (loop for exit in (entry-exits mess-up)
-                      for nlx-info = (find-nlx-info exit)
+                      for nlx-info = (exit-nlx-info exit)
                       do (funcall fun nlx-info)))
                ((:catch :unwind-protect)
                 (aver (combination-p mess-up))
@@ -985,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))))))
 
@@ -1037,7 +1059,7 @@
     (do-uses (use lvar)
       (let ((prev (node-prev use)))
 	(let ((block (ctran-block prev)))
-          (setf (component-reoptimize (block-component block)) t)
+          (reoptimize-component (block-component block) t)
           (setf (block-attributep (block-flags block)
                                   flush-p type-asserted type-check)
                 t)))
@@ -1331,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
@@ -1503,10 +1531,17 @@
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))
-  (let ((entry (exit-entry exit)))
+  (let* ((entry (exit-entry exit))
+         (cleanup (entry-cleanup entry))
+        (block (first (block-succ (node-block exit)))))
     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
-      (when (eq (nlx-info-exit nlx) exit)
+      (when (and (eq (nlx-info-block nlx) block)
+                 (eq (nlx-info-cleanup nlx) cleanup))
 	(return nlx)))))
+
+(defun nlx-info-lvar (nlx)
+  (declare (type nlx-info nlx))
+  (node-lvar (block-last (nlx-info-target nlx))))
 
 ;;;; functional hackery
 
@@ -1613,8 +1648,8 @@
 	   ;; arbitrarily huge blocks of code. -- WHN)
 	   (let ((*compiler-error-context* node))
 	     (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
-			       probably trying to~%  ~
-			       inline a recursive function."
+                               probably trying to~%  ~
+                               inline a recursive function."
 			      *inline-expansion-limit*))
 	   nil)
 	  (t t))))
@@ -1774,4 +1809,4 @@
              (do-uses (node lvar)
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
-               (setf (component-reoptimize (node-component node)) t)))))))
+               (reoptimize-component (node-component node) :maybe)))))))