X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=61aea84dedfed1b215568ccc36cec5d7cab6409f;hb=8dd43b84a688fde72f6d957c59f7207d539990f7;hp=c882a0fcfb8e486dd1285415d8f0a17cd541eb9b;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index c882a0f..61aea84 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -18,15 +18,16 @@ ;;;; interface for obtaining results of constant folding -;;; Return true for a CONTINUATION whose sole use is a reference to a +;;; Return true for an LVAR whose sole use is a reference to a ;;; constant leaf. (defun constant-lvar-p (thing) + (declare (type (or lvar null) thing)) (and (lvar-p thing) (let ((use (principal-lvar-use thing))) (and (ref-p use) (constant-p (ref-leaf use)))))) -;;; Return the constant value for a continuation whose only use is a -;;; constant node. +;;; Return the constant value for an LVAR whose only use is a constant +;;; node. (declaim (ftype (function (lvar) t) lvar-value)) (defun lvar-value (lvar) (let ((use (principal-lvar-use lvar))) @@ -34,23 +35,13 @@ ;;;; interface for obtaining results of type inference -;;; Our best guess for the type of this continuation's value. Note -;;; that this may be VALUES or FUNCTION type, which cannot be passed -;;; as an argument to the normal type operations. See -;;; CONTINUATION-TYPE. This may be called on deleted continuations, -;;; always returning *. +;;; Our best guess for the type of this lvar's value. Note that this +;;; may be VALUES or FUNCTION type, which cannot be passed as an +;;; argument to the normal type operations. See LVAR-TYPE. ;;; -;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the -;;; result is a subtype of the assertion. If so, return the proven -;;; type and set TYPE-CHECK to NIL. Otherwise, return the intersection -;;; of the asserted and proven types, and set TYPE-CHECK T. If -;;; TYPE-CHECK already has a non-null value, then preserve it. Only in -;;; the somewhat unusual circumstance of a newly discovered assertion -;;; will we change TYPE-CHECK from NIL to T. -;;; -;;; The result value is cached in the CONTINUATION-%DERIVED-TYPE slot. -;;; If the slot is true, just return that value, otherwise recompute -;;; and stash the value there. +;;; The result value is cached in the LVAR-%DERIVED-TYPE slot. If the +;;; slot is true, just return that value, otherwise recompute and +;;; stash the value there. #!-sb-fluid (declaim (inline lvar-derived-type)) (defun lvar-derived-type (lvar) (declare (type lvar lvar)) @@ -70,14 +61,14 @@ (t (node-derived-type (lvar-uses lvar)))))) -;;; Return the derived type for CONT's first value. This is guaranteed +;;; Return the derived type for LVAR's first value. This is guaranteed ;;; not to be a VALUES or FUNCTION type. (declaim (ftype (sfunction (lvar) ctype) lvar-type)) (defun lvar-type (lvar) (single-value-type (lvar-derived-type lvar))) -;;; If CONT is an argument of a function, return a type which the -;;; function checks CONT for. +;;; If LVAR is an argument of a function, return a type which the +;;; function checks LVAR for. #!-sb-fluid (declaim (inline lvar-externally-checkable-type)) (defun lvar-externally-checkable-type (lvar) (or (lvar-%externally-checkable-type lvar) @@ -225,49 +216,55 @@ (defun ir1-optimize (component) (declare (type component component)) (setf (component-reoptimize component) nil) - (do-blocks (block component) - (cond - ;; We delete blocks when there is either no predecessor or the - ;; block is in a lambda that has been deleted. These blocks - ;; would eventually be deleted by DFO recomputation, but doing - ;; it here immediately makes the effect available to IR1 - ;; optimization. - ((or (block-delete-p block) - (null (block-pred block))) - (delete-block block)) - ((eq (functional-kind (block-home-lambda block)) :deleted) - ;; Preserve the BLOCK-SUCC invariant that almost every block has - ;; one successor (and a block with DELETE-P set is an acceptable - ;; exception). - (mark-for-deletion block) - (delete-block block)) - (t - (loop - (let ((succ (block-succ block))) - (unless (singleton-p succ) - (return))) - - (let ((last (block-last block))) - (typecase last - (cif - (flush-dest (if-test last)) - (when (unlink-node last) - (return))) - (exit - (when (maybe-delete-exit last) - (return))))) - - (unless (join-successor-if-possible block) - (return))) - - (when (and (block-reoptimize block) (block-component block)) - (aver (not (block-delete-p block))) - (ir1-optimize-block block)) - - (cond ((and (block-delete-p block) (block-component block)) - (delete-block block)) - ((and (block-flush-p block) (block-component block)) - (flush-dead-code block)))))) + (loop with block = (block-next (component-head component)) + with tail = (component-tail component) + for last-block = block + until (eq block tail) + do (cond + ;; We delete blocks when there is either no predecessor or the + ;; block is in a lambda that has been deleted. These blocks + ;; would eventually be deleted by DFO recomputation, but doing + ;; it here immediately makes the effect available to IR1 + ;; optimization. + ((or (block-delete-p block) + (null (block-pred block))) + (delete-block-lazily block) + (setq block (clean-component component block))) + ((eq (functional-kind (block-home-lambda block)) :deleted) + ;; Preserve the BLOCK-SUCC invariant that almost every block has + ;; one successor (and a block with DELETE-P set is an acceptable + ;; exception). + (mark-for-deletion block) + (setq block (clean-component component block))) + (t + (loop + (let ((succ (block-succ block))) + (unless (singleton-p succ) + (return))) + + (let ((last (block-last block))) + (typecase last + (cif + (flush-dest (if-test last)) + (when (unlink-node last) + (return))) + (exit + (when (maybe-delete-exit last) + (return))))) + + (unless (join-successor-if-possible block) + (return))) + + (when (and (block-reoptimize block) (block-component block)) + (aver (not (block-delete-p block))) + (ir1-optimize-block block)) + + (cond ((and (block-delete-p block) (block-component block)) + (setq block (clean-component component block))) + ((and (block-flush-p block) (block-component block)) + (flush-dead-code block))))) + do (when (eq block last-block) + (setq block (block-next block)))) (values)) @@ -326,19 +323,21 @@ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker (cond ( ;; We cannot combine with a successor block if: (or - ;; The successor has more than one predecessor. + ;; the successor has more than one predecessor; (rest (block-pred next)) - ;; The successor is the current block (infinite loop). + ;; the successor is the current block (infinite loop); (eq next block) - ;; The next block has a different cleanup, and thus + ;; the next block has a different cleanup, and thus ;; we may want to insert cleanup code between the - ;; two blocks at some point. + ;; two blocks at some point; (not (eq (block-end-cleanup block) (block-start-cleanup next))) - ;; The next block has a different home lambda, and + ;; the next block has a different home lambda, and ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) - (block-home-lambda next)))) + (block-home-lambda next))) + ;; Stack analysis phase wants ENTRY to start a block. + (entry-p (block-start-node next))) nil) (t (join-blocks block next) @@ -385,7 +384,7 @@ (defun flush-dead-code (block) (declare (type cblock block)) (setf (block-flush-p block) nil) - (do-nodes-backwards (node lvar block) + (do-nodes-backwards (node lvar block :restart-p t) (unless lvar (typecase node (ref @@ -456,23 +455,26 @@ (let ((result (return-result node))) (collect ((use-union *empty-type* values-type-union)) (do-uses (use result) - (cond ((and (basic-combination-p use) - (eq (basic-combination-kind use) :local)) - (aver (eq (lambda-tail-set (node-home-lambda use)) - (lambda-tail-set (combination-lambda use)))) - (when (combination-p use) - (when (nth-value 1 (maybe-convert-tail-local-call use)) - (return-from find-result-type (values))))) - (t - (use-union (node-derived-type use))))) + (let ((use-home (node-home-lambda use))) + (cond ((or (eq (functional-kind use-home) :deleted) + (block-delete-p (node-block use)))) + ((and (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (aver (eq (lambda-tail-set use-home) + (lambda-tail-set (combination-lambda use)))) + (when (combination-p use) + (when (nth-value 1 (maybe-convert-tail-local-call use)) + (return-from find-result-type t)))) + (t + (use-union (node-derived-type use)))))) (let ((int ;; (values-type-intersection ;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26 (use-union) ;; ) - )) + )) (setf (return-result-type node) int)))) - (values)) + nil) ;;; Do stuff to realize that something has changed about the value ;;; delivered to a return node. Since we consider the return values of @@ -483,27 +485,30 @@ ;;; ;;; 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 -;;; all the continuations for references to functions in the tail set. -;;; This will cause IR1-OPTIMIZE-COMBINATION to derive the new type as -;;; the results of the calls. +;;; all the lvars for references to functions in the tail set. This +;;; will cause IR1-OPTIMIZE-COMBINATION to derive the new type as the +;;; results of the calls. (defun ir1-optimize-return (node) (declare (type creturn node)) - (let* ((tails (lambda-tail-set (return-lambda node))) - (funs (tail-set-funs tails))) - (collect ((res *empty-type* values-type-union)) - (dolist (fun funs) - (let ((return (lambda-return fun))) - (when return - (when (node-reoptimize return) - (setf (node-reoptimize return) nil) - (find-result-type return)) - (res (return-result-type return))))) - - (when (type/= (res) (tail-set-type tails)) - (setf (tail-set-type tails) (res)) - (dolist (fun (tail-set-funs tails)) - (dolist (ref (leaf-refs fun)) - (reoptimize-lvar (node-lvar ref))))))) + (tagbody + :restart + (let* ((tails (lambda-tail-set (return-lambda node))) + (funs (tail-set-funs tails))) + (collect ((res *empty-type* values-type-union)) + (dolist (fun funs) + (let ((return (lambda-return fun))) + (when return + (when (node-reoptimize return) + (setf (node-reoptimize return) nil) + (when (find-result-type return) + (go :restart))) + (res (return-result-type return))))) + + (when (type/= (res) (tail-set-type tails)) + (setf (tail-set-type tails) (res)) + (dolist (fun (tail-set-funs tails)) + (dolist (ref (leaf-refs fun)) + (reoptimize-lvar (node-lvar ref)))))))) (values)) @@ -631,7 +636,8 @@ (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) (when (lvar-reoptimize (basic-combination-fun node)) - (propagate-fun-change node)) + (propagate-fun-change node) + (maybe-terminate-block node nil)) (let ((args (basic-combination-args node)) (kind (basic-combination-kind node))) (case kind @@ -699,9 +705,7 @@ (values)) ;;; If NODE doesn't return (i.e. return type is NIL), then terminate -;;; the block there, and link it to the component tail. We also change -;;; the NODE's CONT to be a dummy continuation to prevent the use from -;;; confusing things. +;;; the block there, and link it to the component tail. ;;; ;;; Except when called during IR1 convertion, we delete the ;;; continuation if it has no other uses. (If it does have other uses, @@ -1167,6 +1171,7 @@ (set-use (principal-lvar-use (set-value set))) (() (and (combination-p set-use) (fun-info-p (combination-kind set-use)) + (not (node-to-be-deleted-p set-use)) (eq (combination-fun-source-name set-use) '+)) :exit-if-null) (+-args (basic-combination-args set-use)) @@ -1265,7 +1270,7 @@ (info :function :info name))))))))) ;;; If we have a non-set LET var with a single use, then (if possible) -;;; replace the variable reference's CONT with the arg continuation. +;;; replace the variable reference's LVAR with the arg lvar. ;;; ;;; 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 @@ -1313,7 +1318,7 @@ ;;; Delete a LET, removing the call and bind nodes, and warning about ;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come ;;; along right away and delete the REF and then the lambda, since we -;;; flush the FUN continuation. +;;; flush the FUN lvar. (defun delete-let (clambda) (declare (type clambda clambda)) (aver (functional-letlike-p clambda)) @@ -1323,6 +1328,9 @@ (unlink-node call) (unlink-node (lambda-bind clambda)) (setf (lambda-bind clambda) nil)) + (setf (functional-kind clambda) :zombie) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) (values)) ;;; This function is called when one of the arguments to a LET @@ -1481,8 +1489,7 @@ (:error)) (values)) -;;; Propagate derived type info from the values continuation to the -;;; vars. +;;; Propagate derived type info from the values lvar to the vars. (defun ir1-optimize-mv-bind (node) (declare (type mv-combination node)) (let* ((arg (first (basic-combination-args node))) @@ -1656,7 +1663,7 @@ (eq (lvar-fun-name (combination-fun use)) 'list)) - ;; FIXME: VALUES might not satisfy an assertion on NODE-CONT. + ;; FIXME: VALUES might not satisfy an assertion on NODE-LVAR. (change-ref-leaf (lvar-uses (combination-fun node)) (find-free-fun 'values "in a strange place")) (setf (combination-kind node) :full) @@ -1675,7 +1682,9 @@ (deftransform values ((&rest vals) * * :node node) (unless (lvar-single-value-p (node-lvar node)) (give-up-ir1-transform)) - (setf (node-derived-type node) *wild-type*) + (setf (node-derived-type node) + (make-short-values-type (list (single-value-type + (node-derived-type node))))) (principal-lvar-single-valuify (node-lvar node)) (if vals (let ((dummies (make-gensym-list (length (cdr vals))))) @@ -1688,41 +1697,12 @@ ;;; - CAST chains; (defun ir1-optimize-cast (cast &optional do-not-optimize) (declare (type cast cast)) - (let* ((value (cast-value cast)) - (value-type (lvar-derived-type value)) - (atype (cast-asserted-type cast)) - (int (values-type-intersection value-type atype))) - (derive-node-type cast int) - (when (eq int *empty-type*) - (unless (eq value-type *empty-type*) - - ;; FIXME: Do it in one step. - (filter-lvar - value - `(multiple-value-call #'list 'dummy)) - (filter-lvar - (cast-value cast) - ;; FIXME: Derived type. - `(%compile-time-type-error 'dummy - ',(type-specifier atype) - ',(type-specifier value-type))) - ;; KLUDGE: FILTER-CONTINUATION does not work for - ;; non-returning functions, so we declare the return type of - ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type - ;; here. - (setq value (cast-value cast)) - (derive-node-type (lvar-uses value) *empty-type*) - (maybe-terminate-block (lvar-uses value) nil) - ;; FIXME: Is it necessary? - (aver (null (block-pred (node-block cast)))) - (setf (block-delete-p (node-block cast)) t) - (return-from ir1-optimize-cast))) - (when (eq (node-derived-type cast) *empty-type*) - (maybe-terminate-block cast nil)) - + (let ((value (cast-value cast)) + (atype (cast-asserted-type cast))) (when (not do-not-optimize) (let ((lvar (node-lvar cast))) - (when (values-subtypep value-type (cast-asserted-type cast)) + (when (values-subtypep (lvar-derived-type value) + (cast-asserted-type cast)) (delete-filter cast lvar value) (when lvar (reoptimize-lvar lvar) @@ -1754,10 +1734,40 @@ (dolist (use (merges)) (merge-tail-sets use))))))) - (when (and (cast-%type-check cast) - (values-subtypep value-type - (cast-type-to-check cast))) - (setf (cast-%type-check cast) nil))) + (let* ((value-type (lvar-derived-type value)) + (int (values-type-intersection value-type atype))) + (derive-node-type cast int) + (when (eq int *empty-type*) + (unless (eq value-type *empty-type*) + + ;; FIXME: Do it in one step. + (filter-lvar + value + `(multiple-value-call #'list 'dummy)) + (filter-lvar + (cast-value cast) + ;; FIXME: Derived type. + `(%compile-time-type-error 'dummy + ',(type-specifier atype) + ',(type-specifier value-type))) + ;; KLUDGE: FILTER-LVAR does not work for non-returning + ;; functions, so we declare the return type of + ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type + ;; here. + (setq value (cast-value cast)) + (derive-node-type (lvar-uses value) *empty-type*) + (maybe-terminate-block (lvar-uses value) nil) + ;; FIXME: Is it necessary? + (aver (null (block-pred (node-block cast)))) + (delete-block-lazily (node-block cast)) + (return-from ir1-optimize-cast))) + (when (eq (node-derived-type cast) *empty-type*) + (maybe-terminate-block cast nil)) + + (when (and (cast-%type-check cast) + (values-subtypep value-type + (cast-type-to-check cast))) + (setf (cast-%type-check cast) nil)))) (unless do-not-optimize (setf (node-reoptimize cast) nil)))