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