X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fstack.lisp;h=4ac4c7af2d82b5651b800da1dd2fd33a1b5b315c;hb=04c502ea9374372b1cd5d350aa95af4829fbae22;hp=6ab9bfde06651702981f83c3170c4d6d4142aadc;hpb=602c9b1f15e2d96e4b79a3341a734b5eb8e02093;p=sbcl.git diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 6ab9bfd..4ac4c7a 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -1,7 +1,10 @@ ;;;; 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 remove unused values. +;;;; analyse lifetime of dynamically allocated object packets on stack +;;;; and insert cleanups where necessary. +;;;; +;;;; Currently there are two kinds of interesting stack packets: UVLs, +;;;; whose use and destination lie in different blocks, and LVARs of +;;;; constructors of dynamic-extent objects. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -19,24 +22,25 @@ ;;; 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 lvar - (let ((dest (lvar-dest lvar)) - (2lvar (lvar-info lvar))) - (when (and (not (eq (node-block dest) block)) - 2lvar - (eq (ir2-lvar-kind 2lvar) :unknown)) - (aver (or saw-last (not last-pop))) - (pushed lvar)))))) + (when (and lvar + (or (lvar-dynamic-extent lvar) + (let ((dest (lvar-dest lvar)) + (2lvar (lvar-info lvar))) + (and (not (eq (node-block dest) block)) + 2lvar + (eq (ir2-lvar-kind 2lvar) :unknown))))) + (aver (or saw-last (not last-pop))) + (pushed lvar)))) (setf (ir2-block-pushed 2block) (pushed)))) (values)) @@ -86,7 +90,24 @@ nle-start-stack))) (setq new-end (merge-uvl-live-sets new-end next-stack)))) - block) + block + (lambda (dx-cleanup) + (dolist (lvar (cleanup-info dx-cleanup)) + (let* ((generator (lvar-use lvar)) + (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, 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))))))) (setf (ir2-block-end-stack 2block) new-end) @@ -96,12 +117,24 @@ ;; We cannot delete unused UVLs during NLX, so all UVLs live at ;; ENTRY will be actually live at NLE. + ;; + ;; BUT, UNWIND-PROTECTor is called in the environment, which has + ;; nothing in common with the environment of its entry. So we + ;; fictively compute its stack from the containing cleanups, but + ;; do not propagate additional LVARs from the entry, thus + ;; preveting bogus stack cleanings. + ;; + ;; TODO: Insert a check that no values are discarded in UWP. Or, + ;; maybe, we just don't need to create NLX-ENTRY for UWP? (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)))) + (let* ((nlx-info (nle-block-nlx-info block)) + (cleanup (nlx-info-cleanup nlx-info))) + (unless (eq (cleanup-kind cleanup) :unwind-protect) + (let* ((entry-block (node-block (cleanup-mess-up cleanup))) + (entry-stack (ir2-block-start-stack (block-info entry-block)))) + (setq start (merge-uvl-live-sets start entry-stack)))))) (when *check-consistency* (aver (subsetp original-start start))) @@ -237,33 +270,37 @@ ;;;; stack analysis ;;; Return a list of all the blocks containing genuine uses of one of -;;; the RECEIVERS. Exits are excluded, since they don't drop through -;;; to the receiver. -(defun find-values-generators (receivers) - (declare (list receivers)) +;;; the RECEIVERS (blocks) and DX-LVARS. Exits are excluded, since +;;; they don't drop through to the receiver. +(defun find-pushing-blocks (receivers dx-lvars) + (declare (list receivers dx-lvars)) (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)))) (res))) -;;; Analyze the use of unknown-values lvars in COMPONENT, inserting -;;; cleanup code to discard values that are generated but never -;;; 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. +;;; Analyze the use of unknown-values and DX lvars in COMPONENT, +;;; inserting cleanup code to discard values that are generated but +;;; never received. This phase doesn't need to be run when +;;; Values-Receivers and Dx-Lvars are null, i.e. there are no +;;; unknown-values lvars used across block boundaries and no DX LVARs. (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) - (receivers (ir2-component-values-receivers 2comp)) - (generators (find-values-generators receivers))) + (receivers (ir2-component-values-receivers 2comp)) + (generators (find-pushing-blocks receivers + (component-dx-lvars component)))) (dolist (block generators) (find-pushed-lvars block)) - ;;; Compute sets of live UVLs + ;;; Compute sets of live UVLs and DX LVARs (loop for did-something = nil do (do-blocks-backwards (block component) (when (update-uvl-live-sets block) @@ -274,10 +311,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))