0.8.9.27:

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 5d228d5..538e95a 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -220,6 +220,25 @@
       ((:inside-block)
        (node-ends-block (ctran-use ctran)))))
   (values))
+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+  (declare (type ctran ctran))
+  (aver (not (ctran-next ctran)))
+  (ecase (ctran-kind ctran)
+    (:inside-block
+     (let ((block (ctran-block ctran))
+           (node (ctran-use ctran)))
+       (aver (not (block-last block)))
+       (aver node)
+       (setf (block-last block) node)
+       (setf (node-next node) nil)
+       (setf (ctran-use ctran) nil)
+       (setf (ctran-kind ctran) :unused)
+       (setf (ctran-block ctran) nil)
+       (link-blocks block (ctran-starts-block ctran))))
+    (:block-start)))
 \f
 ;;;;
 
@@ -658,6 +677,30 @@
     (setf (block-prev next) block))
   (values))
 
+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block)
+  (loop for cleanup = (block-end-cleanup block)
+        then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+        while cleanup
+        do (let ((mess-up (cleanup-mess-up cleanup)))
+             (case (cleanup-kind cleanup)
+               ((:block :tagbody)
+                (aver (entry-p mess-up))
+                (loop for exit in (entry-exits mess-up)
+                      for nlx-info = (find-nlx-info exit)
+                      do (funcall fun nlx-info)))
+               ((:catch :unwind-protect)
+                (aver (combination-p mess-up))
+                (let* ((arg-lvar (first (basic-combination-args mess-up)))
+                       (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+                (funcall fun nlx-info)))))))
+
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
 (declaim (ftype (sfunction (component) (values)) clear-flags))
@@ -814,7 +857,16 @@
        (let ((bind-block (node-block bind)))
          (mark-for-deletion bind-block))
        (let ((home (lambda-home clambda)))
-         (setf (lambda-lets home) (delete clambda (lambda-lets home)))))
+         (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+       ;; KLUDGE: In presence of NLEs we cannot always understand that
+       ;; LET's BIND dominates its body [for a LET "its" body is not
+       ;; quite its]; let's delete too dangerous for IR2 stuff. --
+       ;; APD, 2004-01-01
+       (dolist (var (lambda-vars clambda))
+         (flet ((delete-node (node)
+                  (mark-for-deletion (node-block node))))
+         (mapc #'delete-node (leaf-refs var))
+         (mapc #'delete-node (lambda-var-sets var)))))
       (t
        ;; Function has no reachable references.
        (dolist (ref (lambda-refs clambda))
@@ -1322,8 +1374,8 @@
                (append before-args inside-args after-args))
          (change-ref-leaf (lvar-uses inside-fun)
                           (find-free-fun 'list "???"))
-         (setf (combination-kind inside)
-                (info :function :info 'list))
+         (setf (combination-fun-info inside) (info :function :info 'list)
+               (combination-kind inside) :known)
          (setf (node-derived-type inside) *wild-type*)
          (flush-dest lvar)
          (values))))))
@@ -1406,7 +1458,7 @@
                (flet ((frob (l)
                         (find home l
                               :key #'node-home-lambda
-                              :test-not #'eq)))
+                              :test #'neq)))
                  (or (frob (leaf-refs var))
                      (frob (basic-var-sets var)))))))))
 
@@ -1549,13 +1601,15 @@
   (declare (type combination call))
   (let ((kind (basic-combination-kind call)))
     (or (eq kind :full)
-        (and (fun-info-p kind)
-             (not (fun-info-ir2-convert kind))
-             (dolist (template (fun-info-templates kind) t)
-               (when (eq (template-ltn-policy template) :fast-safe)
-                 (multiple-value-bind (val win)
-                     (valid-fun-use call (template-type template))
-                   (when (or val (not win)) (return nil)))))))))
+        (and (eq kind :known)
+            (let ((info (basic-combination-fun-info call)))
+              (and
+               (not (fun-info-ir2-convert info))
+               (dolist (template (fun-info-templates info) t)
+                 (when (eq (template-ltn-policy template) :fast-safe)
+                   (multiple-value-bind (val win)
+                      (valid-fun-use call (template-type template))
+                     (when (or val (not win)) (return nil)))))))))))
 \f
 ;;;; careful call