\f
;;;; 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
(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))
(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
;;; 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))
(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))
(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
(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)))))
(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)))
(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)))))))
(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))
(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 "+")
(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))
;; 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)
(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)
(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)))
;;; 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"
projects / sbcl.git / commitdiff