[Sbcl-commits] master: src/compiler/stack: Be more clever about back-propagation of DX LVARs.

[Alastair B. <lis...@us...>]

The branch "master" has been updated in SBCL:
       via  bd1da352123f1ba3991ef2cceb8e74001ed72180 (commit)
      from  db6ba6852b8f6d6cf965c1363fc3e3e4b581589c (commit)

- Log -----------------------------------------------------------------
commit bd1da352123f1ba3991ef2cceb8e74001ed72180
Author: Alastair Bridgewater <ala...@gm...>
Date:   Mon Feb 16 09:32:49 2015 -0500

    src/compiler/stack: Be more clever about back-propagation of DX LVARs.
    
      * DX LVARs don't represent values, they represent storage for
    values.  In some cases the storage can be conditionally allocated,
    while the value itself is still valid (such as in (IF X (CONS ...))
    which could lead to not finding a USE of the LVAR along one
    backwards path, thus leading to it being considered live on entry
    to the function.  Not exactly excellent.
    
      * Use a depth-first-search to do back-propagation of DX LVARs
    from their environment entry to their USEs only along control-flow
    paths which actually allocate the LVARs, with appropriate
    cleverness to prevent getting stuck in loops or searching "too far
    back".
    
      * This is in support of fixing lp#1044465, but doesn't actually
    affect the symptom, let alone cause correct code to be generated.
---
 src/compiler/main.lisp  |    1 +
 src/compiler/stack.lisp |   76 ++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 76 insertions(+), 1 deletions(-)

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index dc9a82a..57142af 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -547,6 +547,7 @@ necessary, since type inference may take arbitrarily long to converge.")
     (when (or (ir2-component-values-receivers (component-info component))
               (component-dx-lvars component))
       (maybe-mumble "stack ")
+      (find-dominators component)
       (stack-analyze component)
       ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by
       ;; stack analysis. There shouldn't be any unreachable code after
diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 4eeae72..6e425e6 100644
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -65,6 +65,64 @@
   (dolist (e late early)
     (pushnew e early)))
 
+;; Blocks are numbered in reverse DFO order, so the "lowest common
+;; dominator" of a set of blocks is the closest dominator of all of
+;; the blocks.
+(defun find-lowest-common-dominator (blocks)
+  ;; FIXME: NIL is defined as a valid value for BLOCK-DOMINATORS,
+  ;; meaning "all blocks in component".  Actually handle this case.
+  (let ((common-dominators (copy-sset (block-dominators (first blocks)))))
+    (dolist (block (rest blocks))
+      (sset-intersection common-dominators (block-dominators block)))
+    (let ((lowest-dominator))
+      (do-sset-elements (dominator common-dominators lowest-dominator)
+        (when (or (not lowest-dominator)
+                  (< (sset-element-number dominator)
+                     (sset-element-number lowest-dominator)))
+          (setf lowest-dominator dominator))))))
+
+;;; Carefully back-propagate DX LVARs from the start of their
+;;; environment to where they are allocated, along all code paths
+;;; which actually allocate said LVARs.
+(defun back-propagate-one-dx-lvar (block dx-lvar)
+  (declare (type cblock block)
+           (type lvar dx-lvar))
+  ;; We have to back-propagate the lifetime of DX-LVAR to its USEs,
+  ;; but only along the paths which actually USE it.  The naive
+  ;; solution (which we're going with for now) is a depth-first search
+  ;; over an arbitrarily complex chunk of flow graph that is known to
+  ;; have a single entry block.
+  (let* ((use-blocks (mapcar #'node-block (find-uses dx-lvar)))
+         (start-block (find-lowest-common-dominator
+                       (list* block use-blocks))))
+    (labels ((mark-lvar-live-on-path (block-list)
+               (dolist (block block-list)
+                 (let ((2block (block-info block)))
+                   (pushnew dx-lvar (ir2-block-end-stack 2block))
+                   (pushnew dx-lvar (ir2-block-start-stack 2block)))))
+             (back-propagate-pathwise (current-block path)
+               (cond
+                 ((member current-block use-blocks)
+                  ;; The LVAR is live on exit from a use-block, but
+                  ;; not on entry.
+                  (pushnew dx-lvar (ir2-block-end-stack
+                                    (block-info current-block)))
+                  (mark-lvar-live-on-path path))
+                 ;; Don't go back past START-BLOCK, and don't loop.
+                 ((and (not (eq current-block start-block))
+                       (not (member current-block path)))
+                  (let ((new-path (list* current-block path)))
+                    (declare (dynamic-extent new-path))
+                    (dolist (pred-block (block-pred current-block))
+                      (back-propagate-pathwise pred-block new-path)))))))
+      (back-propagate-pathwise block nil))))
+
+(defun back-propagate-dx-lvars (block dx-lvars)
+  (declare (type cblock block)
+           (type list dx-lvars))
+  (dolist (dx-lvar dx-lvars)
+    (back-propagate-one-dx-lvar block dx-lvar)))
+
 ;;; Update information on stacks of unknown-values LVARs on the
 ;;; boundaries of BLOCK. Return true if the start stack has been
 ;;; changed.
@@ -80,7 +138,11 @@
          (new-end end))
     (dolist (succ (block-succ block))
       (setq new-end (merge-uvl-live-sets new-end
-                                         (ir2-block-start-stack (block-info succ)))))
+                                         ;; Don't back-propagate DX
+                                         ;; LVARs automatically,
+                                         ;; they're handled specially.
+                                         (remove-if #'lvar-dynamic-extent
+                                                    (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
@@ -119,6 +181,18 @@
 
     (setf (ir2-block-end-stack 2block) new-end)
 
+    ;; If a block starts with an "entry DX" node (the start of a DX
+    ;; environment) then we need to back-propagate the DX LVARs to
+    ;; their allocation sites.  We need to be clever about this
+    ;; because some code paths may not allocate all of the DX LVARs.
+    ;;
+    ;; FIXME: Use BLOCK-FLAG to make this happen only once.
+    (let ((first-node (ctran-next (block-start block))))
+      (when (typep first-node 'entry)
+        (let ((cleanup (entry-cleanup first-node)))
+          (when (eq (cleanup-kind cleanup) :dynamic-extent)
+            (back-propagate-dx-lvars block (cleanup-info cleanup))))))
+
     (let ((start new-end))
       (setq start (set-difference start (ir2-block-pushed 2block)))
       (setq start (merge-uvl-live-sets start (ir2-block-popped 2block)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL