diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp index 51f4d7c873528680006f0c448dd93943de614ed2..5f2eb355122a1d0f588f1ec4e2ce46096580a8be 100644 --- a/compiler/byte-comp.lisp +++ b/compiler/byte-comp.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.20 1993/08/23 01:37:21 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.21 1993/08/24 23:34:46 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -336,13 +336,21 @@ total-consumes nlx-entries nlx-entry-p))) (label (new-assem:gen-label) :type new-assem:label) ;; - ;; A list of the continuations that this block pushes onto the stack. + ;; A list of the CONTINUATIONs describing values that this block pushes onto + ;; the stack. Note: PRODUCES and CONSUMES can contain the keyword :NLX-ENTRY + ;; marking the place on the stack where a non-local-exit frame is added or + ;; removed. Since breaking up a NLX restores the stack, we don't have to + ;; about (and in fact must not) discard values underneath a :NLX-ENTRY marker + ;; evern though they appear to be dead (since they might not be.) (produces nil :type list) ;; - ;; An SSET of the produces for faster set manipulations. + ;; An SSET of the produces for faster set manipulations. The elements are + ;; the BYTE-CONTINUATION-INFO objects. :NLX-ENTRY markers are not + ;; represented. (produces-sset (make-sset) :type sset) ;; - ;; A list of the continuations that this block pops from the stack. + ;; A list of the continuations that this block pops from the stack. See + ;; PRODUCES. (consumes nil :type list) ;; ;; The transitive closure of what this block and all its successors @@ -354,10 +362,12 @@ ;; block several times. (already-queued nil :type (member t nil)) ;; - ;; The continuations on the stack (in order) when this block starts. + ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this + ;; block starts. (start-stack :unknown :type (or (member :unknown) list)) ;; - ;; The continuations on the stack (in order) when this block ends. + ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this + ;; block ends. (end-stack nil :type list) ;; ;; List of ((nlx-info*) produces consumes) for each ENTRY in this block that @@ -628,6 +638,16 @@ (defvar *byte-continuation-counter*) +;;; COMPUTE-PRODUCES-AND-CONSUMES -- Internal +;;; +;;; Scan the nodes in Block and compute the information that we will need to +;;; do flow analysis and our stack simulation walk. We simulate the stack +;;; within the block, reducing it to ordered lists representing the values we +;;; remove from the top of the stack and place on the stack (not considering +;;; values that are produced and consumed within the block.) A NLX entry point +;;; is considered to push a :NLX-ENTRY marker (can be though of as the run-time +;;; catch frame.) +;;; (defun compute-produces-and-consumes (block) (let ((stack nil) (consumes nil) @@ -641,7 +661,7 @@ (not (member (byte-continuation-info-results info) '(0 :eq-test))))))) (consume (cont) - (cond ((not (interesting cont))) + (cond ((not (or (eq cont :nlx-entry) (interesting cont)))) (stack (assert (eq (car stack) cont)) (pop stack)) @@ -649,11 +669,12 @@ (adjoin-cont cont total-consumes) (push cont consumes)))) (adjoin-cont (cont sset) - (let ((info (continuation-info cont))) - (unless (byte-continuation-info-number info) - (setf (byte-continuation-info-number info) - (incf *byte-continuation-counter*))) - (sset-adjoin info sset)))) + (unless (eq cont :nlx-entry) + (let ((info (continuation-info cont))) + (unless (byte-continuation-info-number info) + (setf (byte-continuation-info-number info) + (incf *byte-continuation-counter*))) + (sset-adjoin info sset))))) (do-nodes (node cont block) (etypecase node (bind) @@ -665,16 +686,24 @@ (when arg (consume arg))) (consume (basic-combination-fun node)) - (when (eq (continuation-function-name - (basic-combination-fun node)) - '%nlx-entry) - (let ((nlx-info (continuation-value - (first (basic-combination-args node))))) - (when (eq (cleanup-kind (nlx-info-cleanup nlx-info)) :block) - (let ((cont (nlx-info-continuation nlx-info))) - (when (interesting cont) - (push cont stack))))) - (setf nlx-entry-p t))) + (case (continuation-function-name (basic-combination-fun node)) + (%nlx-entry + (let ((nlx-info (continuation-value + (first (basic-combination-args node))))) + (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) + ((:catch :unwind-protect) + (consume :nlx-entry)) + ;; + ;; If for a lexical exit, we will see a breakup later, so + ;; don't consume :NLX-ENTRY now. + (:tagbody) + (:block + (let ((cont (nlx-info-continuation nlx-info))) + (when (interesting cont) + (push cont stack)))))) + (setf nlx-entry-p t)) + ((%catch-breakup %unwind-protect-breakup %lexical-exit-breakup) + (consume :nlx-entry)))) (cif (consume (if-test node))) (creturn @@ -683,6 +712,7 @@ (let* ((cup (entry-cleanup node)) (nlx-info (cleanup-nlx-info cup))) (when nlx-info + (push :nlx-entry stack) (push (list nlx-info stack (reverse consumes)) nlx-entries)))) (exit @@ -714,26 +744,44 @@ (byte-block-info-nlx-entry-p (block-info succ))) (walk-block succ block stack))))) +;;; CONSUME-STUFF -- Internal +;;; +;;; Take a stack and a consumes list, and remove the appropriate stuff. +;;; When we consume a :NLX-ENTRY, we just remove the top marker, and leave any +;;; values on top intact. This represents the desired effect of +;;; %CATCH-BREAKUP, etc., which don't affect any values on the stack. +;;; +(defun consume-stuff (stack stuff) + (let ((new-stack stack)) + (dolist (cont stuff) + (cond ((eq cont :nlx-entry) + (assert (find :nlx-entry new-stack)) + (setq new-stack (remove :nlx-entry new-stack :count 1))) + (t + (assert (eq (car new-stack) cont)) + (pop new-stack)))) + new-stack)) + +;;; WALK-NLX-ENTRY -- Internal +;;; ;;; NLX-infos is the list of nlx-info structures for this ENTRY note. Consume ;;; and Produce are the values from outside this block that were consumed and ;;; produced by this block before the ENTRY node. Stack is the globally ;;; simulated stack at the start of this block. ;;; -;;; If we hit the NLX ep for a unwind-protect, then we are unwinding, and don't -;;; want to mess with the stack, so just say there's nothing on it. -;;; (defun walk-nlx-entry (nlx-infos stack produce consume) - (dolist (cont consume) - (assert (eq (car stack) cont)) - (pop stack)) - (dolist (nlx-info nlx-infos) - (walk-block (nlx-info-target nlx-info) nil - (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - ((:block :tagbody :catch) - (append produce stack)) - (:unwind-protect ())))) + (let ((stack (consume-stuff stack consume))) + (dolist (nlx-info nlx-infos) + (walk-block (nlx-info-target nlx-info) nil (append produce stack)))) (undefined-value)) + +;;; WALK-BLOCK -- Internal +;;; +;;; Simulate the stack across block boundaries, discarding any values that +;;; are dead. A :NLX-ENTRY marker prevents values live at a NLX entry point +;;; from being discarded prematurely. +;;; (defun walk-block (block pred stack) ;; Pop everything off of stack that isn't live. (let* ((info (block-info block)) @@ -747,12 +795,14 @@ (loop (unless stack (return)) - (let* ((cont (car stack)) - (info (continuation-info cont))) - (when (sset-member info live) + (let ((cont (car stack))) + (when (or (eq cont :nlx-entry) + (sset-member (continuation-info cont) live)) (return)) (pop stack) - (let ((results (byte-continuation-info-results info))) + (let ((results + (byte-continuation-info-results + (continuation-info cont)))) (case results (:unknown (flush-fixed) @@ -769,6 +819,7 @@ (continuation-next (block-start block)) `(progn ,@(pops))))) (annotate-block cleanup-block)))) + (cond ((eq (byte-block-info-start-stack info) :unknown) ;; Record what the stack looked like at the start of this block. (setf (byte-block-info-start-stack info) stack) @@ -776,9 +827,7 @@ (dolist (stuff (byte-block-info-nlx-entries info)) (walk-nlx-entry (first stuff) stack (second stuff) (third stuff))) ;; Remove whatever we consume. - (dolist (cont (byte-block-info-consumes info)) - (assert (eq (car stack) cont)) - (pop stack)) + (setq stack (consume-stuff stack (byte-block-info-consumes info))) ;; Add whatever we produce. (setf stack (append (byte-block-info-produces info) stack)) (setf (byte-block-info-end-stack info) stack) @@ -790,6 +839,16 @@ (assert (equal (byte-block-info-start-stack info) stack))))) (undefined-value)) +;;; BYTE-STACK-ANALYZE -- Internal +;;; +;;; Do lifetime flow analysis on values pushed on the stack, then call do +;;; the stack simulation walk to discard dead values. In addition to +;;; considering the obvious inputs from a block's successors, we must also +;;; consider %NLX-ENTRY targets to be successors in order to ensure that any +;;; values only used in the NLX entry stay alive until we reach the mess-up +;;; node. After then, we can keep the values from being discarded by placing a +;;; marker on the simulated stack. +;;; (defun byte-stack-analyze (component) (let ((head nil)) (let ((*byte-continuation-counter* 0)) @@ -810,6 +869,15 @@ (setf head new)) (setf tail new)))))) (maybe-enqueue-predecessors (block) + (when (byte-block-info-nlx-entry-p (block-info block)) + (maybe-enqueue + (node-block + (cleanup-mess-up + (nlx-info-cleanup + (find block + (environment-nlx-info (block-environment block)) + :key #'nlx-info-target)))))) + (dolist (pred (block-pred block)) (unless (eq pred (component-head (block-component block))) (maybe-enqueue pred))))) @@ -830,8 +898,18 @@ (byte-block-info-total-consumes succ-info) produces-sset) (setf did-anything t))))) + (dolist (nlx-list (byte-block-info-nlx-entries info)) + (dolist (nlx-info (first nlx-list)) + (when (sset-union-of-difference + total-consumes + (byte-block-info-total-consumes + (block-info + (nlx-info-target nlx-info))) + produces-sset) + (setf did-anything t)))) (when did-anything (maybe-enqueue-predecessors block))))))) + (walk-successors (component-head component) nil) (undefined-value)) @@ -1715,7 +1793,6 @@ (assert (and (zerop num-args) (zerop results))) (let ((nlx-info (continuation-value nlx-info))) (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info)) - (:catch t) (:block ;; We only want to do this for the fall-though case. (not (eq (car (block-pred (node-block node)))