Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18647/src/compiler
Modified Files:
ir1opt.lisp ir1util.lisp locall.lisp main.lisp node.lisp
srctran.lisp
Log Message:
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.
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -d -r1.102 -r1.103
--- ir1opt.lisp 31 Oct 2004 05:34:23 -0000 1.102
+++ ir1opt.lisp 6 Nov 2004 07:11:24 -0000 1.103
@@ -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
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -d -r1.98 -r1.99
--- ir1util.lisp 26 Oct 2004 17:51:17 -0000 1.98
+++ ir1util.lisp 6 Nov 2004 07:11:25 -0000 1.99
@@ -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)))))))
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -d -r1.67 -r1.68
--- locall.lisp 26 Oct 2004 17:51:17 -0000 1.67
+++ locall.lisp 6 Nov 2004 07:11:26 -0000 1.68
@@ -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))
Index: main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -d -r1.100 -r1.101
--- main.lisp 1 Nov 2004 03:44:13 -0000 1.100
+++ main.lisp 6 Nov 2004 07:11:26 -0000 1.101
@@ -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))
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -d -r1.55 -r1.56
--- node.lisp 12 Oct 2004 22:01:42 -0000 1.55
+++ node.lisp 6 Nov 2004 07:11:26 -0000 1.56
@@ -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)
Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -d -r1.114 -r1.115
--- srctran.lisp 2 Nov 2004 11:49:32 -0000 1.114
+++ srctran.lisp 6 Nov 2004 07:11:27 -0000 1.115
@@ -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)
|