From 14538e006c43facf52e17e452cb1164077bbafd3 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Sat, 8 Jun 2013 01:31:22 -0400
Subject: [PATCH] Look for left-over dead code when *check-consistency*

 If ir1opt leaves dead code around, later parts of the compilation
 pipeline can become seriously confused.  Detect such issues earlier,
 rather than as mysterious failures.
---
 src/compiler/ir1opt.lisp |   10 ++++++++--
 src/compiler/main.lisp   |    7 +++++++
 2 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 7f44b64..f984621 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -522,17 +522,19 @@
 ;;; Delete any nodes in BLOCK whose value is unused and which have no
 ;;; side effects. We can delete sets of lexical variables when the set
 ;;; variable has no references.
-(defun flush-dead-code (block)
+(defun flush-dead-code (block &aux victim)
   (declare (type cblock block))
   (setf (block-flush-p block) nil)
   (do-nodes-backwards (node lvar block :restart-p t)
     (unless lvar
       (typecase node
         (ref
+         (setf victim node)
          (delete-ref node)
          (unlink-node node))
         (combination
          (when (flushable-combination-p node)
+           (setf victim node)
            (flush-combination node)))
         (mv-combination
          (when (eq (basic-combination-kind node) :local)
@@ -541,27 +543,31 @@
                      (when (or (leaf-refs var)
                                (lambda-var-sets var))
                        (return nil)))
+               (setf victim node)
                (flush-dest (first (basic-combination-args node)))
                (delete-let fun)))))
         (exit
          (let ((value (exit-value node)))
            (when value
+             (setf victim node)
              (flush-dest value)
              (setf (exit-value node) nil))))
         (cset
          (let ((var (set-var node)))
            (when (and (lambda-var-p var)
                       (null (leaf-refs var)))
+             (setf victim node)
              (flush-dest (set-value node))
              (setf (basic-var-sets var)
                    (delq node (basic-var-sets var)))
              (unlink-node node))))
         (cast
          (unless (cast-type-check node)
+           (setf victim node)
            (flush-dest (cast-value node))
            (unlink-node node))))))
 
-  (values))
+  victim)
 
 ;;;; local call return type propagation
 
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 1223388..1bec50e 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -526,6 +526,13 @@ Examples:
         (return))
       (incf loop-count)))
 
+  (when *check-consistency*
+    (do-blocks-backwards (block component)
+      (awhen (flush-dead-code block)
+        (let ((*compiler-error-context* it))
+          (compiler-warn "dead code detected at the end of ~S"
+                         'ir1-phases)))))
+
   (ir1-finalize component)
   (values))
 
-- 
1.7.10.4