X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fstack.lisp;h=f04e92cf8f8de96830056ecdc897826e98e936b8;hb=0bca0cb1bf5ce5572ab5cd7ba59f87fed1f2edb0;hp=b8246a06603a3c213e0a62f9f3bd0069617c777e;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index b8246a0..f04e92c 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -35,7 +35,7 @@ (not (eq (node-block dest) block)) 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (assert (or saw-last (not last-pop))) + (aver (or saw-last (not last-pop))) (pushed cont))))) (setf (ir2-block-pushed 2block) (pushed)))) @@ -43,44 +43,47 @@ ;;;; annotation graph walk -;;; Do a backward walk in the flow graph simulating the run-time stack of -;;; unknown-values continuations and annotating the blocks with the result. +;;; Do a backward walk in the flow graph simulating the run-time stack +;;; of unknown-values continuations and annotating the blocks with the +;;; result. ;;; -;;; Block is the block that is currently being walked and Stack is the stack -;;; of unknown-values continuations in effect immediately after block. We -;;; simulate the stack by popping off the unknown-values generated by this -;;; block (if any) and pushing the continuations for values received by this -;;; block. (The role of push and pop are interchanged because we are doing a -;;; backward walk.) +;;; BLOCK is the block that is currently being walked and STACK is the +;;; stack of unknown-values continuations in effect immediately after +;;; block. We simulate the stack by popping off the unknown-values +;;; generated by this block (if any) and pushing the continuations 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 continuation 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 we run into a values generator whose continuation 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 continuations 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. +;;; If our final stack isn't empty, then we walk all the predecessor +;;; blocks that don't have all the continuations 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. +;;; 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. +;;; 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. +;;; 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))) @@ -89,7 +92,7 @@ (dolist (push (reverse (ir2-block-pushed 2block))) (if (eq (car new-stack) push) (pop new-stack) - (assert (not (member push new-stack))))) + (aver (not (member push new-stack))))) (dolist (pop (reverse (ir2-block-popped 2block))) (push pop new-stack)) @@ -99,12 +102,12 @@ (when new-stack (dolist (pred (block-pred block)) (if (eq pred (component-head (block-component block))) - (assert (find block - (environment-nlx-info (block-environment block)) - :key #'nlx-info-target)) + (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) - (assert (search pred-stack new-stack)) + (aver (search pred-stack new-stack)) (stack-simulation-walk pred new-stack)))))))) (values)) @@ -134,30 +137,30 @@ ((null pushes)) (let ((push (first pushes))) (cond ((member push stack) - (assert (not popping))) + (aver (not popping))) ((eq push tailp-cont) - (assert (null (rest pushes)))) + (aver (null (rest pushes)))) (t (push push (ir2-block-end-stack 2block)) (setq popping t)))))) (values)) -;;; Called when we discover that the stack-top unknown-values continuation -;;; at the end of Block1 is different from that at the start of Block2 (its -;;; successor.) +;;; This is called when we discover that the stack-top unknown-values +;;; continuation at the end of BLOCK1 is different from that at the +;;; start of BLOCK2 (its successor). ;;; -;;; We insert a call to a funny function in a new cleanup block introduced -;;; between Block1 and Block2. Since control analysis and LTN have already -;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and -;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1 -;;; in the emit order. +;;; We insert a call to a funny function in a new cleanup block +;;; introduced between BLOCK1 and BLOCK2. Since control analysis and +;;; LTN have already run, we must do make an IR2 block, then do +;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new block. +;;; The new block is inserted after BLOCK1 in the emit order. ;;; -;;; If the control transfer between Block1 and Block2 represents a -;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then -;;; the cleanup code will never actually be executed. It doesn't seem to be -;;; worth the risk of trying to optimize this, since this rarely happens and -;;; wastes only space. +;;; If the control transfer between BLOCK1 and BLOCK2 represents a +;;; tail-recursive return (:DELETED IR2-continuation) or a non-local +;;; exit, then the cleanup code will never actually be executed. It +;;; doesn't seem to be worth the risk of trying to optimize this, +;;; since this rarely happens and wastes only space. (defun discard-unused-values (block1 block2) (declare (type cblock block1 block2)) (let* ((block1-stack (ir2-block-end-stack (block-info block1))) @@ -166,7 +169,7 @@ (- (length block1-stack) (length block2-stack) 1)))) - (assert (tailp block2-stack block1-stack)) + (aver (tailp block2-stack block1-stack)) (let* ((block (insert-cleanup-code block1 block2 (continuation-next (block-start block2)) @@ -174,7 +177,7 @@ (2block (make-ir2-block block))) (setf (block-info block) 2block) (add-to-emit-order 2block (block-info block1)) - (ltn-analyze-block block))) + (ltn-analyze-belated-block block))) (values))