From bfbe4f7ee017f7dfad7bb96e81e19490c1a960cc Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 18 Jun 2000 15:45:31 +0000
Subject: [PATCH] Ensure that continuation references stored within the lexical
 environment, for block exits and tagbody entries, are updated when
 continuations are substituted. Add a cont-ref structure, and a new slot to
 continuations which holds the list of these references to be be updated when
 the continuation is substituted. Based on the work of Tim Moore.

---
 compiler/alloc.lisp   |  3 ++-
 compiler/ir1tran.lisp | 19 +++++++++++--------
 compiler/ir1util.lisp |  7 +++++--
 compiler/node.lisp    | 21 ++++++++++++++++++++-
 4 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/compiler/alloc.lisp b/compiler/alloc.lisp
index 29e54b0d9..0dd4eaea1 100644
--- a/compiler/alloc.lisp
+++ b/compiler/alloc.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/alloc.lisp,v 1.12 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alloc.lisp,v 1.13 2000/06/18 15:45:30 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -117,6 +117,7 @@
     (setf (continuation-asserted-type structure) *wild-type*)
     (setf (continuation-%derived-type structure) nil)
     (setf (continuation-use structure) nil)
+    (setf (continuation-refs structure) nil)
     (setf (continuation-block structure) nil)
     (setf (continuation-reoptimize structure) t)
     (setf (continuation-%type-check structure) t))
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index fe78a8f1c..a4f228a9b 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.113 2000/02/28 18:36:33 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.114 2000/06/18 15:45:30 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2068,9 +2068,11 @@
     (setf (entry-cleanup entry) cleanup)
     (prev-link entry start)
     (use-continuation entry dummy)
-    (let ((*lexical-environment*
-	   (make-lexenv :blocks (list (cons name (list entry cont)))
-			:cleanup cleanup)))
+    (let* ((cont-ref (make-cont-ref :cont cont))
+	   (*lexical-environment*
+	    (make-lexenv :blocks (list (cons name (list entry cont-ref)))
+			 :cleanup cleanup)))
+      (push cont-ref (continuation-refs cont))
       (ir1-convert-progn-body dummy cont forms))))
 
 ;;; We make Cont start a block just so that it will have a block assigned.
@@ -2093,7 +2095,7 @@
     (setf (continuation-dest value-cont) exit)
     (ir1-convert start value-cont value)
     (prev-link exit value-cont)
-    (use-continuation exit (second found))))
+    (use-continuation exit (cont-ref-cont (second found)))))
 
 
 ;;; Parse-Tagbody  --  Internal
@@ -2153,11 +2155,12 @@
 	      (conts))
       (starts dummy)
       (dolist (segment (rest segments))
-	(let ((tag-cont (make-continuation)))
+	(let* ((tag-cont (make-continuation))
+	       (tag-cont-ref (make-cont-ref :cont tag-cont)))
 	  (conts tag-cont)
 	  (starts tag-cont)
 	  (continuation-starts-block tag-cont)
-	  (tags (list (car segment) entry tag-cont))))
+	  (tags (list (car segment) entry tag-cont-ref))))
       (conts cont)
       
       (let ((*lexical-environment*
@@ -2182,7 +2185,7 @@
 	 (exit (make-exit :entry entry)))
     (push exit (entry-exits entry))
     (prev-link exit start)
-    (use-continuation exit (second found))))
+    (use-continuation exit (cont-ref-cont (second found)))))
 
 
 ;;;; Translators for compiler-magic special forms:
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index f8076e31c..5888bed1d 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.79 2000/02/28 18:36:34 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.80 2000/06/18 15:45:31 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -201,11 +201,14 @@
   (unless (and (eq (continuation-kind new) :unused)
 	       (eq (continuation-kind old) :inside-block))
     (ensure-block-start new))
-  
+
   (do-uses (node old)
     (delete-continuation-use node)
     (add-continuation-use node new))
 
+  (dolist (cont-ref (continuation-refs old))
+    (setf (cont-ref-cont cont-ref) new))
+
   (reoptimize-continuation new)
   (undefined-value))
 
diff --git a/compiler/node.lisp b/compiler/node.lisp
index 22c920695..f5a43385c 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.35 1999/02/25 13:03:11 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.36 2000/06/18 15:45:31 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -85,6 +85,21 @@
   (options nil :type list))
 
 
+;;; A Cont-Ref represents a reference to a continuation.
+;;;
+;;; Note this is somewhat of a hack to handle continuation substitution and
+;;; correct references to continuations within the lexenv.
+;;;
+(defstruct (cont-ref
+	    (:print-function %print-cont-ref))
+  ;;
+  ;; The continuation referenced.
+  (cont (required-argument))) ; :type continuation))
+
+(defprinter cont-ref
+  cont)
+
+
 ;;; The front-end data structure (IR1) is composed of nodes and continuations.
 ;;; The general idea is that continuations contain top-down information and
 ;;; nodes contain bottom-up, derived information.  A continuation represents a
@@ -167,6 +182,10 @@
   ;; indicate whether NIL means no uses or more than one use.
   (use nil :type (or node null))
   ;;
+  ;; Other references to this continuation that must be substituted when this
+  ;; continuation is substituted. This is a list of cont-ref structures.
+  (refs nil :type list)
+  ;;
   ;; Basic block this continuation is in.  This is null only in :Deleted and
   ;; :Unused continuations.  Note that blocks that are unreachable but still in
   ;; the DFO may receive deleted continuations, so it isn't o.k. to assume that
-- 
GitLab