X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=d35a1a2604b0eab02c8faf5cd35f5c206da95af3;hb=bea5b384106a6734a4b280a76e8ebdd4d51b5323;hp=cb198bdbf15f7dd722b6916f83e3b466f2a3e81f;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index cb198bd..d35a1a2 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -21,6 +21,7 @@ ;;; 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)))))) @@ -106,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 @@ -129,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)) @@ -139,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 @@ -163,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 @@ -186,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 @@ -212,52 +209,58 @@ ;;; 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) - (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 (not fastp) (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)) @@ -316,19 +319,29 @@ (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)) + (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) @@ -375,15 +388,16 @@ (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 (delete-ref node) (unlink-node node)) (combination - (let ((info (combination-kind node))) - (when (fun-info-p info) + (let ((kind (combination-kind node)) + (info (combination-fun-info node))) + (when (and (eq kind :known) (fun-info-p info)) (let ((attr (fun-info-attributes info))) (when (and (not (ir1-attributep attr call)) ;; ### For now, don't delete potentially @@ -446,23 +460,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 @@ -478,22 +495,25 @@ ;;; 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)) @@ -621,25 +641,39 @@ (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 + (kind (basic-combination-kind node)) + (info (basic-combination-fun-info node))) + (ecase kind (:local (let ((fun (combination-lambda node))) (if (eq (functional-kind fun) :let) (propagate-let-args node fun) (propagate-local-call-args node fun)))) - ((:full :error) + (:error (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil)))) - (t + (:full + (dolist (arg args) + (when arg + (setf (lvar-reoptimize arg) nil))) + (when info + (let ((fun (fun-info-derive-type info))) + (when fun + (let ((res (funcall fun node))) + (when res + (derive-node-type node (coerce-to-values res)) + (maybe-terminate-block node nil))))))) + (:known + (aver info) (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil))) - (let ((attr (fun-info-attributes kind))) + (let ((attr (fun-info-attributes info))) (when (and (ir1-attributep attr foldable) ;; KLUDGE: The next test could be made more sensitive, ;; only suppressing constant-folding of functions with @@ -665,16 +699,16 @@ (constant-fold-call node) (return-from ir1-optimize-combination))) - (let ((fun (fun-info-derive-type kind))) + (let ((fun (fun-info-derive-type info))) (when fun (let ((res (funcall fun node))) (when res (derive-node-type node (coerce-to-values res)) (maybe-terminate-block node nil))))) - (let ((fun (fun-info-optimizer kind))) + (let ((fun (fun-info-optimizer info))) (unless (and fun (funcall fun node)) - (dolist (x (fun-info-transforms kind)) + (dolist (x (fun-info-transforms info)) #!+sb-show (when *show-transforms-p* (let* ((lvar (basic-combination-fun node)) @@ -704,12 +738,13 @@ ;;; ;;; 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)) (tail (component-tail (block-component block))) (succ (first (block-succ block)))) + (declare (ignore lvar)) (unless (or (and (eq node (block-last block)) (eq succ tail)) (block-delete-p block)) (when (eq (node-derived-type node) *empty-type*) @@ -727,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 @@ -761,7 +799,11 @@ (defined-fun-inlinep leaf) :no-chance))) (cond - ((eq inlinep :notinline) (values nil nil)) + ((eq inlinep :notinline) + (let ((info (info :function :info (leaf-source-name leaf)))) + (when info + (setf (basic-combination-fun-info call) info)) + (values nil nil))) ((not (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function))) (values leaf nil)) @@ -779,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 @@ -796,7 +839,10 @@ (t (let ((info (info :function :info (leaf-source-name leaf)))) (if info - (values leaf (setf (basic-combination-kind call) info)) + (values leaf + (progn + (setf (basic-combination-kind call) :known) + (setf (basic-combination-fun-info call) info))) (values leaf nil))))))) ;;; Check whether CALL satisfies TYPE. If so, apply the type to the @@ -815,7 +861,7 @@ (recognize-known-call call ir1-converting-not-optimizing-p)) ((valid-fun-use call type :argument-test #'always-subtypep - :result-test #'always-subtypep + :result-test nil ;; KLUDGE: Common Lisp is such a dynamic ;; language that all we can do here in ;; general is issue a STYLE-WARNING. It @@ -867,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) @@ -933,7 +981,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warn args)) + (apply #'warn args)) (remhash node table) nil) (:failure @@ -1017,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 @@ -1040,10 +1088,7 @@ (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-name 'lambda-inlined source-name))) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) @@ -1154,7 +1199,9 @@ (() (null (rest sets)) :exit-if-null) (set-use (principal-lvar-use (set-value set))) (() (and (combination-p set-use) - (fun-info-p (combination-kind set-use)) + (eq (combination-kind set-use) :known) + (fun-info-p (combination-fun-info 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,8 +1312,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 @@ -1289,9 +1338,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) @@ -1311,6 +1375,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 @@ -1534,14 +1601,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))) @@ -1662,7 +1729,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))))) @@ -1675,41 +1744,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-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)))) - (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) @@ -1729,7 +1769,10 @@ (immediately-used-p value use)) (unless next-block (when ctran (ensure-block-start ctran)) - (setq next-block (first (block-succ (node-block cast))))) + (setq next-block (first (block-succ (node-block 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)) @@ -1741,10 +1784,42 @@ (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 + (if (cast-single-value-p cast) + `(list 'dummy) + `(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)))