X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f034d4ad83d95cd84977769fe079b90ff4e7b72e;hb=422b88abf96f4842a3d0999cd3b80d96f5a153d6;hp=822178a450c83148fb964263151af9ac7854af65;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 822178a..f034d4a 100644
--- 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
@@ -1138,7 +1137,42 @@
   (let ((args (mapcar #'continuation-value (combination-args call)))
 	(fun-name (combination-fun-source-name call)))
     (multiple-value-bind (values win)
-	(careful-call fun-name args call "constant folding")
+	(careful-call fun-name
+		      args
+		      call
+		      ;; Note: CMU CL had COMPILER-WARN here, and that
+		      ;; seems more natural, but it's probably not.
+		      ;;
+		      ;; It's especially not while bug 173 exists:
+		      ;; Expressions like
+		      ;;   (COND (END
+		      ;;          (UNLESS (OR UNSAFE? (<= END SIZE)))
+		      ;;            ...))
+		      ;; can cause constant-folding TYPE-ERRORs (in
+		      ;; #'<=) when END can be proved to be NIL, even
+		      ;; though the code is perfectly legal and safe
+		      ;; because a NIL value of END means that the
+		      ;; #'<= will never be executed.
+		      ;;
+		      ;; Moreover, even without bug 173,
+		      ;; quite-possibly-valid code like
+		      ;;   (COND ((NONINLINED-PREDICATE END)
+		      ;;          (UNLESS (<= END SIZE))
+		      ;;            ...))
+		      ;; (where NONINLINED-PREDICATE is something the
+		      ;; compiler can't do at compile time, but which
+		      ;; turns out to make the #'<= expression
+		      ;; unreachable when END=NIL) could cause errors
+		      ;; when the compiler tries to constant-fold (<=
+		      ;; END SIZE).
+		      ;;
+		      ;; So, with or without bug 173, it'd be 
+		      ;; unnecessarily evil to do a full
+		      ;; COMPILER-WARNING (and thus return FAILURE-P=T
+		      ;; from COMPILE-FILE) for legal code, so we we
+		      ;; use a wimpier COMPILE-STYLE-WARNING instead.
+		      #'compiler-style-warn
+		      "constant folding")
       (if (not win)
 	  (setf (combination-kind call) :error)
 	  (let ((dummies (make-gensym-list (length args))))
@@ -1194,7 +1228,7 @@
   (derive-node-type node (continuation-type (set-value node)))
   (values))
 
-;;; Return true if the value of Ref will always be the same (and is
+;;; Return true if the value of REF will always be the same (and is
 ;;; thus legal to substitute.)
 (defun constant-reference-p (ref)
   (declare (type ref ref))