X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=3d06bd0aab0bee14026f92b8e9d0d7f089b7646f;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=b538652ed0d60021d48a9254a26dd1af0216d401;hpb=bfa4310e41dcd011ca9d139f29be1c5757b41378;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index b538652..3d06bd0 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) @@ -738,7 +738,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 +762,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 +821,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 @@ -1061,7 +1065,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,8 +1088,8 @@ (block-next (node-block call))) (let ((new-fun (ir1-convert-inline-lambda res - :debug-name (debug-namify "LAMBDA-inlined " - source-name + :debug-name (debug-namify "LAMBDA-inlined " + source-name ""))) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) @@ -1310,8 +1314,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 +1340,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 +1603,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)))