X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=61aea84dedfed1b215568ccc36cec5d7cab6409f;hb=8dd43b84a688fde72f6d957c59f7207d539990f7;hp=3c67e0f73045ee6d8866a7f8896e934b139e2c81;hpb=d18903c82a4856d5a65549b2913c0ee098c34f7e;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 3c67e0f..61aea84 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -216,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)) @@ -317,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) @@ -1320,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 @@ -1671,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))))) @@ -1746,7 +1759,7 @@ (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) + (delete-block-lazily (node-block cast)) (return-from ir1-optimize-cast))) (when (eq (node-derived-type cast) *empty-type*) (maybe-terminate-block cast nil))