X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcontrol.lisp;h=3c4a3ff56fee7972fb6203e356a011edf58990c4;hb=54da325f13fb41669869aea688ae195426c0e231;hp=5df3e2f51fddcf7bbf64baf33d6e942c74d495b3;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 5df3e2f..3c4a3ff 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -47,33 +47,50 @@ ;;; suppress rotation of loop heads which are the start of a function ;;; (i.e. tail calls), as the debugger wants functions to start at the ;;; start. +;;; +;;; The rotation also is not done if the back edge identified in the +;;; first step originates from a block that has more than one successor. +;;; This matches loops that have their terminating condition tested at +;;; the end, for which the original block order already minimizes the +;;; number of branches: the back edge starts at a conditional branch at +;;; the loop's tail and no other branches are needed. We used not to +;;; test for this situation, rotating these loops, too, resulting in +;;; machine code that looked like this +;;; jump to L1 +;;; L0: body of loop +;;; conditionally branch to L2 if the loop should terminate +;;; L1: jump to L0 +;;; L2: +;;; which is ugly, and larger and often slower than what is generated +;;; when not rotating these loops. (defun find-rotated-loop-head (block) (declare (type cblock block)) (let* ((num (block-number block)) - (env (block-physenv block)) - (pred (dolist (pred (block-pred block) nil) - (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) - (< (block-number pred) num)) - (return pred))))) + (env (block-physenv block)) + (pred (dolist (pred (block-pred block) nil) + (when (and (not (block-flag pred)) + (eq (block-physenv pred) env) + (< (block-number pred) num)) + (return pred))))) (cond ((and pred - (not (physenv-nlx-info env)) - (not (eq (lambda-block (block-home-lambda block)) block))) + (not (physenv-nlx-info env)) + (not (eq (lambda-block (block-home-lambda block)) block)) + (null (cdr (block-succ pred)))) (let ((current pred) - (current-num (block-number pred))) - (block DONE - (loop - (dolist (pred (block-pred current) (return-from DONE)) - (when (eq pred block) - (return-from DONE)) - (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) - (> (block-number pred) current-num)) - (setq current pred current-num (block-number pred)) - (return))))) - (aver (not (block-flag current))) - current)) + (current-num (block-number pred))) + (block DONE + (loop + (dolist (pred (block-pred current) (return-from DONE)) + (when (eq pred block) + (return-from DONE)) + (when (and (not (block-flag pred)) + (eq (block-physenv pred) env) + (> (block-number pred) current-num)) + (setq current pred current-num (block-number pred)) + (return))))) + (aver (not (block-flag current))) + current)) (t block)))) @@ -96,34 +113,36 @@ ;;; (end in an error, NLX or tail full call.) This is to discourage ;;; making error code the drop-through. (defun control-analyze-block (block tail block-info-constructor) - (declare (type cblock block) (type block-annotation tail)) + (declare (type cblock block) + (type block-annotation tail) + (type function block-info-constructor)) (unless (block-flag block) (let ((block (find-rotated-loop-head block))) (setf (block-flag block) t) (aver (and (block-component block) (not (block-delete-p block)))) (add-to-emit-order (or (block-info block) - (setf (block-info block) - (funcall block-info-constructor block))) - (block-annotation-prev tail)) + (setf (block-info block) + (funcall block-info-constructor block))) + (block-annotation-prev tail)) (let ((last (block-last block))) - (cond ((and (combination-p last) (node-tail-p last) - (eq (basic-combination-kind last) :local) - (not (eq (node-physenv last) - (lambda-physenv (combination-lambda last))))) - (combination-lambda last)) - (t - (let ((component-tail (component-tail (block-component block))) - (block-succ (block-succ block)) - (fun nil)) - (dolist (succ block-succ) - (unless (eq (first (block-succ succ)) component-tail) - (let ((res (control-analyze-block - succ tail block-info-constructor))) - (when res (setq fun res))))) - (dolist (succ block-succ) - (control-analyze-block succ tail block-info-constructor)) - fun))))))) + (cond ((and (combination-p last) (node-tail-p last) + (eq (basic-combination-kind last) :local) + (not (eq (node-physenv last) + (lambda-physenv (combination-lambda last))))) + (combination-lambda last)) + (t + (let ((component-tail (component-tail (block-component block))) + (block-succ (block-succ block)) + (fun nil)) + (dolist (succ block-succ) + (unless (eq (first (block-succ succ)) component-tail) + (let ((res (control-analyze-block + succ tail block-info-constructor))) + (when res (setq fun res))))) + (dolist (succ block-succ) + (control-analyze-block succ tail block-info-constructor)) + fun))))))) ;;; Analyze all of the NLX EPs first to ensure that code reachable ;;; only from a NLX is emitted contiguously with the code reachable @@ -137,30 +156,32 @@ ;;; course, it will never get a drop-through if either function has ;;; NLX code. (defun control-analyze-1-fun (fun component block-info-constructor) - (declare (type clambda fun) (type component component)) + (declare (type clambda fun) + (type component component) + (type function block-info-constructor)) (let* ((tail-block (block-info (component-tail component))) - (prev-block (block-annotation-prev tail-block)) - (bind-block (node-block (lambda-bind fun)))) + (prev-block (block-annotation-prev tail-block)) + (bind-block (node-block (lambda-bind fun)))) (unless (block-flag bind-block) (dolist (nlx (physenv-nlx-info (lambda-physenv fun))) - (control-analyze-block (nlx-info-target nlx) tail-block - block-info-constructor)) + (control-analyze-block (nlx-info-target nlx) tail-block + block-info-constructor)) (cond ((block-flag bind-block) - (let* ((block-note (block-info bind-block)) - (prev (block-annotation-prev block-note)) - (next (block-annotation-next block-note))) - (setf (block-annotation-prev next) prev) - (setf (block-annotation-next prev) next) - (add-to-emit-order block-note prev-block))) + (let* ((block-note (block-info bind-block)) + (prev (block-annotation-prev block-note)) + (next (block-annotation-next block-note))) + (setf (block-annotation-prev next) prev) + (setf (block-annotation-next prev) next) + (add-to-emit-order block-note prev-block))) (t - (let ((new-fun (control-analyze-block bind-block - (block-annotation-next - prev-block) - block-info-constructor))) - (when new-fun - (control-analyze-1-fun new-fun component - block-info-constructor))))))) + (let ((new-fun (control-analyze-block bind-block + (block-annotation-next + prev-block) + block-info-constructor))) + (when new-fun + (control-analyze-1-fun new-fun component + block-info-constructor))))))) (values)) ;;; Do control analysis on COMPONENT, finding the emit order. Our only @@ -175,11 +196,11 @@ (defevent control-deleted-block "control analysis deleted dead block") (defun control-analyze (component block-info-constructor) (declare (type component component) - (type function block-info-constructor)) + (type function block-info-constructor)) (let* ((head (component-head component)) - (head-block (funcall block-info-constructor head)) - (tail (component-tail component)) - (tail-block (funcall block-info-constructor tail))) + (head-block (funcall block-info-constructor head)) + (tail (component-tail component)) + (tail-block (funcall block-info-constructor tail))) (setf (block-info head) head-block) (setf (block-info tail) tail-block) (setf (block-annotation-prev tail-block) head-block) @@ -189,21 +210,21 @@ (dolist (fun (component-lambdas component)) (when (xep-p fun) - (control-analyze-1-fun fun component block-info-constructor))) + (control-analyze-1-fun fun component block-info-constructor))) (dolist (fun (component-lambdas component)) (control-analyze-1-fun fun component block-info-constructor)) (do-blocks (block component) (unless (block-flag block) - (event control-deleted-block (continuation-next (block-start block))) - (delete-block block)))) + (event control-deleted-block (block-start-node block)) + (delete-block block)))) (let ((2comp (component-info component))) (when (ir2-component-p 2comp) ;; If it's not an IR2-COMPONENT, don't worry about it. (setf (ir2-component-values-receivers 2comp) - (delete-if-not #'block-component - (ir2-component-values-receivers 2comp))))) + (delete-if-not #'block-component + (ir2-component-values-receivers 2comp))))) (values))