From ea12c1295d511ba5242f3ce64c44e1e445f72cc8 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 6 Nov 2004 07:11:24 +0000 Subject: [PATCH] 0.8.16.34: * Fix MISC.437: differ necessary and unnecessary component reoptimizations; unused code flushing is necassary (for variable references). ... disable forward optimization pass after running out of reoptimization limit. --- src/compiler/ir1opt.lisp | 18 +++++++++++++----- src/compiler/ir1util.lisp | 6 +++--- src/compiler/locall.lisp | 4 ++-- src/compiler/main.lisp | 13 ++++++++----- src/compiler/node.lisp | 7 ++++--- src/compiler/srctran.lisp | 2 +- tests/compiler.pure.lisp | 20 ++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 52 insertions(+), 20 deletions(-) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 28f338a..73a3247 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -107,6 +107,14 @@ ;;;; interface routines used by optimizers +(declaim (inline reoptimize-component)) +(defun reoptimize-component (component kind) + (declare (type component component) + (type (member nil :maybe t) kind)) + (aver kind) + (unless (eq (component-reoptimize component) t) + (setf (component-reoptimize component) kind))) + ;;; This function is called by optimizers to indicate that something ;;; interesting has happened to the value of LVAR. Optimizers must ;;; make sure that they don't call for reoptimization when nothing has @@ -130,7 +138,7 @@ (when (typep dest 'cif) (setf (block-test-modified block) t)) (setf (block-reoptimize block) t) - (setf (component-reoptimize component) t)))) + (reoptimize-component component :maybe)))) (do-uses (node lvar) (setf (block-type-check (node-block node)) t))) (values)) @@ -140,7 +148,7 @@ (do-uses (use lvar) (setf (node-reoptimize use) t) (setf (block-reoptimize (node-block use)) t) - (setf (component-reoptimize (node-component use)) t))) + (reoptimize-component (node-component use) :maybe))) ;;; Annotate NODE to indicate that its result has been proven to be ;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the @@ -213,7 +221,7 @@ ;;; and doing IR1 optimizations. We can ignore all blocks that don't ;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when ;;; we are done, then another iteration would be beneficial. -(defun ir1-optimize (component) +(defun ir1-optimize (component fastp) (declare (type component component)) (setf (component-reoptimize component) nil) (loop with block = (block-next (component-head component)) @@ -255,7 +263,7 @@ (unless (join-successor-if-possible block) (return))) - (when (and (block-reoptimize block) (block-component block)) + (when (and (not fastp) (block-reoptimize block) (block-component block)) (aver (not (block-delete-p block))) (ir1-optimize-block block)) @@ -1069,7 +1077,7 @@ (setf (node-reoptimize node) t) (let ((block (node-block node))) (setf (block-reoptimize block) t) - (setf (component-reoptimize (block-component block)) t))))))) + (reoptimize-component (block-component block) :maybe))))))) reoptimize)) ;;; Take the lambda-expression RES, IR1 convert it in the proper diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 8f8cee0..5126c04 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -672,7 +672,7 @@ (frob if-alternative) (when (eq (if-consequent last) (if-alternative last)) - (setf (component-reoptimize (block-component block)) t))))) + (reoptimize-component (block-component block) :maybe))))) (t (unless (memq new (block-succ block)) (link-blocks block new))))) @@ -1036,7 +1036,7 @@ (do-uses (use lvar) (let ((prev (node-prev use))) (let ((block (ctran-block prev))) - (setf (component-reoptimize (block-component block)) t) + (reoptimize-component (block-component block) t) (setf (block-attributep (block-flags block) flush-p type-asserted type-check) t))) @@ -1773,4 +1773,4 @@ (do-uses (node lvar) (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t))))))) + (reoptimize-component (node-component node) :maybe))))))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index b6da50b..f1c7feb 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -233,8 +233,8 @@ (leaf-ever-used res) t (functional-entry-fun res) fun (functional-entry-fun fun) res - (component-reanalyze *current-component*) t - (component-reoptimize *current-component*) t) + (component-reanalyze *current-component*) t) + (reoptimize-component *current-component* :maybe) (etypecase fun (clambda (locall-analyze-fun-1 fun)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index cabe030..efb342c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -287,18 +287,20 @@ (maybe-mumble "opt") (event ir1-optimize-until-done) (let ((count 0) - (cleared-reanalyze nil)) + (cleared-reanalyze nil) + (fastp nil)) (loop (when (component-reanalyze component) (setq count 0) (setq cleared-reanalyze t) (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) - (ir1-optimize component) + (ir1-optimize component fastp) (cond ((component-reoptimize component) (incf count) - (when (and (= count *max-optimize-iterations*) - (not (component-reanalyze component))) + (when (and (>= count *max-optimize-iterations*) + (not (component-reanalyze component)) + (eq (component-reoptimize component) :maybe)) (maybe-mumble "*") (cond ((retry-delayed-ir1-transforms :optimize) (maybe-mumble "+") @@ -315,7 +317,8 @@ (t (maybe-mumble " ") (return))) - (maybe-mumble ".")) + (setq fastp (>= count *max-optimize-iterations*)) + (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 4f0ad48..392bea6 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -348,9 +348,10 @@ ;; Between runs of local call analysis there may be some debris of ;; converted or even deleted functions in this list. (new-functionals () :type list) - ;; If this is true, then there is stuff in this component that could - ;; benefit from further IR1 optimization. - (reoptimize t :type boolean) + ;; If this is :MAYBE, then there is stuff in this component that + ;; could benefit from further IR1 optimization. T means that + ;; reoptimization is necessary. + (reoptimize t :type (member nil :maybe t)) ;; If this is true, then the control flow in this component was ;; messed up by IR1 optimizations, so the DFO should be recomputed. (reanalyze nil :type boolean) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 9c832e3..c1da98b 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2580,7 +2580,7 @@ (setf (lvar-%derived-type (node-lvar node)) nil) (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t)) + (reoptimize-component (node-component node) :maybe)) (cut-node (node &aux did-something) (when (and (not (block-delete-p (node-block node))) (combination-p node) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ac701a6..1f651bf 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1618,3 +1618,23 @@ (elt '(102) (flet ((%f12 () (rem 0 -43))) (multiple-value-call #'%f12 (values)))))))))) + +;;; MISC.437: lost reoptimization after FLUSH-DEST +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d e) + (declare (notinline values complex eql)) + (declare + (optimize (compilation-speed 3) + (speed 3) + (debug 1) + (safety 1) + (space 0))) + (flet ((%f10 + (f10-1 f10-2 f10-3 + &optional (f10-4 (ignore-errors 0)) (f10-5 0) + &key &allow-other-keys) + (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) + (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) + 80043 74953652306 33658947 -63099937105 -27842393))) diff --git a/version.lisp-expr b/version.lisp-expr index 1939c70..9075dd3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.16.33" +"0.8.16.34" -- 1.7.10.4