From: Alexey Dejneka Date: Wed, 14 Jan 2004 04:42:52 +0000 (+0000) Subject: 0.8.7.13: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=64ec717cf13c44fb4571c1fd7fbd508551ecfe01;p=sbcl.git 0.8.7.13: * Stack analysis: propagate liveness information from NLEs. (fixes bug 299, PFD's MISC.185, 186, 231, 232, 235, 236, 237). --- diff --git a/BUGS b/BUGS index 14cd32a..a52d83a 100644 --- a/BUGS +++ b/BUGS @@ -1228,21 +1228,6 @@ WORKAROUND: returns, values returned by (EXT) must be removed from under that of (INT). -299: (aka PFD MISC.186) - * (defun foo () - (declare (optimize (debug 1))) - (multiple-value-call #'list - (if (eval t) (eval '(values :a :b :c)) nil) ; (*) - (catch 'foo (throw 'foo (values :x :y))))) - FOO - * (foo) - (:X :Y) - - Operator THROW is represented with a call of a not returning funny - function %THROW, unknown values stack after the call is empty, so - the unknown values LVAR (*) is considered to be dead after the call - and, thus, before it and is popped by the stack analysis. - 300: (reported by Peter Graves) Function PEEK-CHAR checks PEEK-TYPE argument type only after having read a character. This is caused with EXPLICIT-CHECK attribute in DEFKNOWN. The similar problem diff --git a/NEWS b/NEWS index 8d79df5..984410d 100644 --- a/NEWS +++ b/NEWS @@ -2243,6 +2243,9 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7: type when called with 1 argument; PEEK-CHAR checked type of PEEK-TYPE only after having read first character from a stream. (reported by Peter Graves) + * fixed some bugs revealed by Paul Dietz' test suite: + ** in stack analysys liveness information is propagated from + non-local entry points. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index 7c51f47..6eed380 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -169,3 +169,11 @@ then cons up a bignum for it: ((89 125 16) (ASH A (MIN 18 -706))) (T (DPB -3 (BYTE 30 30) -1)))) -------------------------------------------------------------------------------- +#16 +(do ((i 0 (1+ i))) + ((= i (the (integer 0 100) n))) + ...) + +It is commonly expected for Python to derive (FIXNUMP I). (If ``='' is +replaced with ``>='', Python will do.) +-------------------------------------------------------------------------------- diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7252c64..4ad7749 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -69,6 +69,7 @@ result of Value-Form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) + (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -162,6 +163,7 @@ to the next statement following that tag. A Tag must an integer or a symbol. A statement must be a list. Other objects are illegal within the body." + (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index aae4e2f..61aea84 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -323,19 +323,21 @@ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker (cond ( ;; We cannot combine with a successor block if: (or - ;; The successor has more than one predecessor. + ;; the successor has more than one predecessor; (rest (block-pred next)) - ;; The successor is the current block (infinite loop). + ;; the successor is the current block (infinite loop); (eq next block) - ;; The next block has a different cleanup, and thus + ;; the next block has a different cleanup, and thus ;; we may want to insert cleanup code between the - ;; two blocks at some point. + ;; two blocks at some point; (not (eq (block-end-cleanup block) (block-start-cleanup next))) - ;; The next block has a different home lambda, and + ;; the next block has a different home lambda, and ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) - (block-home-lambda next)))) + (block-home-lambda next))) + ;; Stack analysis phase wants ENTRY to start a block. + (entry-p (block-start-node next))) nil) (t (join-blocks block next) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 9483c78..2dfcfef 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -220,6 +220,25 @@ ((:inside-block) (node-ends-block (ctran-use ctran))))) (values)) + +;;; CTRAN must be the last ctran in an incomplete block; finish the +;;; block and start a new one if necessary. +(defun start-block (ctran) + (declare (type ctran ctran)) + (aver (not (ctran-next ctran))) + (ecase (ctran-kind ctran) + (:inside-block + (let ((block (ctran-block ctran)) + (node (ctran-use ctran))) + (aver (not (block-last block))) + (aver node) + (setf (block-last block) node) + (setf (node-next node) nil) + (setf (ctran-use ctran) nil) + (setf (ctran-kind ctran) :unused) + (setf (ctran-block ctran) nil) + (link-blocks block (ctran-starts-block ctran)))) + (:block-start))) ;;;; @@ -658,6 +677,30 @@ (setf (block-prev next) block)) (values)) +;;; List all NLX-INFOs which BLOCK can exit to. +;;; +;;; We hope that no cleanup actions are performed in the middle of +;;; BLOCK, so it is enough to look only at cleanups in the block +;;; end. The tricky thing is a special cleanup block; all its nodes +;;; have the same cleanup info, corresponding to the start, so the +;;; same approach returns safe result. +(defun map-block-nlxes (fun block) + (loop for cleanup = (block-end-cleanup block) + then (node-enclosing-cleanup (cleanup-mess-up cleanup)) + while cleanup + do (let ((mess-up (cleanup-mess-up cleanup))) + (case (cleanup-kind cleanup) + ((:block :tagbody) + (aver (entry-p mess-up)) + (loop for exit in (entry-exits mess-up) + for nlx-info = (find-nlx-info exit) + do (funcall fun nlx-info))) + ((:catch :unwind-protect) + (aver (combination-p mess-up)) + (let* ((arg-lvar (first (basic-combination-args mess-up))) + (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar))))) + (funcall fun nlx-info))))))) + ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. (declaim (ftype (sfunction (component) (values)) clear-flags)) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index b71a128..275cf22 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -43,73 +43,62 @@ ;;;; annotation graph walk -;;; Do a backward walk in the flow graph simulating the run-time stack -;;; of unknown-values lvars and annotating the blocks with the result. -;;; -;;; BLOCK is the block that is currently being walked and STACK is the -;;; stack of unknown-values lvars in effect immediately after -;;; block. We simulate the stack by popping off the unknown-values -;;; generated by this block (if any) and pushing the lvars for -;;; values received by this block. (The role of push and pop are -;;; interchanged because we are doing a backward walk.) -;;; -;;; If we run into a values generator whose lvar isn't on -;;; stack top, then the receiver hasn't yet been reached on any walk -;;; to this use. In this case, we ignore the push for now, counting on -;;; Annotate-Dead-Values to clean it up if we discover that it isn't -;;; reachable at all. -;;; -;;; If our final stack isn't empty, then we walk all the predecessor -;;; blocks that don't have all the lvars that we have on our -;;; START-STACK on their END-STACK. This is our termination condition -;;; for the graph walk. We put the test around the recursive call so -;;; that the initial call to this function will do something even -;;; though there isn't initially anything on the stack. -;;; -;;; We can use the tailp test, since the only time we want to bottom -;;; out with a non-empty stack is when we intersect with another path -;;; from the same top level call to this function that has more values -;;; receivers on that path. When we bottom out in this way, we are -;;; counting on DISCARD-UNUSED-VALUES doing its thing. -;;; -;;; When we do recurse, we check that predecessor's END-STACK is a -;;; subsequence of our START-STACK. There may be extra stuff on the -;;; top of our stack because the last path to the predecessor may have -;;; discarded some values that we use. There may be extra stuff on the -;;; bottom of our stack because this walk may be from a values -;;; receiver whose lifetime encloses that of the previous walk. -;;; -;;; If a predecessor block is the component head, then it must be the -;;; case that this is a NLX entry stub. If so, we just stop our walk, -;;; since the stack at the exit point doesn't have anything to do with -;;; our stack. -(defun stack-simulation-walk (block stack) - (declare (type cblock block) (list stack)) - (let ((2block (block-info block))) - (setf (ir2-block-end-stack 2block) stack) - (let ((new-stack stack)) - (dolist (push (reverse (ir2-block-pushed 2block))) - (if (eq (car new-stack) push) - (pop new-stack) - (aver (not (member push new-stack))))) +;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has +;;; been changed. +(defun merge-stacks (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 (pop (reverse (ir2-block-popped 2block))) - (push pop new-stack)) +;;; 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) + (declare (type cblock block)) + (declare (optimize (debug 3))) + (let* ((2block (block-info block)) + (end (ir2-block-end-stack 2block)) + (new-end end) + (cleanup (block-end-cleanup block)) + (found-similar-p nil)) + (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)) - (setf (ir2-block-start-stack 2block) new-stack) + (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))))) - (when new-stack - (dolist (pred (block-pred block)) - (if (eq pred (component-head (block-component block))) - (aver (find block - (physenv-nlx-info (block-physenv block)) - :key #'nlx-info-target)) - (let ((pred-stack (ir2-block-end-stack (block-info pred)))) - (unless (tailp new-stack pred-stack) - (aver (search pred-stack new-stack)) - (stack-simulation-walk pred new-stack)))))))) + (dolist (pop (reverse (ir2-block-popped 2block))) + (push pop start)) - (values)) + (cond ((equal-but-no-car-recursion start + (ir2-block-start-stack 2block)) + 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 @@ -125,6 +114,8 @@ ;;; 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)) (let* ((2block (block-info block)) @@ -144,6 +135,34 @@ (setq popping t)))))) (values)) + +;;; 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-var entry-stack)))) + (push exit-var 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 + ))))) ;;; 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 @@ -215,9 +234,16 @@ (dolist (block generators) (find-pushed-lvars block)) - (dolist (block receivers) - (unless (ir2-block-start-stack (block-info block)) - (stack-simulation-walk block ()))) + (loop for did-something = nil + do (do-blocks-backwards (block component) + (when (stack-update 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)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9a08b7e..0e493f5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1033,3 +1033,64 @@ 215067723) 13739018)) +;;; bug 299 (reported by PFD) +(assert + (equal (funcall + (compile + nil + '(lambda () + (declare (optimize (debug 1))) + (multiple-value-call #'list + (if (eval t) (eval '(values :a :b :c)) nil) + (catch 'foo (throw 'foo (values :x :y))))))) + '(:a :b :c :x :y))) +;;; MISC.185 +(assert (equal + (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer 5 155656586618) a)) + (declare (type (integer -15492 196529) b)) + (declare (type (integer 7 10) c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (flet ((%f3 + (f3-1 f3-2 f3-3 + &optional (f3-4 a) (f3-5 0) + (f3-6 + (labels ((%f10 (f10-1 f10-2 f10-3) + 0)) + (apply #'%f10 + 0 + a + (- (if (equal a b) b (%f10 c a 0)) + (catch 'ct2 (throw 'ct2 c))) + nil)))) + 0)) + (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7) + 0)) +;;; MISC.186 +(assert (eq + (eval + '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1)) + (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil))) + (vars '(b c)) + (fn1 `(lambda ,vars + (declare (type (integer -2 19) b) + (type (integer -1520 218978) c) + (optimize (speed 3) (safety 1) (debug 1))) + ,form)) + (fn2 `(lambda ,vars + (declare (notinline logeqv apply) + (optimize (safety 3) (speed 0) (debug 0))) + ,form)) + (cf1 (compile nil fn1)) + (cf2 (compile nil fn2)) + (result1 (multiple-value-list (funcall cf1 2 18886))) + (result2 (multiple-value-list (funcall cf2 2 18886)))) + (if (equal result1 result2) + :good + (values result1 result2)))) + :good)) diff --git a/version.lisp-expr b/version.lisp-expr index 8654696..669512e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.7.12" +"0.8.7.13"