X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=d585c2076d9903d6f5a6480fbda9488da80c3f0b;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=02b83404f7121a28e73546816a787c2d4a42f4a7;hpb=25e76ec2b1083ac6a4bba42af7ad7b5a8239f2b8;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 02b8340..d585c20 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -134,6 +134,7 @@ (let* ((fun (combination-fun dest)) (args (combination-args dest)) (fun-type (continuation-type fun))) + (setf (continuation-%externally-checkable-type fun) *wild-type*) (if (or (not (fun-type-p fun-type)) ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)). (fun-type-wild-args fun-type)) @@ -213,6 +214,11 @@ ~% ~S~%*** possible internal error? Please report this." (type-specifier rtype) (type-specifier node-type)))) (setf (node-derived-type node) int) + (when (and (ref-p node) + (member-type-p int) + (null (rest (member-type-members int))) + (lambda-var-p (ref-leaf node))) + (change-ref-leaf node (find-constant (first (member-type-members int))))) (reoptimize-continuation (node-cont node)))))) (values)) @@ -311,9 +317,15 @@ (let ((last (block-last block))) (typecase last (cif - (flush-dest (if-test last)) - (when (unlink-node last) - (return))) + (if (memq (continuation-type-check (if-test last)) + '(nil :deleted)) + ;; FIXME: Remove the test above when the bug 203 + ;; will be fixed. + (progn + (flush-dest (if-test last)) + (when (unlink-node last) + (return))) + (return))) (exit (when (maybe-delete-exit last) (return))))) @@ -508,10 +520,7 @@ :lossage-fun nil :unwinnage-fun nil)) (ir1-attributep attr unsafely-flushable))) - (flush-dest (combination-fun node)) - (dolist (arg (combination-args node)) - (flush-dest arg)) - (unlink-node node)))))) + (flush-combination node)))))) (mv-combination (when (eq (basic-combination-kind node) :local) (let ((fun (combination-lambda node))) @@ -580,7 +589,7 @@ ;;; all functions in the tail set to be equivalent, this amounts to ;;; bringing the entire tail set up to date. We iterate over the ;;; returns for all the functions in the tail set, reanalyzing them -;;; all (not treating Node specially.) +;;; all (not treating NODE specially.) ;;; ;;; When we are done, we check whether the new type is different from ;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize @@ -627,22 +636,25 @@ (convert-if-if use node) (when (continuation-use test) (return))))) - (let* ((type (continuation-type test)) - (victim - (cond ((constant-continuation-p test) - (if (continuation-value test) - (if-alternative node) - (if-consequent node))) - ((not (types-equal-or-intersect type (specifier-type 'null))) - (if-alternative node)) - ((type= type (specifier-type 'null)) - (if-consequent node))))) - (when victim - (flush-dest test) - (when (rest (block-succ block)) - (unlink-blocks block victim)) - (setf (component-reanalyze (node-component node)) t) - (unlink-node node)))) + (when (memq (continuation-type-check test) + '(nil :deleted)) + ;; FIXME: Remove the test above when the bug 203 will be fixed. + (let* ((type (continuation-type test)) + (victim + (cond ((constant-continuation-p test) + (if (continuation-value test) + (if-alternative node) + (if-consequent node))) + ((not (types-equal-or-intersect type (specifier-type 'null))) + (if-alternative node)) + ((type= type (specifier-type 'null)) + (if-consequent node))))) + (when victim + (flush-dest test) + (when (rest (block-succ block)) + (unlink-blocks block victim)) + (setf (component-reanalyze (node-component node)) t) + (unlink-node node))))) (values)) ;;; Create a new copy of an IF node that tests the value of the node @@ -1167,21 +1179,24 @@ ;;; possible to do this starting from debug names as well as source ;;; names, but as of sbcl-0.7.1.5, there was no need for this ;;; generality, since source names are always known to our callers.) -(defun transform-call (node res source-name) - (declare (type combination node) (list res)) +(defun transform-call (call res source-name) + (declare (type combination call) (list res)) (aver (and (legal-fun-name-p source-name) (not (eql source-name '.anonymous.)))) - (with-ir1-environment-from-node node + (node-ends-block call) + (with-ir1-environment-from-node call + (with-component-last-block (*current-component* + (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 "")))) - (ref (continuation-use (combination-fun node)))) + (ref (continuation-use (combination-fun call)))) (change-ref-leaf ref new-fun) - (setf (combination-kind node) :full) - (locall-analyze-component *current-component*))) + (setf (combination-kind call) :full) + (locall-analyze-component *current-component*)))) (values)) ;;; Replace a call to a foldable function of constant arguments with @@ -1254,7 +1269,8 @@ (setf (continuation-next cont) next) ;; FIXME: type checking? (reoptimize-continuation cont) - (reoptimize-continuation prev)))) + (reoptimize-continuation prev) + (flush-combination call)))) (t (let ((dummies (make-gensym-list (length args)))) (transform-call call @@ -1340,7 +1356,7 @@ ;;; -- either continuation has a funky TYPE-CHECK annotation. ;;; -- the continuations have incompatible assertions, so the new asserted type ;;; would be NIL. -;;; -- the var's DEST has a different policy than the ARG's (think safety). +;;; -- the VAR's DEST has a different policy than the ARG's (think safety). ;;; ;;; We change the REF to be a reference to NIL with unused value, and ;;; let it be flushed as dead code. A side effect of this substitution @@ -1354,7 +1370,7 @@ (dest (continuation-dest cont))) (when (and (eq (continuation-use cont) ref) dest - (not (typep dest '(or creturn exit mv-combination))) + (continuation-single-value-p cont) (eq (node-home-lambda ref) (lambda-home (lambda-var-home var))) (member (continuation-type-check arg) '(t nil)) @@ -1455,9 +1471,9 @@ ;;; If the function has an XEP, then we don't do anything, since we ;;; won't discover anything. ;;; -;;; We can clear the Continuation-Reoptimize flags for arguments in -;;; all calls corresponding to changed arguments in Call, since the -;;; only use in IR1 optimization of the Reoptimize flag for local call +;;; We can clear the CONTINUATION-REOPTIMIZE flags for arguments in +;;; all calls corresponding to changed arguments in CALL, since the +;;; only use in IR1 optimization of the REOPTIMIZE flag for local call ;;; args is right here. (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) @@ -1680,7 +1696,7 @@ (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) (collect ((res vals)) - (loop as cont = (make-continuation use) + (loop for cont = (make-continuation use) and prev = node-prev then cont repeat (- nvars nvals) do (reference-constant prev cont nil) @@ -1700,7 +1716,8 @@ (unlink-node call) (when vals (reoptimize-continuation (first vals))) - (propagate-to-args use fun)) + (propagate-to-args use fun) + (reoptimize-call use)) t))) ;;; If we see: @@ -1713,11 +1730,15 @@ ;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them ;;; args of the VALUES-LIST call, flushing the old argument ;;; continuation (allowing the LIST to be flushed.) +;;; +;;; FIXME: Thus we lose possible type assertions on (LIST ...). (defoptimizer (values-list optimizer) ((list) node) (let ((use (continuation-use list))) (when (and (combination-p use) (eq (continuation-fun-name (combination-fun use)) 'list)) + + ;; FIXME: VALUES might not satisfy an assertion on NODE-CONT. (change-ref-leaf (continuation-use (combination-fun node)) (find-free-fun 'values "in a strange place")) (setf (combination-kind node) :full) @@ -1734,8 +1755,7 @@ ;;; to a PROG1. This allows the computation of the additional values ;;; to become dead code. (deftransform values ((&rest vals) * * :node node) - (when (typep (continuation-dest (node-cont node)) - '(or creturn exit mv-combination)) + (unless (continuation-single-value-p (node-cont node)) (give-up-ir1-transform)) (setf (node-derived-type node) *wild-type*) (if vals