X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=4bf7285bebb92ebbe3286d57a9b1caa521d5c664;hb=2a71a27c55ad98e36f2886017d45ca2ae986296d;hp=370c5a9bf13d328e1b285723d9bdc4d8d7fd6dc3;hpb=4ccd8dcd4b936ca6a0f989e12397bd9426905a11;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 370c5a9..4bf7285 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 @@ -164,7 +172,7 @@ (let ((*compiler-error-context* node)) (compiler-warn "New inferred type ~S conflicts with old type:~ - ~% ~S~%*** possible internal error? Please report this." + ~% ~S~%*** possible internal error? Please report this." (type-specifier rtype) (type-specifier node-type)))) (setf (node-derived-type node) int) ;; If the new type consists of only one object, replace 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)) @@ -336,12 +332,16 @@ ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) (block-home-lambda next))) - ;; Stack analysis phase wants ENTRY to start a block. + ;; Stack analysis phase wants ENTRY to start a block... (entry-p (block-start-node next)) (let ((last (block-last block))) (and (valued-node-p last) (awhen (node-lvar last) - (consp (lvar-uses it)))))) + (or + ;; ... and a DX-allocator to end a block. + (lvar-dynamic-extent it) + ;; FIXME: This is a partial workaround for bug 303. + (consp (lvar-uses it))))))) nil) (t (join-blocks block next) @@ -681,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))) @@ -738,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)) @@ -762,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 @@ -818,10 +807,11 @@ ;; called semi-inlining? A more descriptive name would ;; be nice. -- WHN 2002-01-07 (frob () - (let ((res (ir1-convert-lambda-for-defun - (defined-fun-inline-expansion leaf) - leaf t - #'ir1-convert-inline-lambda))) + (let ((res (let ((*allow-instrumenting* t)) + (ir1-convert-lambda-for-defun + (defined-fun-inline-expansion leaf) + leaf t + #'ir1-convert-inline-lambda)))) (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) (if ir1-converting-not-optimizing-p @@ -977,7 +967,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warn args)) + (apply #'warn args)) (remhash node table) nil) (:failure @@ -1061,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 @@ -1084,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) @@ -1219,11 +1207,21 @@ (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)))) + (flet ((max* (i j) + (cond ((eq i nil) nil) + ((eq j nil) nil) + (t (max i j))))) + (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)) - (numeric-type-low set-type)) + (flet ((min* (i j) + (cond ((eq i nil) nil) + ((eq j nil) nil) + (t (min i j))))) + (min* (numeric-type-low initial-type) + (numeric-type-low set-type)))) (numeric-type-high initial-type))) (t (values nil nil))) @@ -1310,8 +1308,10 @@ (dest (lvar-dest lvar))) (when (and ;; Think about (LET ((A ...)) (IF ... A ...)): two - ;; LVAR-USEs should not be met on one path. + ;; 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 @@ -1334,9 +1334,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) - (delete-lvar-use ref) (change-ref-leaf ref (find-constant nil)) (delete-ref ref) (unlink-node ref) @@ -1582,14 +1597,14 @@ (when (and min (< total-nvals min)) (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ - at least ~R." + at least ~R." total-nvals min) (setf (basic-combination-kind node) :error) (return-from ir1-optimize-mv-call)) (when (and max (> total-nvals max)) (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ - at most ~R." + at most ~R." total-nvals max) (setf (basic-combination-kind node) :error) (return-from ir1-optimize-mv-call)))