X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fstack.lisp;h=4eeae72338ca7c36b1eba32f16b7d78cb43847da;hb=69e6aef5e6fb3bd682c7a2cbf774034d2ea58ee8;hp=fccf4f8a8db902d340cf0acfa4b94b0cb097d5ce;hpb=8902b8b6bd2e9285749dd39d313b33b6c69c5213;p=sbcl.git diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index fccf4f8..4eeae72 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -22,17 +22,17 @@ ;;; invariant that all pushes come after the last pop. (defun find-pushed-lvars (block) (let* ((2block (block-info block)) - (popped (ir2-block-popped 2block)) - (last-pop (if popped - (lvar-dest (car (last popped))) - nil))) + (popped (ir2-block-popped 2block)) + (last-pop (if popped + (lvar-dest (car (last popped))) + nil))) (collect ((pushed)) (let ((saw-last nil)) - (do-nodes (node lvar block) - (when (eq node last-pop) - (setq saw-last t)) + (do-nodes (node lvar block) + (when (eq node last-pop) + (setq saw-last t)) - (when (and lvar + (when (and lvar (or (lvar-dynamic-extent lvar) (let ((dest (lvar-dest lvar)) (2lvar (lvar-info lvar))) @@ -61,6 +61,7 @@ ;;; been changed. (defun merge-uvl-live-sets (early late) (declare (type list early late)) + ;; FIXME: O(N^2) (dolist (e late early) (pushnew e early))) @@ -93,22 +94,28 @@ block (lambda (dx-cleanup) (dolist (lvar (cleanup-info dx-cleanup)) - (let* ((generator (lvar-use lvar)) - (block (node-block generator)) - (2block (block-info block))) - (aver (eq generator (block-last block))) - ;; DX objects, living in the LVAR, are - ;; alive in the environment, protected by - ;; the CLEANUP. We also cannot move them - ;; (because, in general, we cannot track - ;; all references to them). Therefore, - ;; everything, allocated deeper than a DX - ;; object, should be kept alive until the - ;; object is deallocated. - (setq new-end (merge-uvl-live-sets - new-end (ir2-block-end-stack 2block))) - (setq new-end (merge-uvl-live-sets - new-end (ir2-block-pushed 2block))))))) + (do-uses (generator lvar) + (let* ((block (node-block generator)) + (2block (block-info block))) + ;; DX objects, living in the LVAR, are alive in + ;; the environment, protected by the CLEANUP. We + ;; also cannot move them (because, in general, we + ;; cannot track all references to them). + ;; Therefore, everything, allocated deeper than a + ;; DX object -- that is, before the DX object -- + ;; should be kept alive until the object is + ;; deallocated. + ;; + ;; Since DX generators end their blocks, we can + ;; find out UVLs allocated before them by looking + ;; at the stack at the end of the block. + ;; + ;; FIXME: This is not quite true: REFs to DX + ;; closures don't end their blocks! + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-end-stack 2block))) + (setq new-end (merge-uvl-live-sets + new-end (ir2-block-pushed 2block)))))))) (setf (ir2-block-end-stack 2block) new-end) @@ -182,22 +189,32 @@ (defun order-uvl-sets (component) (clear-flags component) + ;; KLUDGE: Workaround for lp#308914: we keep track of number of blocks + ;; needing repeats, and bug out if we get stuck. (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)) + with todo = 0 + with last-todo = 0 + do (psetq last-todo todo + todo 0) + do (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 + (incf todo)))))) + do (when (= last-todo todo) + ;; If the todo count is the same as on last iteration, it means + ;; we are stuck, which in turn means the unmarked blocks are + ;; actually unreachable, so UVL set ordering for them doesn't + ;; matter. + (return-from order-uvl-sets)) + while (plusp todo))) ;;; 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 @@ -278,9 +295,9 @@ (collect ((res nil adjoin)) (dolist (rec receivers) (dolist (pop (ir2-block-popped (block-info rec))) - (do-uses (use pop) - (unless (exit-p use) - (res (node-block use)))))) + (do-uses (use pop) + (unless (exit-p use) + (res (node-block use)))))) (dolist (dx-lvar dx-lvars) (do-uses (use dx-lvar) (res (node-block use)))) @@ -294,8 +311,8 @@ (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) - (receivers (ir2-component-values-receivers 2comp)) - (generators (find-pushing-blocks receivers + (receivers (ir2-component-values-receivers 2comp)) + (generators (find-pushing-blocks receivers (component-dx-lvars component)))) (dolist (block generators) @@ -312,10 +329,10 @@ (do-blocks (block component) (let ((top (ir2-block-end-stack (block-info block)))) - (dolist (succ (block-succ block)) - (when (and (block-start succ) - (not (eq (ir2-block-start-stack (block-info succ)) - top))) - (discard-unused-values block succ)))))) + (dolist (succ (block-succ block)) + (when (and (block-start succ) + (not (eq (ir2-block-start-stack (block-info succ)) + top))) + (discard-unused-values block succ)))))) (values))