From 5d00555f7087a49047fe6b7e20b185256b6fe8c6 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Thu, 2 Oct 2003 19:23:11 +0000
Subject: [PATCH] 	(compile nil 	  '(lambda (c) (declare (optimize
 (speed 3) (debug 1))) 	     (flet ((%f18 () -36)) 	        (flet ((%f13
 () (let () (block b8 (return-from b8 c))))) 	          (%f18))))) 	 =>
 error nil is not an integer, in dump-1-variable

	Found by Paul Dietz.

	This is caused by a lambda-var being passed to dump-1-variable
	which hasn't been packed, and so has a null tn-offset.  A ref to
	this lambda-var remains at this point because it is referenced
	from a different component.  The ref is deleted when that
	component is compiled.  The problem is that there shouldn't have
	been two components to begin with, which we prevent by recording
	additional DFO dependencies for closed-over variables and entries.

	Port from SBCL, basically.

	Does not require a bootstrap file, but a full build is necessary
	due to the renamed clambda structure slot.

	* src/compiler/dfo.lisp (dfo-walk-call-graph): Process
	new dfo dependencies.

	* src/compiler/node.lisp (clambda): Rename slot `calls'
	to `dfo-dependencies'.

	* src/compiler/locall.lisp (convert-call, convert-mv-call):
	Call note-dfo-dependency.
	(merge-lets): Change for new clambda slot name.
	(unconvert-tail-calls): Handle the case of non-clambdas in
	the dfo dependencies.

	* src/compiler/ir1util.lisp (continuation-home-lambda)
	(note-dfo-dependency): New functions.

	* src/compiler/ir1tran.lisp (ir1-convert-variable)
	(return-from, go, setq): Call note-dfo-dependency.

	* src/compiler/xref.lisp (lambda-called-p): New function.
	(prettiest-caller-name): Use lambda-called-p instead of
	lambda-calls.
---
 compiler/dfo.lisp     | 65 ++++++++++++++++++++++++-------------------
 compiler/ir1tran.lisp | 19 ++++++++-----
 compiler/ir1util.lisp | 20 ++++++++++++-
 compiler/locall.lisp  | 54 ++++++++++++++++++-----------------
 compiler/node.lisp    | 12 ++++++--
 compiler/xref.lisp    |  9 ++++--
 6 files changed, 111 insertions(+), 68 deletions(-)

diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp
index af3eb9c08..a188d22bb 100644
--- a/compiler/dfo.lisp
+++ b/compiler/dfo.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.26 2000/07/07 09:33:01 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.27 2003/10/02 19:23:11 gerd Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -241,33 +241,42 @@
   (let* ((bind-block (node-block (lambda-bind fun)))
 	 (this (block-component bind-block))
 	 (return (lambda-return fun)))
-    (cond
-     ((eq this component) component)
-     ((not (eq (component-kind this) :initial))
-      (join-components this component)
-      this)
-     ((block-flag bind-block)
-      component)
-     (t
-      (push fun (component-lambdas component))
-      (setf (component-lambdas this)
-	    (delete fun (component-lambdas this)))
-      (link-blocks (component-head component) bind-block)
-      (unlink-blocks (component-head this) bind-block)
-      (when return
-	(let ((return-block (node-block return)))
-	  (link-blocks return-block (component-tail component))
-	  (unlink-blocks return-block (component-tail this))))
-      (let ((calls (if (eq (functional-kind fun) :external)
-		       (append (find-reference-functions fun)
-			       (lambda-calls fun))
-		       (lambda-calls fun))))
-	(do ((res (find-initial-dfo-aux bind-block component)
-		  (dfo-walk-call-graph (first funs) res))
-	     (funs calls (rest funs)))
-	    ((null funs) res)
-	  (declare (type component res))))))))
-
+    (cond ((eq this component)
+	   component)
+	  ((not (eq (component-kind this) :initial))
+	   (join-components this component)
+	   this)
+	  ((block-flag bind-block)
+	   component)
+	  (t
+	   (push fun (component-lambdas component))
+	   (setf (component-lambdas this)
+		 (delete fun (component-lambdas this)))
+	   (link-blocks (component-head component) bind-block)
+	   (unlink-blocks (component-head this) bind-block)
+	   (when return
+	     (let ((return-block (node-block return)))
+	       (link-blocks return-block (component-tail component))
+	       (unlink-blocks return-block (component-tail this))))
+	   (let ((res (find-initial-dfo-aux bind-block component)))
+	     (declare (type component res))
+	     (flet ((walk (clambda)
+		      (unless (eq (lambda-kind clambda) :deleted)
+			(let ((home (lambda-home clambda)))
+			  (setq res (dfo-walk-call-graph home res))))))
+	       (dolist (dd (lambda-dfo-dependencies fun))
+		 (etypecase dd
+		   (clambda
+		    (walk dd))
+		   (lambda-var
+		    (unless (null (lambda-var-refs dd))
+		      (walk (lambda-home (lambda-var-home dd)))))
+		   (entry
+		    (walk (node-home-lambda dd)))))
+	       (when (eq (lambda-kind fun) :external)
+		 (dolist (lambda (find-reference-functions fun))
+		   (walk lambda))))
+	     res)))))
 
 ;;; HAS-XEP-OR-NLX  --  Internal
 ;;;
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 0c0f83cc2..61beb85b7 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.164 2003/09/14 10:13:27 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.165 2003/10/02 19:23:11 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -145,7 +145,7 @@
 ;;;; Dynamic-Extent
 
 (defvar *trust-dynamic-extent-declarations* nil
-  "If null, don't trust dynamic-extent declarations.
+  "If NIL, never trust dynamic-extent declarations.
 
    If T, always trust dynamic-extent declarations.
 
@@ -794,8 +794,10 @@
   (let ((var (or (lexenv-find name variables) (find-free-variable name))))
     (etypecase var
       (leaf
-       (when (and (lambda-var-p var) (lambda-var-ignorep var))
-	 (compiler-note "Reading an ignored variable: ~S." name))
+       (when (lambda-var-p var)
+	 (when (lambda-var-ignorep var)
+	   (compiler-note "Reading an ignored variable: ~S." name))
+	 (note-dfo-dependency start var))
        (reference-leaf start cont var))
       (cons
        (assert (eq (car var) 'MACRO))
@@ -2325,6 +2327,7 @@
     (setf (continuation-dest value-cont) exit)
     (ir1-convert start value-cont value)
     (prev-link exit value-cont)
+    (note-dfo-dependency start entry)
     (use-continuation exit (cont-ref-cont (second found)))))
 
 
@@ -2415,6 +2418,7 @@
 	 (exit (make-exit :entry entry)))
     (push exit (entry-exits entry))
     (prev-link exit start)
+    (note-dfo-dependency start entry)
     (use-continuation exit (cont-ref-cont (second found)))))
 
 
@@ -3268,9 +3272,10 @@
 		       (and (global-var-p leaf)
 			    (eq (global-var-kind leaf) :constant)))
 	       (compiler-error "Attempt to set constant ~S." name))
