0.7.3.6:

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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 822178a..3572089 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -239,15 +239,27 @@
   (do-blocks (block component)
     (cond
      ((or (block-delete-p block)
-         (null (block-pred block))
-         (eq (functional-kind (block-home-lambda block)) :deleted))
+         (null (block-pred block)))
       (delete-block block))
+     ((eq (functional-kind (block-home-lambda block)) :deleted)
+      ;; Preserve the BLOCK-SUCC invariant that almost every block has
+      ;; one successor (and a block with DELETE-P set is an acceptable
+      ;; exception).
+      (labels ((mark-blocks (block)
+                 (dolist (pred (block-pred block))
+                   (when (and (not (block-delete-p pred))
+                              (eq (functional-kind (block-home-lambda pred))
+                                  :deleted))
+                     (setf (block-delete-p pred) t)
+                     (mark-blocks pred)))))
+        (mark-blocks block)
+        (delete-block block)))
      (t
       (loop
        (let ((succ (block-succ block)))
          (unless (and succ (null (rest succ)))
            (return)))
-       
+
        (let ((last (block-last block)))
          (typecase last
            (cif
@@ -257,8 +269,8 @@
            (exit
             (when (maybe-delete-exit last)
               (return)))))
-       
-       (unless (join-successor-if-possible block)
+
+        (unless (join-successor-if-possible block)
          (return)))
 
       (when (and (block-reoptimize block) (block-component block))
@@ -982,20 +994,7 @@
                    (policy node (>= speed inhibit-warnings))
                    (policy node (> speed inhibit-warnings))))
         (*compiler-error-context* node))
-    (cond ((not (member (transform-when transform)
-                       '(:native :both)))
-          ;; FIXME: Make sure that there's a transform for
-          ;; (MEMBER SYMBOL ..) into MEMQ.
-          ;; FIXME: Note that when/if I make SHARE operation to shared
-          ;; constant data between objects in the system, remember that a
-          ;; SHAREd list, or other SHAREd compound object, can be processed
-          ;; recursively, so that e.g. the two lists above can share their
-          ;; '(:BOTH) tail sublists.
-          (let ((when (transform-when transform)))
-            (not (or (eq when :both)
-                     (eq when :native))))
-          t)
-         ((or (not constrained)
+    (cond ((or (not constrained)
               (valid-fun-use node type :strict-result t))
           (multiple-value-bind (severity args)
               (catch 'give-up-ir1-transform