X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=d585c2076d9903d6f5a6480fbda9488da80c3f0b;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=5626039e676f49e7a499a1c1e3c752137ff12c32;hpb=1fdd787fcdac403f92d121701aee8738f710f048;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 5626039..d585c20 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -118,11 +118,49 @@ (declaim (ftype (function (continuation) ctype) continuation-type)) (defun continuation-type (cont) (single-value-type (continuation-derived-type cont))) + +;;; If CONT is an argument of a function, return a type which the +;;; function checks CONT for. +#!-sb-fluid (declaim (inline continuation-externally-checkable-type)) +(defun continuation-externally-checkable-type (cont) + (or (continuation-%externally-checkable-type cont) + (%continuation-%externally-checkable-type cont))) +(defun %continuation-%externally-checkable-type (cont) + (declare (type continuation cont)) + (let ((dest (continuation-dest cont))) + (if (not (and dest (combination-p dest))) + ;; TODO: MV-COMBINATION + (setf (continuation-%externally-checkable-type cont) *wild-type*) + (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)) + (progn (dolist (arg args) + (when arg + (setf (continuation-%externally-checkable-type arg) + *wild-type*))) + *wild-type*) + (let* ((arg-types (append (fun-type-required fun-type) + (fun-type-optional fun-type) + (let ((rest (list (or (fun-type-rest fun-type) + *wild-type*)))) + (setf (cdr rest) rest))))) + ;; TODO: &KEY + (loop + for arg of-type continuation in args + and type of-type ctype in arg-types + do (when arg + (setf (continuation-%externally-checkable-type arg) + type))) + (continuation-%externally-checkable-type cont))))))) ;;;; interface routines used by optimizers ;;; This function is called by optimizers to indicate that something -;;; interesting has happened to the value of Cont. Optimizers must +;;; interesting has happened to the value of CONT. Optimizers must ;;; make sure that they don't call for reoptimization when nothing has ;;; happened, since optimization will fail to terminate. ;;; @@ -131,7 +169,7 @@ ;;; is deleted (in which case we do nothing.) ;;; ;;; Since this can get called during IR1 conversion, we have to be -;;; careful not to fly into space when the Dest's Prev is missing. +;;; careful not to fly into space when the DEST's PREV is missing. (defun reoptimize-continuation (cont) (declare (type continuation cont)) (unless (member (continuation-kind cont) '(:deleted :unused)) @@ -152,15 +190,15 @@ (setf (block-type-check (node-block node)) t))) (values)) -;;; Annotate Node to indicate that its result has been proven to be -;;; typep to RType. After IR1 conversion has happened, this is the +;;; Annotate NODE to indicate that its result has been proven to be +;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the ;;; only correct way to supply information discovered about a node's -;;; type. If you screw with the Node-Derived-Type directly, then +;;; type. If you screw with the NODE-DERIVED-TYPE directly, then ;;; information may be lost and reoptimization may not happen. ;;; -;;; What we do is intersect Rtype with Node's Derived-Type. If the +;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the ;;; intersection is different from the old type, then we do a -;;; Reoptimize-Continuation on the Node-Cont. +;;; REOPTIMIZE-CONTINUATION on the NODE-CONT. (defun derive-node-type (node rtype) (declare (type node node) (type ctype rtype)) (let ((node-type (node-derived-type node))) @@ -176,26 +214,42 @@ ~% ~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)) +(defun set-continuation-type-assertion (cont atype ctype) + (declare (type continuation cont) (type ctype atype ctype)) + (when (eq atype *wild-type*) + (return-from set-continuation-type-assertion)) + (let* ((old-atype (continuation-asserted-type cont)) + (old-ctype (continuation-type-to-check cont)) + (new-atype (values-type-intersection old-atype atype)) + (new-ctype (values-type-intersection old-ctype ctype))) + (when (or (type/= old-atype new-atype) + (type/= old-ctype new-ctype)) + (setf (continuation-asserted-type cont) new-atype) + (setf (continuation-type-to-check cont) new-ctype) + (do-uses (node cont) + (setf (block-attributep (block-flags (node-block node)) + type-check type-asserted) + t)) + (reoptimize-continuation cont))) + (values)) + ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an ;;; error for CONT's value not to be TYPEP to TYPE. If we improve the ;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that ;;; the new assertion will be checked. -(defun assert-continuation-type (cont type) +(defun assert-continuation-type (cont type policy) (declare (type continuation cont) (type ctype type)) - (let ((cont-type (continuation-asserted-type cont))) - (unless (eq cont-type type) - (let ((int (values-type-intersection cont-type type))) - (when (type/= cont-type int) - (setf (continuation-asserted-type cont) int) - (do-uses (node cont) - (setf (block-attributep (block-flags (node-block node)) - type-check type-asserted) - t)) - (reoptimize-continuation cont))))) - (values)) + (when (eq type *wild-type*) + (return-from assert-continuation-type)) + (set-continuation-type-assertion cont type (maybe-weaken-check type policy))) ;;; Assert that CALL is to a function of the specified TYPE. It is ;;; assumed that the call is legal and has only constants in the @@ -203,20 +257,21 @@ (defun assert-call-type (call type) (declare (type combination call) (type fun-type type)) (derive-node-type call (fun-type-returns type)) - (let ((args (combination-args call))) + (let ((args (combination-args call)) + (policy (lexenv-policy (node-lexenv call)))) (dolist (req (fun-type-required type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) - (assert-continuation-type arg req))) + (assert-continuation-type arg req policy))) (dolist (opt (fun-type-optional type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) - (assert-continuation-type arg opt))) + (assert-continuation-type arg opt policy))) (let ((rest (fun-type-rest type))) (when rest (dolist (arg args) - (assert-continuation-type arg rest)))) + (assert-continuation-type arg rest policy)))) (dolist (key (fun-type-keywords type)) (let ((name (key-info-name key))) @@ -224,7 +279,8 @@ ((null arg)) (when (eq (continuation-value (first arg)) name) (assert-continuation-type - (second arg) (key-info-type key))))))) + (second arg) (key-info-type key) + policy)))))) (values)) ;;;; IR1-OPTIMIZE @@ -238,53 +294,53 @@ (setf (component-reoptimize component) nil) (do-blocks (block component) (cond - ((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). - (labels ((mark-blocks (block) - (dolist (pred (block-pred block)) - (when (and (not (block-delete-p pred)) - (eq (functional-kind (block-home-lambda pred)) - :deleted)) - (setf (block-delete-p pred) t) - (mark-blocks pred))))) - (mark-blocks block) - (delete-block block))) - (t - (loop - (let ((succ (block-succ block))) - (unless (and succ (null (rest 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)) - ;; 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. - (when (and (block-flush-p block) (block-component block)) - (aver (not (block-delete-p block))) - (flush-dead-code block))))) + ((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 (and succ (null (rest succ))) + (return))) + + (let ((last (block-last block))) + (typecase last + (cif + (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))))) + + (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 ((block-delete-p block) + (delete-block block)) + ((and (block-flush-p block) (block-component block)) + (flush-dead-code block)))))) (values)) @@ -334,6 +390,7 @@ (derive-node-type node (continuation-derived-type value))))) (cset (ir1-optimize-set node))))) + (values)) ;;; Try to join with a successor block. If we succeed, we return true, @@ -441,17 +498,29 @@ (let ((info (combination-kind node))) (when (fun-info-p info) (let ((attr (fun-info-attributes info))) - (when (and (ir1-attributep attr flushable) + (when (and (not (ir1-attributep attr call)) ;; ### For now, don't delete potentially ;; flushable calls when they have the CALL ;; attribute. Someday we should look at the ;; functional args to determine if they have ;; any side effects. - (not (ir1-attributep attr call))) - (flush-dest (combination-fun node)) - (dolist (arg (combination-args node)) - (flush-dest arg)) - (unlink-node node)))))) + (if (policy node (= safety 3)) + (and (ir1-attributep attr flushable) + (every (lambda (arg) + ;; FIXME: when bug 203 + ;; will be fixed, remove + ;; this check + (member (continuation-type-check arg) + '(nil :deleted))) + (basic-combination-args node)) + (valid-fun-use node + (info :function :type + (leaf-source-name (ref-leaf (continuation-use (basic-combination-fun node))))) + :result-test #'always-subtypep + :lossage-fun nil + :unwinnage-fun nil)) + (ir1-attributep attr unsafely-flushable))) + (flush-combination node)))))) (mv-combination (when (eq (basic-combination-kind node) :local) (let ((fun (combination-lambda node))) @@ -520,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 @@ -567,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 @@ -615,6 +687,7 @@ (new-block (continuation-starts-block new-cont))) (link-node-to-previous-continuation new-node new-cont) (setf (continuation-dest new-cont) new-node) + (setf (continuation-%externally-checkable-type new-cont) nil) (add-continuation-use new-node dummy-cont) (setf (block-last new-block) new-node) @@ -935,31 +1008,31 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-source-name leaf)) - (and info - (ir1-attributep (fun-info-attributes info) - predicate) - (let ((dest (continuation-dest (node-cont call)))) - (and dest (not (if-p dest)))))) - (when (and (leaf-has-source-name-p leaf) - ;; FIXME: This SYMBOLP is part of a literal - ;; translation of a test in the old CMU CL - ;; source, and it's not quite clear what - ;; the old source meant. Did it mean "has a - ;; valid name"? Or did it mean "is an - ;; ordinary function name, not a SETF - ;; function"? Either way, the old CMU CL - ;; code probably didn't deal with SETF - ;; functions correctly, and neither does - ;; this new SBCL code, and that should be fixed. - (symbolp (leaf-source-name leaf))) - (let ((dummies (make-gensym-list (length - (combination-args call))))) - (transform-call call - `(lambda ,dummies - (,(leaf-source-name leaf) - ,@dummies)) - (leaf-source-name leaf)))))))))) + ((and (leaf-has-source-name-p leaf) + (or (info :function :source-transform (leaf-source-name leaf)) + (and info + (ir1-attributep (fun-info-attributes info) + predicate) + (let ((dest (continuation-dest (node-cont call)))) + (and dest (not (if-p dest))))))) + ;; FIXME: This SYMBOLP is part of a literal + ;; translation of a test in the old CMU CL + ;; source, and it's not quite clear what + ;; the old source meant. Did it mean "has a + ;; valid name"? Or did it mean "is an + ;; ordinary function name, not a SETF + ;; function"? Either way, the old CMU CL + ;; code probably didn't deal with SETF + ;; functions correctly, and neither does + ;; this new SBCL code, and that should be fixed. + (when (symbolp (leaf-source-name leaf)) + (let ((dummies (make-gensym-list + (length (combination-args call))))) + (transform-call call + `(lambda ,dummies + (,(leaf-source-name leaf) + ,@dummies)) + (leaf-source-name leaf)))))))))) (values)) ;;;; known function optimization @@ -1106,33 +1179,42 @@ ;;; 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 -;;; the result of evaluating the form. We insert the resulting -;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no DEST, which should cause it -;;; and its arguments to go away. If there is an error during the +;;; the result of evaluating the form. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. ;;; ;;; If there is more than one value, then we transform the call into a ;;; VALUES form. +;;; +;;; An old commentary also said: +;;; +;;; We insert the resulting constant node after the call, stealing +;;; the call's continuation. We give the call a continuation with no +;;; DEST, which should cause it and its arguments to go away. +;;; +;;; This seems to be more efficient, than the current code. Maybe we +;;; should really implement it? -- APD, 2002-12-23 (defun constant-fold-call (call) (let ((args (mapcar #'continuation-value (combination-args call))) (fun-name (combination-fun-source-name call))) @@ -1166,22 +1248,36 @@ ;; when the compiler tries to constant-fold (<= ;; END SIZE). ;; - ;; So, with or without bug 173, it'd be + ;; So, with or without bug 173, it'd be ;; unnecessarily evil to do a full ;; COMPILER-WARNING (and thus return FAILURE-P=T ;; from COMPILE-FILE) for legal code, so we we ;; use a wimpier COMPILE-STYLE-WARNING instead. #'compiler-style-warn "constant folding") - (if (not win) - (setf (combination-kind call) :error) - (let ((dummies (make-gensym-list (length args)))) - (transform-call - call - `(lambda ,dummies - (declare (ignore ,@dummies)) - (values ,@(mapcar (lambda (x) `',x) values))) - fun-name))))) + (cond ((not win) + (setf (combination-kind call) :error)) + ((and (proper-list-of-length-p values 1) + (eq (continuation-kind (node-cont call)) :inside-block)) + (with-ir1-environment-from-node call + (let* ((cont (node-cont call)) + (next (continuation-next cont)) + (prev (make-continuation))) + (delete-continuation-use call) + (add-continuation-use call prev) + (reference-constant prev cont (first values)) + (setf (continuation-next cont) next) + ;; FIXME: type checking? + (reoptimize-continuation cont) + (reoptimize-continuation prev) + (flush-combination call)))) + (t (let ((dummies (make-gensym-list (length args)))) + (transform-call + call + `(lambda ,dummies + (declare (ignore ,@dummies)) + (values ,@(mapcar (lambda (x) `',x) values))) + fun-name)))))) (values)) ;;;; local call optimization @@ -1202,13 +1298,16 @@ (values)))) ;;; Figure out the type of a LET variable that has sets. We compute -;;; the union of the initial value Type and the types of all the set +;;; the union of the initial value TYPE and the types of all the set ;;; values and to a PROPAGATE-TO-REFS with this type. (defun propagate-from-sets (var type) (collect ((res type type-union)) (dolist (set (basic-var-sets var)) - (res (continuation-type (set-value set))) - (setf (node-reoptimize set) nil)) + (let ((type (continuation-type (set-value set)))) + (res type) + (when (node-reoptimize set) + (derive-node-type set type) + (setf (node-reoptimize set) nil)))) (propagate-to-refs var (res))) (values)) @@ -1228,7 +1327,7 @@ (derive-node-type node (continuation-type (set-value node))) (values)) -;;; Return true if the value of Ref will always be the same (and is +;;; Return true if the value of REF will always be the same (and is ;;; thus legal to substitute.) (defun constant-reference-p (ref) (declare (type ref ref)) @@ -1241,7 +1340,12 @@ (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function t)))))) + (:global-function + (let ((name (leaf-source-name leaf))) + (or #-sb-xc-host + (eq (symbol-package (fun-name-block-name name)) + *cl-package*) + (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. @@ -1252,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 @@ -1262,10 +1366,11 @@ (let* ((ref (first (leaf-refs var))) (cont (node-cont ref)) (cont-atype (continuation-asserted-type cont)) + (cont-ctype (continuation-type-to-check cont)) (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)) @@ -1278,7 +1383,7 @@ (lexenv-policy (node-lexenv (continuation-dest arg))))) (aver (member (continuation-kind arg) '(:block-start :deleted-block-start :inside-block))) - (assert-continuation-type arg cont-atype) + (set-continuation-type-assertion arg cont-atype cont-ctype) (setf (node-derived-type ref) *wild-type*) (change-ref-leaf ref (find-constant nil)) (substitute-continuation arg cont) @@ -1366,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)) @@ -1537,7 +1642,7 @@ (return-from ir1-optimize-mv-call))) (let ((count (cond (total-nvals) - ((and (policy node (zerop safety)) + ((and (policy node (zerop verify-arg-count)) (eql min max)) min) (t nil)))) @@ -1591,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) @@ -1603,14 +1708,16 @@ (flush-dest (combination-fun use)) (let ((fun-cont (basic-combination-fun call))) (setf (continuation-dest fun-cont) use) - (setf (combination-fun use) fun-cont)) + (setf (combination-fun use) fun-cont) + (setf (continuation-%externally-checkable-type fun-cont) nil)) (setf (combination-kind use) :local) (setf (functional-kind fun) :let) (flush-dest (first (basic-combination-args call))) (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: @@ -1623,17 +1730,22 @@ ;;; 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) (let ((args (combination-args use))) (dolist (arg args) - (setf (continuation-dest arg) node)) + (setf (continuation-dest arg) node) + (setf (continuation-%externally-checkable-type arg) nil)) (setf (combination-args use) nil) (flush-dest list) (setf (combination-args node) args)) @@ -1643,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