-	     (when (and (lambda-var-p leaf)
-			(lambda-var-ignorep leaf))
-	       (compiler-note "Setting an ignored variable: ~S." name))
+	     (when (lambda-var-p leaf)
+	       (when (lambda-var-ignorep leaf)
+		 (compiler-note "Setting an ignored variable: ~S." name))
+	       (note-dfo-dependency start leaf))
 	     (set-variable start cont leaf (second things)))
 	    (cons
 	     (assert (eq (car leaf) 'MACRO))
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index 7306f17f4..eb029350b 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.94 2003/08/16 11:45:47 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.95 2003/10/02 19:23:11 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2194,3 +2194,21 @@ these can be NIL if unavailable or inapplicable.")
 
   (let ((action (event-info-action info)))
     (when action (funcall action node))))
+
+(defun continuation-home-lambda (cont)
+  (if (continuation-use cont)
+      (node-home-lambda (continuation-use cont))
+      (let* ((block (continuation-block cont))
+	     (last-node (block-last block)))
+	(when last-node
+	  (node-home-lambda last-node)))))
+
+(defun note-dfo-dependency (dependent thing)
+  (declare (type (or lambda-var clambda entry) thing))
+  (let ((home (etypecase dependent
+		(node
+		 (node-home-lambda dependent))
+		(continuation
+		 (continuation-home-lambda dependent)))))
+    (when home
+      (pushnew thing (lambda-dfo-dependencies home)))))
diff --git a/compiler/locall.lisp b/compiler/locall.lisp
index 28a9ea27e..ebde6169e 100644
--- a/compiler/locall.lisp
+++ b/compiler/locall.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.54 2003/08/05 14:04:52 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.55 2003/10/02 19:23:11 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -102,7 +102,7 @@
   (declare (type ref ref) (type combination call) (type clambda fun))
   (propagate-to-args call fun)
   (setf (basic-combination-kind call) :local)
-  (pushnew fun (lambda-calls (node-home-lambda call)))
+  (note-dfo-dependency call fun)
   (merge-tail-sets call fun)
   (change-ref-leaf ref fun)
   (undefined-value))
@@ -432,7 +432,7 @@
 	     (= (length (basic-combination-args call)) 1))
     (let ((ep (car (last (optional-dispatch-entry-points fun)))))
       (setf (basic-combination-kind call) :local)
-      (pushnew ep (lambda-calls (node-home-lambda call)))
+      (note-dfo-dependency call ep)
       (merge-tail-sets call ep)
       (change-ref-leaf ref ep)
       
@@ -758,11 +758,12 @@
 
     ;; HOME no longer calls FUN, and owns all of FUN's old DFO
     ;; dependencies
-    (setf (lambda-calls home)
-	  (delete fun (nunion (lambda-calls fun) (lambda-calls home))))
+    (setf (lambda-dfo-dependencies home)
+	  (delete fun (nunion (lambda-dfo-dependencies fun)
+			      (lambda-dfo-dependencies home))))
     ;; FUN no longer has an independent existence as an entity
     ;; which calls things or has DFO dependencies.
-    (setf (lambda-calls fun) ())
+    (setf (lambda-dfo-dependencies fun) ())
 
     ;; All of FUN's ENTRIES belong to HOME now.
     (setf (lambda-entries home)
@@ -837,28 +838,29 @@
 ;;;
 ;;;    The called function might be an assignment in the case where we are
 ;;; currently converting that function.  In steady-state, assignments never
-;;; appear in the lambda-calls.
+;;; appear in the lambda-dfo-dependencies.
 ;;;
 (defun unconvert-tail-calls (fun call next-block)
-  (dolist (called (lambda-calls fun))
-    (dolist (ref (leaf-refs called))
-      (let ((this-call (continuation-dest (node-cont ref))))
-	(when (and (node-tail-p this-call)
-		   (eq (node-home-lambda this-call) fun))
-	  (setf (node-tail-p this-call) nil)
-	  (ecase (functional-kind called)
-	    ((nil :cleanup :optional)
-	     (let ((block (node-block this-call))
-		   (cont (node-cont call)))
-	       (ensure-block-start cont)
-	       (unlink-blocks block (first (block-succ block)))
-	       (link-blocks block next-block)
-	       (delete-continuation-use this-call)
-	       (add-continuation-use this-call cont)))
-	    (:deleted)
-	    (:assignment
-	     (assert (eq called fun))))))))
-  (undefined-value))
+  (dolist (called (lambda-dfo-dependencies fun))
+    (when (lambda-p called)
+      (dolist (ref (leaf-refs called))
+	(let ((this-call (continuation-dest (node-cont ref))))
+	  (when (and (node-tail-p this-call)
+		     (eq (node-home-lambda this-call) fun))
+	    (setf (node-tail-p this-call) nil)
+	    (ecase (functional-kind called)
+	      ((nil :cleanup :optional)
+	       (let ((block (node-block this-call))
+		     (cont (node-cont call)))
+		 (ensure-block-start cont)
+		 (unlink-blocks block (first (block-succ block)))
+		 (link-blocks block next-block)
+		 (delete-continuation-use this-call)
+		 (add-continuation-use this-call cont)))
+	      (:deleted)
+	      (:assignment
+	       (assert (eq called fun)))))))))
+  (values))
 
 
 ;;; MOVE-RETURN-STUFF  --  Internal
diff --git a/compiler/node.lisp b/compiler/node.lisp
index c87b35177..7df863f42 100644
--- a/compiler/node.lisp
+++ b/compiler/node.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.43 2003/08/25 20:50:59 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.44 2003/10/02 19:23:11 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -936,10 +936,16 @@
   ;; let.
   (entries () :type list)
   ;;
-  ;; A list of all the functions directly called from this function (or one of
+  ;; A list of leafs and nodes determining this lambda's dfo.
+  ;;
+  ;; - Clambdas directly called from this function (or one of
   ;; its lets) using a non-let local call.  May include deleted functions
   ;; because nobody bothers to clear them out.
-  (calls () :type list)
+  ;;
+  ;; - Lambda-Vars used
+  ;;
+  ;; - Entries
+  (dfo-dependencies () :type list)
   ;;
   ;; The Tail-Set that this lambda is in.  Null during creation and in let
   ;; lambdas.
diff --git a/compiler/xref.lisp b/compiler/xref.lisp
index 9ad58487a..ea192bdca 100644
--- a/compiler/xref.lisp
+++ b/compiler/xref.lisp
@@ -3,7 +3,7 @@
 ;;; Author: Eric Marsden <emarsden@laas.fr>
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.4 2003/06/11 12:58:08 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/xref.lisp,v 1.5 2003/10/02 19:23:11 gerd Exp $")
 ;;
 ;; This code was written as part of the CMUCL project and has been
 ;; placed in the public domain.
@@ -197,6 +197,9 @@ be set at runtime."
 
 (in-package :compiler)
 
+(defun lambda-contains-calls-p (clambda)
+  (declare (type clambda clambda))
+  (some #'lambda-p (lambda-dfo-dependencies clambda)))
 
 (defun prettiest-caller-name (lambda-node toplevel-name)
   (cond
@@ -207,7 +210,7 @@ be set at runtime."
     ;; If the home slot contains a lambda with a nice name, we use
     ;; that; otherwise fall back on the toplevel-name.
     ((or (not (eq (lambda-home lambda-node) lambda-node))
-         (lambda-calls lambda-node))
+         (lambda-contains-calls-p lambda-node))
      (let ((home (lambda-name (lambda-home lambda-node)))
            (here (lambda-name lambda-node)))
        (cond ((and home here)
@@ -244,7 +247,7 @@ be set at runtime."
             (list :internal
                   (lambda-name (lambda-home lambda-node))
                   (lambda-name lambda-node)))
-           ((lambda-calls lambda-node)
+           ((lambda-contains-calls-p lambda-node)
             (list :internal/calls
                   (lambda-name (lambda-home lambda-node))
                   (lambda-name lambda-node)))
-- 
GitLab