X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=34117f5c42ed44b92fcd1fe53eaca96d93bf787a;hb=16a6592367eec7c5e9da668ec42fd260e7705b0c;hp=95b4357e81dc362ebbd56970c9670e3653075403;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 95b4357..34117f5 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 @@ -187,24 +195,12 @@ (defun assert-lvar-type (lvar type policy) (declare (type lvar lvar) (type ctype type)) (unless (values-subtypep (lvar-derived-type lvar) type) - (let* ((dest (lvar-dest lvar)) - (ctran (node-prev dest))) - (with-ir1-environment-from-node dest - (let* ((cast (make-cast lvar type policy)) - (internal-lvar (make-lvar)) - (internal-ctran (make-ctran))) - (setf (ctran-next ctran) cast - (node-prev cast) ctran) - (use-continuation cast internal-ctran internal-lvar) - (link-node-to-previous-ctran dest internal-ctran) - (substitute-lvar internal-lvar lvar) - (setf (lvar-dest lvar) cast) - (reoptimize-lvar lvar) - (when (return-p dest) - (node-ends-block cast)) - (setf (block-attributep (block-flags (node-block cast)) - type-check type-asserted) - t)))))) + (let ((internal-lvar (make-lvar)) + (dest (lvar-dest lvar))) + (substitute-lvar internal-lvar lvar) + (let ((cast (insert-cast-before dest lvar type policy))) + (use-lvar cast internal-lvar)))) + (values)) ;;;; IR1-OPTIMIZE @@ -213,7 +209,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 +251,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)) @@ -685,21 +681,7 @@ ;; function arguments. -- WHN 19990918 (not (ir1-attributep attr call)) (every #'constant-lvar-p args) - (node-lvar node) - ;; Even if the function is foldable in principle, - ;; it might be one of our low-level - ;; implementation-specific functions. Such - ;; functions don't necessarily exist at runtime on - ;; a plain vanilla ANSI Common Lisp - ;; cross-compilation host, in which case the - ;; cross-compiler can't fold it because the - ;; cross-compiler doesn't know how to evaluate it. - #+sb-xc-host - (or (fboundp (combination-fun-source-name node)) - (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%" - (combination-fun-source-name node) - (mapcar #'lvar-value args)) - nil))) + (node-lvar node)) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -742,7 +724,7 @@ ;;; ;;; Why do we need to consider LVAR type? -- APD, 2003-07-30 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p) - (declare (type (or basic-combination cast) node)) + (declare (type (or basic-combination cast ref) node)) (let* ((block (node-block node)) (lvar (node-lvar node)) (ctran (node-next node)) @@ -766,13 +748,16 @@ (t (node-ends-block node))) - (unlink-blocks block (first (block-succ block))) - (setf (component-reanalyze (block-component block)) t) - (aver (not (block-succ block))) - (link-blocks block tail) - (if ir1-converting-not-optimizing-p - (%delete-lvar-use node) - (delete-lvar-use node)) + (let ((succ (first (block-succ block)))) + (unlink-blocks block succ) + (setf (component-reanalyze (block-component block)) t) + (aver (not (block-succ block))) + (link-blocks block tail) + (cond (ir1-converting-not-optimizing-p + (%delete-lvar-use node)) + (t (delete-lvar-use node) + (when (null (block-pred succ)) + (mark-for-deletion succ))))) t)))) ;;; This is called both by IR1 conversion and IR1 optimization when @@ -1066,7 +1051,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 @@ -1089,9 +1074,7 @@ (block-next (node-block call))) (let ((new-fun (ir1-convert-inline-lambda res - :debug-name (debug-namify "LAMBDA-inlined " - source-name - ""))) + :debug-name (debug-name 'lambda-inlined source-name))) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) @@ -1143,7 +1126,15 @@ ;; COMPILER-WARNING (and thus return FAILURE-P=T ;; from COMPILE-FILE) for legal code, so we we ;; use a wimpier COMPILE-STYLE-WARNING instead. - #'compiler-style-warn + #-sb-xc-host #'compiler-style-warn + ;; On the other hand, for code we control, we + ;; should be able to work around any bug + ;; 173-related problems, and in particular we + ;; want to be alerted to calls to our own + ;; functions which aren't being folded away; a + ;; COMPILER-WARNING is butch enough to stop the + ;; SBCL build itself in its tracks. + #+sb-xc-host #'compiler-warn "constant folding") (cond ((not win) (setf (combination-kind call) :error)) @@ -1219,23 +1210,42 @@ (when (and (numeric-type-p initial-type) (numeric-type-p step-type) (numeric-type-equal initial-type step-type)) - (multiple-value-bind (low high) - (cond ((csubtypep step-type (specifier-type '(real 0 *))) - (values (numeric-type-low initial-type) - (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (numeric-type-high set-type)))) - ((csubtypep step-type (specifier-type '(real * 0))) - (values (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (numeric-type-low set-type)) - (numeric-type-high initial-type))) - (t - (values nil nil))) - (modified-numeric-type initial-type - :low low - :high high - :enumerable nil))))) + (labels ((leftmost (x y cmp cmp=) + (cond ((eq x nil) nil) + ((eq y nil) nil) + ((listp x) + (let ((x1 (first x))) + (cond ((listp y) + (let ((y1 (first y))) + (if (funcall cmp x1 y1) x y))) + (t + (if (funcall cmp x1 y) x y))))) + ((listp y) + (let ((y1 (first y))) + (if (funcall cmp= x y1) x y))) + (t (if (funcall cmp x y) x y)))) + (max* (x y) (leftmost x y #'> #'>=)) + (min* (x y) (leftmost x y #'< #'<=))) + (declare (inline compare)) + (multiple-value-bind (low high) + (cond ((csubtypep step-type (specifier-type '(real 0 *))) + (values (numeric-type-low initial-type) + (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (max* (numeric-type-high initial-type) + (numeric-type-high set-type))))) + ((csubtypep step-type (specifier-type '(real * 0))) + (values (when (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (min* (numeric-type-low initial-type) + (numeric-type-low set-type))) + (numeric-type-high initial-type))) + (t + (values nil nil))) + (modified-numeric-type initial-type + :low low + :high high + :enumerable nil)))))) (deftransform + ((x y) * * :result result) "check for iteration variable reoptimization" (let ((dest (principal-lvar-end result)) @@ -1318,6 +1328,7 @@ ;; LVAR-USEs should not be met on one path. Another problem ;; is with dynamic-extent. (eq (lvar-uses lvar) ref) + (not (block-delete-p (node-block ref))) (typecase dest ;; we should not change lifetime of unknown values lvars (cast @@ -1340,11 +1351,24 @@ t)) (eq (node-home-lambda ref) (lambda-home (lambda-var-home var)))) + (let ((ref-type (single-value-type (node-derived-type ref)))) + (cond ((csubtypep (single-value-type (lvar-type arg)) ref-type) + (substitute-lvar-uses lvar arg + ;; Really it is (EQ (LVAR-USES LVAR) REF): + t) + (delete-lvar-use ref)) + (t + (let* ((value (make-lvar)) + (cast (insert-cast-before ref value ref-type + ;; KLUDGE: it should be (TYPE-CHECK 0) + *policy*))) + (setf (cast-type-to-check cast) *wild-type*) + (substitute-lvar-uses value arg + ;; FIXME + t) + (%delete-lvar-use ref) + (add-lvar-use cast lvar))))) (setf (node-derived-type ref) *wild-type*) - (substitute-lvar-uses lvar arg - ;; Really it is (EQ (LVAR-USES LVAR) REF): - t) - (delete-lvar-use ref) (change-ref-leaf ref (find-constant nil)) (delete-ref ref) (unlink-node ref)