X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=3d06bd0aab0bee14026f92b8e9d0d7f089b7646f;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=9bf0a584ccaf103e1958d4d269680100599b6433;hpb=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 9bf0a58..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,8 +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. - (entry-p (block-start-node next))) + ;; 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) + (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) @@ -734,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)) @@ -758,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 @@ -814,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 @@ -905,7 +913,9 @@ (lvar-uses (basic-combination-fun call)) call)) ((not leaf)) - ((and (leaf-has-source-name-p leaf) + ((and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (leaf-has-source-name-p leaf) (or (info :function :source-transform (leaf-source-name leaf)) (and info (ir1-attributep (fun-info-attributes info) @@ -971,7 +981,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warn args)) + (apply #'warn args)) (remhash node table) nil) (:failure @@ -1055,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 @@ -1078,10 +1088,9 @@ (block-next (node-block call))) (let ((new-fun (ir1-convert-inline-lambda res - :debug-name (debug-namify "LAMBDA-inlined ~A" - (as-debug-name - source-name - "")))) + :debug-name (debug-namify "LAMBDA-inlined " + source-name + ""))) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) @@ -1305,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 @@ -1329,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) @@ -1577,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))) @@ -1746,7 +1772,9 @@ (unless next-block (when ctran (ensure-block-start ctran)) (setq next-block (first (block-succ (node-block cast)))) - (ensure-block-start (node-prev cast))) + (ensure-block-start (node-prev cast)) + (reoptimize-lvar lvar) + (setf (lvar-%derived-type value) nil)) (%delete-lvar-use use) (add-lvar-use use lvar) (unlink-blocks (node-block use) (node-block cast)) @@ -1767,7 +1795,9 @@ ;; FIXME: Do it in one step. (filter-lvar value - `(multiple-value-call #'list 'dummy)) + (if (cast-single-value-p cast) + `(list 'dummy) + `(multiple-value-call #'list 'dummy))) (filter-lvar (cast-value cast) ;; FIXME: Derived type.