From: Alexey D. <ade...@us...> - 2004-05-01 11:22:50
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14118/src/compiler Modified Files: debug.lisp dfo.lisp fndb.lisp ir2tran.lisp node.lisp physenvanal.lisp stack.lisp Log Message: 0.8.10.3: * Merge with stack-analysis-branch. Index: debug.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug.lisp,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- debug.lisp 4 Apr 2004 14:07:25 -0000 1.34 +++ debug.lisp 1 May 2004 11:22:39 -0000 1.35 @@ -952,6 +952,10 @@ (format t " <deleted>")) (pprint-newline :mandatory) + (awhen (block-info block) + (format t "start stack:~{ v~D~}" + (mapcar #'cont-num (ir2-block-start-stack it))) + (pprint-newline :mandatory)) (do ((ctran (block-start block) (node-next (ctran-next ctran)))) ((not ctran)) (let ((node (ctran-next ctran))) @@ -1010,6 +1014,10 @@ (cast-asserted-type node))))) (pprint-newline :mandatory))) + (awhen (block-info block) + (format t "end stack:~{ v~D~}" + (mapcar #'cont-num (ir2-block-end-stack it))) + (pprint-newline :mandatory)) (let ((succ (block-succ block))) (format t "successors~{ c~D~}~%" (mapcar (lambda (x) (cont-num (block-start x))) succ)))) Index: dfo.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/dfo.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- dfo.lisp 16 Nov 2003 10:19:13 -0000 1.18 +++ dfo.lisp 1 May 2004 11:22:39 -0000 1.19 @@ -91,6 +91,18 @@ (setf (block-flag block) t) (dolist (succ (block-succ block)) (find-dfo-aux succ head component)) + (when (component-nlx-info-generated-p component) + ;; FIXME: We also need (and do) this walk before physenv + ;; analysis, but at that time we are probably not very + ;; interested in the actual DF order. + ;; + ;; TODO: It is probable that one of successors have the same (or + ;; similar) set of NLXes; try to shorten the walk (but think + ;; about a loop, the only exit from which is non-local). + (map-block-nlxes (lambda (nlx-info) + (let ((nle (nlx-info-target nlx-info))) + (find-dfo-aux nle head component))) + block)) (remove-from-dfo block) (add-to-dfo block head)) (values)) Index: fndb.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- fndb.lisp 30 Mar 2004 16:58:26 -0000 1.89 +++ fndb.lisp 1 May 2004 11:22:39 -0000 1.90 @@ -1380,6 +1380,7 @@ (defknown %nlx-entry (t) *) (defknown %%primitive (t t &rest t) *) (defknown %pop-values (t) t) +(defknown %nip-values (t t &rest t) (values)) (defknown %type-check-error (t t) nil) ;; FIXME: This function does not return, but due to the implementation Index: ir2tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v retrieving revision 1.49 retrieving revision 1.50 diff -u -d -r1.49 -r1.50 --- ir2tran.lisp 13 Apr 2004 10:30:39 -0000 1.49 +++ ir2tran.lisp 1 May 2004 11:22:39 -0000 1.50 @@ -1210,16 +1210,16 @@ (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv) - (ir2-physenv-return-pc ir2-physenv)) - (node-lvar node)))) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) + (node-lvar node)))) ;;;; multiple values ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates -;;; the lvarinuation for the correct number of values (with the lvar -;;; user responsible for defaulting), we can just pick them up from -;;; the lvar. +;;; the lvar for the correct number of values (with the lvar user +;;; responsible for defaulting), we can just pick them up from the +;;; lvar. (defun ir2-convert-mv-bind (node block) (declare (type mv-combination node) (type ir2-block block)) (let* ((lvar (first (basic-combination-args node))) @@ -1282,6 +1282,28 @@ (vop reset-stack-pointer node block (first (ir2-lvar-locs 2lvar))))) +(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved &rest moved) + node block) + #!-x86 + (bug "%NIP-VALUES is not implemented on this platform.") + #!+x86 + (let ((2after (lvar-info (lvar-value last-nipped))) + ; pointer immediately after the nipped block + (2first (lvar-info (lvar-value last-preserved))) + ; pointer to the first nipped word + (moved-tns (loop for lvar-ref in moved + for lvar = (lvar-value lvar-ref) + for 2lvar = (lvar-info lvar) + ;when 2lvar + collect (first (ir2-lvar-locs 2lvar))))) + (aver (eq (ir2-lvar-kind 2after) :unknown)) + (aver (eq (ir2-lvar-kind 2first) :unknown)) + (vop* %%nip-values node block + ((first (ir2-lvar-locs 2after)) + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t))))) + ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) (let ((tns (mapcar (lambda (x) Index: node.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v retrieving revision 1.51 retrieving revision 1.52 diff -u -d -r1.51 -r1.52 --- node.lisp 4 Apr 2004 14:07:25 -0000 1.51 +++ node.lisp 1 May 2004 11:22:39 -0000 1.52 @@ -373,7 +373,8 @@ ;; inline expansion. Unlike NEW-FUNCTIONALS, this is not disjoint ;; from COMPONENT-LAMBDAS. (reanalyze-functionals nil :type list) - (delete-blocks nil :type list)) + (delete-blocks nil :type list) + (nlx-info-generated-p nil :type boolean)) (defprinter (component :identity t) name #!+sb-show id @@ -1274,7 +1275,8 @@ ;;; continuation and the exit continuation's DEST. Instead of using ;;; the returned value being delivered directly to the exit ;;; continuation, it is delivered to our VALUE lvar. The original exit -;;; lvar is the exit node's LVAR. +;;; lvar is the exit node's LVAR; physenv analysis also makes it the +;;; lvar of %NLX-ENTRY call. (defstruct (exit (:include valued-node) (:copier nil)) ;; the ENTRY node that this is an exit for. If null, this is a Index: physenvanal.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/physenvanal.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- physenvanal.lisp 30 Mar 2004 16:58:27 -0000 1.13 +++ physenvanal.lisp 1 May 2004 11:22:39 -0000 1.14 @@ -50,6 +50,7 @@ (setf (functional-kind fun) nil) (delete-functional fun))))) + (setf (component-nlx-info-generated-p component) t) (values)) ;;; This is to be called on a COMPONENT with top level LAMBDAs before @@ -232,8 +233,8 @@ ;;; knows what entry is being done. ;;; ;;; The link from the EXIT block to the entry stub is changed to be a -;;; link to the component head. Similarly, the EXIT block is linked to -;;; the component tail. This leaves the entry stub reachable, but +;;; link from the component head. Similarly, the EXIT block is linked +;;; to the component tail. This leaves the entry stub reachable, but ;;; makes the flow graph less confusing to flow analysis. ;;; ;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the @@ -280,9 +281,10 @@ ;;; function reference. This will cause the escape function to ;;; be deleted (although not removed from the DFO.) The escape ;;; function is no longer needed, and we don't want to emit code -;;; for it. We then also change the %NLX-ENTRY call to use the -;;; NLX continuation so that there will be a use to represent -;;; the NLX use. +;;; for it. +;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there +;;; will be a use to represent the NLX use; 2) make life easier for +;;; the stack analysis. (defun note-non-local-exit (env exit) (declare (type physenv env) (type exit exit)) (let ((lvar (node-lvar exit)) @@ -300,11 +302,13 @@ (mapc (lambda (x) (setf (node-derived-type x) *wild-type*)) (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun) - (let ((node (block-last (nlx-info-target info)))) - (delete-lvar-use node) - (aver (eq lvar (node-lvar exit))) - (add-lvar-use node lvar))))) + (substitute-leaf (find-constant info) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) + (aver (eq lvar (node-lvar exit))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar)))))) (values)) ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT Index: stack.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/stack.lisp,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- stack.lisp 13 Apr 2004 10:30:39 -0000 1.12 +++ stack.lisp 1 May 2004 11:22:39 -0000 1.13 @@ -1,7 +1,7 @@ ;;;; This file implements the stack analysis phase in the compiler. We ;;;; do a graph walk to determine which unknown-values lvars are on ;;;; the stack at each point in the program, and then we insert -;;;; cleanup code to pop off unused values. +;;;; cleanup code to remove unused values. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -41,129 +41,129 @@ (setf (ir2-block-pushed 2block) (pushed)))) (values)) -;;;; annotation graph walk +;;;; Computation of live UVL sets +(defun nle-block-nlx-info (block) + (let* ((start-node (block-start-node block)) + (nlx-ref (ctran-next (node-next start-node))) + (nlx-info (constant-value (ref-leaf nlx-ref)))) + nlx-info)) +(defun nle-block-entry-block (block) + (let* ((nlx-info (nle-block-nlx-info block)) + (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info))) + (entry-block (node-block mess-up))) + entry-block)) ;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has ;;; been changed. -(defun merge-stacks (early late) +(defun merge-uvl-live-sets (early late) (declare (type list early late)) - (cond ((null early) late) - ((null late) early) - ((tailp early late) late) - ((tailp late early) early) - ;; FIXME - (t (bug "Lexical unwinding of UVL stack is not implemented.")))) + (dolist (e late early) + (pushnew e early))) ;;; Update information on stacks of unknown-values LVARs on the ;;; boundaries of BLOCK. Return true if the start stack has been ;;; changed. -(defun stack-update (block) +;;; +;;; An LVAR is live at the end iff it is live at some of blocks, which +;;; BLOCK can transfer control to. There are two kind of control +;;; transfers: normal, expressed with BLOCK-SUCC, and NLX. +(defun update-uvl-live-sets (block) (declare (type cblock block)) - (declare (optimize (debug 3))) (let* ((2block (block-info block)) + (original-start (ir2-block-start-stack 2block)) (end (ir2-block-end-stack 2block)) - (new-end end) - (cleanup (block-end-cleanup block)) - (found-similar-p nil)) - (declare (ignore #-nil cleanup)) + (new-end end)) (dolist (succ (block-succ block)) - #+nil - (when (and (< block succ) - (eq cleanup (block-end-cleanup succ))) - (setq found-similar-p t)) - (setq new-end (merge-stacks new-end (ir2-block-start-stack (block-info succ))))) - (unless found-similar-p - (map-block-nlxes (lambda (nlx-info) - (let* ((nle (nlx-info-target nlx-info)) - (nle-start-stack (ir2-block-start-stack - (block-info nle))) - (exit-lvar (nlx-info-lvar nlx-info))) - (when (eq exit-lvar (car nle-start-stack)) - (pop nle-start-stack)) - (setq new-end (merge-stacks new-end - nle-start-stack)))) - block)) + (setq new-end (merge-uvl-live-sets new-end + (ir2-block-start-stack (block-info succ))))) + (map-block-nlxes (lambda (nlx-info) + (let* ((nle (nlx-info-target nlx-info)) + (nle-start-stack (ir2-block-start-stack + (block-info nle))) + (exit-lvar (nlx-info-lvar nlx-info)) + (next-stack (if exit-lvar + (remove exit-lvar nle-start-stack) + nle-start-stack))) + (setq new-end (merge-uvl-live-sets + new-end next-stack)))) + block) (setf (ir2-block-end-stack 2block) new-end) + (let ((start new-end)) - (dolist (push (reverse (ir2-block-pushed 2block))) - (if (eq (car start) push) - (pop start) - (aver (not (member push start))))) + (setq start (set-difference start (ir2-block-pushed 2block))) + (setq start (merge-uvl-live-sets start (ir2-block-popped 2block))) - (dolist (pop (reverse (ir2-block-popped 2block))) - (push pop start)) + ;; We cannot delete unused UVLs during NLX, so all UVLs live at + ;; ENTRY will be actually live at NLE. + (when (and (eq (component-head (block-component block)) + (first (block-pred block))) + (not (bind-p (block-start-node block)))) + (let* ((entry-block (nle-block-entry-block block)) + (entry-stack (ir2-block-start-stack (block-info entry-block)))) + (setq start (merge-uvl-live-sets start entry-stack)))) - (cond ((equal-but-no-car-recursion start - (ir2-block-start-stack 2block)) + (when *check-consistency* + (aver (subsetp original-start start))) + (cond ((subsetp start original-start) nil) (t (setf (ir2-block-start-stack 2block) start) t))))) -;;; Do stack annotation for any values generators in Block that were -;;; unreached by all walks (i.e. the lvar isn't live at the point that -;;; it is generated.) This will only happen when the values receiver cannot be -;;; reached from this particular generator (due to an unconditional control -;;; transfer.) -;;; -;;; What we do is push on the End-Stack all lvars in Pushed that -;;; aren't already present in the End-Stack. When we find any pushed -;;; lvar that isn't live, it must be the case that all lvars -;;; pushed after (on top of) it aren't live. -;;; -;;; If we see a pushed lvar that is the LVAR of a tail call, then we -;;; ignore it, since the tail call didn't actually push anything. The -;;; tail call must always the last in the block. -;;; -;;; [This function also fixes End-Stack in NLEs.] -(defun annotate-dead-values (block) - (declare (type cblock block)) + +;;;; Ordering of live UVL stacks + +;;; Put UVLs on the start/end stacks of BLOCK in the right order. PRED +;;; is a predecessor of BLOCK with already sorted stacks; because all +;;; UVLs being live at the BLOCK start are live in PRED, we just need +;;; to delete dead UVLs. +(defun order-block-uvl-sets (block pred) (let* ((2block (block-info block)) - (stack (ir2-block-end-stack 2block)) - (last (block-last block)) - (tailp-lvar (if (node-tail-p last) (node-lvar last)))) - (do ((pushes (ir2-block-pushed 2block) (rest pushes)) - (popping nil)) - ((null pushes)) - (let ((push (first pushes))) - (cond ((member push stack) - (aver (not popping))) - ((eq push tailp-lvar) - (aver (null (rest pushes)))) - (t - (push push (ir2-block-end-stack 2block)) - (setq popping t)))))) + (pred-end-stack (ir2-block-end-stack (block-info pred))) + (start (ir2-block-start-stack 2block)) + (start-stack (loop for lvar in pred-end-stack + when (memq lvar start) + collect lvar)) + (end (ir2-block-end-stack 2block))) + (when *check-consistency* + (aver (subsetp start start-stack))) + (setf (ir2-block-start-stack 2block) start-stack) - (values)) + (let* ((last (block-last block)) + (tailp-lvar (if (node-tail-p last) (node-lvar last))) + (end-stack start-stack)) + (dolist (pop (ir2-block-popped 2block)) + (aver (eq pop (car end-stack))) + (pop end-stack)) + (dolist (push (ir2-block-pushed 2block)) + (aver (not (memq push end-stack))) + (push push end-stack)) + (aver (subsetp end end-stack)) + (when (and tailp-lvar + (eq (ir2-lvar-kind (lvar-info tailp-lvar)) :unknown)) + (aver (eq tailp-lvar (first end-stack))) + (pop end-stack)) + (setf (ir2-block-end-stack 2block) end-stack)))) -;;; For every NLE block push all LVARs that are live in its ENTRY to -;;; its start stack. (We cannot pop unused LVARs on a control transfer -;;; to an NLE block, so we must do it later.) -(defun fix-nle-block-stacks (component) - (declare (type component component)) - (dolist (block (block-succ (component-head component))) - (let ((start-node (block-start-node block))) - (unless (bind-p start-node) - (let* ((2block (block-info block)) - (start-stack (block-start-stack 2block)) - (nlx-ref (ctran-next (node-next start-node))) - (nlx-info (constant-value (ref-leaf nlx-ref))) - (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info))) - (entry-block (node-block mess-up)) - (entry-stack (ir2-block-start-stack (block-info entry-block))) - (exit-lvar (nlx-info-lvar nlx-info))) - (when (and exit-lvar - (eq exit-lvar (car start-stack))) - (when *check-consistency* - (aver (not (memq exit-lvar entry-stack)))) - (push exit-lvar entry-stack)) - (when *check-consistency* - (aver (subsetp start-stack entry-stack))) - (setf (ir2-block-start-stack 2block) entry-stack) - (setf (ir2-block-end-stack 2block) entry-stack) - ; ANNOTATE-DEAD-VALUES will do the rest - ))))) +(defun order-uvl-sets (component) + (clear-flags component) + (loop with head = (component-head component) + with repeat-p do + (setq repeat-p nil) + (do-blocks (block component) + (unless (block-flag block) + (let ((pred (find-if #'block-flag (block-pred block)))) + (when (and (eq pred head) + (not (bind-p (block-start-node block)))) + (let ((entry (nle-block-entry-block block))) + (setq pred (if (block-flag entry) entry nil)))) + (cond (pred + (setf (block-flag block) t) + (order-block-uvl-sets block pred)) + (t + (setq repeat-p t)))))) + while repeat-p)) ;;; This is called when we discover that the stack-top unknown-values ;;; lvar at the end of BLOCK1 is different from that at the start of @@ -183,20 +183,38 @@ (defun discard-unused-values (block1 block2) (declare (type cblock block1 block2)) (let* ((block1-stack (ir2-block-end-stack (block-info block1))) - (block2-stack (ir2-block-start-stack (block-info block2))) - (last-popped (elt block1-stack - (- (length block1-stack) - (length block2-stack) - 1)))) - (aver (tailp block2-stack block1-stack)) - - (let* ((block (insert-cleanup-code block1 block2 - (block-start-node block2) - `(%pop-values ',last-popped))) - (2block (make-ir2-block block))) - (setf (block-info block) 2block) - (add-to-emit-order 2block (block-info block1)) - (ltn-analyze-belated-block block))) + (block2-stack (ir2-block-start-stack (block-info block2))) + (cleanup-code + (cond ((eq (car block1-stack) (car block2-stack)) + (binding* ((preserved-count (mismatch block1-stack block2-stack) + :exit-if-null) + (n-last-preserved (1- preserved-count)) + (nipped-count (- (length block1-stack) + (length block2-stack))) + (n-last-nipped (+ n-last-preserved nipped-count))) + (aver (equal (nthcdr (1+ n-last-nipped) block1-stack) + (nthcdr preserved-count block2-stack))) + (compiler-notify "%NIP-VALUES emitted") + `(%nip-values ',(elt block1-stack n-last-nipped) + ',(elt block1-stack n-last-preserved) + ,@(loop for moved in block1-stack + repeat preserved-count + collect `',moved)))) + (t + (let* ((n-popped (- (length block1-stack) + (length block2-stack))) + (last-popped (elt block1-stack (1- n-popped)))) + (when *check-consistency* + (aver (equal block2-stack (nthcdr n-popped block1-stack)))) + `(%pop-values ',last-popped)))))) + (when cleanup-code + (let* ((block (insert-cleanup-code block1 block2 + (block-start-node block2) + cleanup-code)) + (2block (make-ir2-block block))) + (setf (block-info block) 2block) + (add-to-emit-order 2block (block-info block1)) + (ltn-analyze-belated-block block)))) (values)) @@ -220,12 +238,6 @@ ;;; received. This phase doesn't need to be run when Values-Receivers ;;; is null, i.e. there are no unknown-values lvars used across block ;;; boundaries. -;;; -;;; Do the backward graph walk, starting at each values receiver. We -;;; ignore receivers that already have a non-null START-STACK. These -;;; are nested values receivers that have already been reached on -;;; another walk. We don't want to clobber that result with our null -;;; initial stack. (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) @@ -235,25 +247,20 @@ (dolist (block generators) (find-pushed-lvars block)) + ;;; Compute sets of live UVLs (loop for did-something = nil do (do-blocks-backwards (block component) - (when (stack-update block) + (when (update-uvl-live-sets block) (setq did-something t))) while did-something) - (when *check-consistency* - (dolist (block (block-succ (component-head component))) - (when (bind-p (block-start-node block)) - (aver (null (ir2-block-start-stack (block-info block))))))) - - (dolist (block generators) - (annotate-dead-values block)) + (order-uvl-sets component) (do-blocks (block component) - (let ((top (car (ir2-block-end-stack (block-info block))))) + (let ((top (ir2-block-end-stack (block-info block)))) (dolist (succ (block-succ block)) (when (and (block-start succ) - (not (eq (car (ir2-block-start-stack (block-info succ))) + (not (eq (ir2-block-start-stack (block-info succ)) top))) (discard-unused-values block succ)))))) |