From 3438a42f6e5c51b64f8ace7bec03e7183d91aa66 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 5 Oct 1990 19:53:10 +0000
Subject: [PATCH] Added stuff to make DELETE-BLOCK print a note when it seems
 that we are deleting code which appeared in the original source.

---
 compiler/ir1util.lisp | 78 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)

diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index bc14e6ada..bcfca19a8 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -817,6 +817,83 @@ inlines
   (undefined-value))
 
 
+(defvar *deletion-ignored-objects* '(t nil))
+
+;;; PRESENT-IN-FORM  --  Internal
+;;;
+;;;    Return true if we can find Obj in Form, NIL otherwise.  We bound our
+;;; recursion so that we don't get lost in circular structures.  We ignore the
+;;; car of forms if they are a symbol (to prevent confusing function
+;;; referencess with variables), and we also ignore anything inside ' or #'.
+;;;
+(defun present-in-form (obj form depth)
+  (declare (type (integer 0 20) depth))
+  (cond ((= depth 20) nil)
+	((eq obj form) t)
+	((atom form) nil)
+	(t
+	 (let ((first (car form))
+	       (depth (1+ depth)))
+	   (if (member first '(quote function))
+	       nil
+	       (or (and (not (symbolp first))
+			(present-in-form obj first depth))
+		   (do ((l (cdr form) (cdr l))
+			(n 0 (1+ n)))
+		       ((or (atom l) (> n 100))
+			nil)
+		     (declare (fixnum n))
+		     (when (present-in-form obj (car l) depth)
+		       (return t)))))))))
+
+
+;;; NOTE-BLOCK-DELETION  --  Internal
+;;;
+;;;    This function is called on a block immediately before we delete it.  We
+;;; check to see if any of the code about to die appeared in the original
+;;; source, and emit a note if so.
+;;;
+;;;    If the block was in a lambda is now deleted, but used to be a
+;;; optional-dispatch entry point or XEP, then we ignore the whole block.  We
+;;; also ignore the deletion of CRETURN nodes, since it is somewhat reasonable
+;;; for a function to not return, and there is a different note for that case
+;;; anyway.
+;;;
+;;;    If the actual source is an atom, then we use a bunch of heuristics to
+;;; guess whether this reference really appeared in the original source:
+;;; -- If a symbol, it must be interned.
+;;; -- It must not be an easily introduced constant (T or NIL).
+;;; -- The atom must be "present" in the original source form, and present in
+;;;    all intervening actual source forms.
+;;;
+(defun note-block-deletion (block)
+  (let ((home (block-home-lambda block)))
+    (unless (and (eq (functional-kind home) :deleted)
+		 (or (functional-entry-function home)
+		     (let ((od (lambda-optional-dispatch home)))
+		       (and od
+			    (not (eq (optional-dispatch-main-entry od)
+				     home))))))
+      (do-nodes (node cont block)
+	(let* ((path (node-source-path node))
+	       (first (first path)))
+	  (when (or (eq first 'original-source-start)
+		    (and (atom first)
+			 (or (not (symbolp first))
+			     (symbol-package first))
+			 (not (member first *deletion-ignored-objects*))
+			 (every #'(lambda (x)
+				    (present-in-form first x 0))
+				(source-path-forms path))
+			 (present-in-form first (find-original-source path)
+					  0)))
+	    (unless (return-p node)
+	      (let ((*compiler-error-context* node))
+		(compiler-note "Deleting unreachable code.")))
+	    (return))))))
+  (undefined-value))
+
+
 ;;; Delete-Block  --  Interface
 ;;;
 ;;;    This function does what is necessary to eliminate the code in it from
@@ -830,6 +907,7 @@ inlines
 (defun delete-block (block)
   (declare (type cblock block))
   (assert (block-component block) () "Block is already deleted.")
+  (note-block-deletion block)
   (setf (block-delete-p block) t)
 
   (let* ((last (block-last block))
-- 
GitLab