X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=d71be0f62bdf3df93504e622ca1d4ae67d11bd40;hb=c713eb2b521b048ff2c927ec52b861787d289f85;hp=2fdd9d9cb312e279efb413c1d6d600dfa6d1f3a3;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2fdd9d9..d71be0f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -56,9 +56,9 @@ (node-derived-type (continuation-use cont))))) ;;; Our best guess for the type of this continuation's value. Note -;;; that this may be Values or Function type, which cannot be passed +;;; 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, +;;; CONTINUATION-TYPE. This may be called on deleted continuations, ;;; always returning *. ;;; ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the @@ -84,6 +84,18 @@ (cond ((values-subtypep proven asserted) (setf (continuation-%type-check cont) nil) (setf (continuation-%derived-type cont) proven)) + ((and (values-subtypep proven (specifier-type 'function)) + (values-subtypep asserted (specifier-type 'function))) + ;; It's physically impossible for a runtime type check to + ;; distinguish between the various subtypes of FUNCTION, so + ;; it'd be pointless to do more type checks here. + (setf (continuation-%type-check cont) nil) + (setf (continuation-%derived-type cont) + ;; FIXME: This should depend on optimization + ;; policy. This is for SPEED > SAFETY: + #+nil (values-type-intersection asserted proven) + ;; and this is for SAFETY >= SPEED: + #-nil proven)) (t (unless (or (continuation-%type-check cont) (not (continuation-dest cont)) @@ -159,9 +171,9 @@ (eq int *empty-type*) (not (eq rtype *empty-type*))) (let ((*compiler-error-context* node)) - (compiler-warning + (compiler-warn "New inferred type ~S conflicts with old type:~ - ~% ~S~%*** Bug?" + ~% ~S~%*** possible internal error? Please report this." (type-specifier rtype) (type-specifier node-type)))) (setf (node-derived-type node) int) (reoptimize-continuation (node-cont node)))))) @@ -264,17 +276,17 @@ (values)) -;;; Loop over the nodes in Block, looking for stuff that needs to be +;;; Loop over the nodes in BLOCK, looking for stuff that needs to be ;;; optimized. We dispatch off of the type of each node with its ;;; reoptimize flag set: -;;; -- With a combination, we call Propagate-Function-Change whenever -;;; the function changes, and call IR1-Optimize-Combination if any +;;; -- With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever +;;; the function changes, and call IR1-OPTIMIZE-COMBINATION if any ;;; argument changes. -;;; -- With an Exit, we derive the node's type from the Value's type. -;;; We don't propagate Cont's assertion to the Value, since if we -;;; did, this would move the checking of Cont's assertion to the -;;; exit. This wouldn't work with Catch and UWP, where the Exit +;;; -- With an EXIT, we derive the node's type from the VALUE's type. +;;; We don't propagate CONT's assertion to the VALUE, since if we +;;; did, this would move the checking of CONT's assertion to the +;;; exit. This wouldn't work with CATCH and UWP, where the EXIT ;;; node is just a placeholder for the actual unknown exit. ;;; ;;; Note that we clear the node & block reoptimize flags *before* @@ -307,6 +319,9 @@ (ir1-optimize-set node))))) (values)) +;;; Try to join with a successor block. If we succeed, we return true, +;;; otherwise false. +;;; ;;; We cannot combine with a successor block if: ;;; 1. The successor has more than one predecessor. ;;; 2. The last node's CONT is also used somewhere else. @@ -316,10 +331,8 @@ ;;; 5. The next block has a different home lambda, and thus the ;;; control transfer is a non-local exit. ;;; -;;; If we succeed, we return true, otherwise false. -;;; -;;; Joining is easy when the successor's Start continuation is the -;;; same from our Last's Cont. If they differ, then we can still join +;;; Joining is easy when the successor's START continuation is the +;;; same from our LAST's CONT. If they differ, then we can still join ;;; when the last continuation has no next and the next continuation ;;; has no uses. In this case, we replace the next continuation with ;;; the last before joining the blocks. @@ -344,10 +357,10 @@ ((and (null (block-start-uses next)) (eq (continuation-kind last-cont) :inside-block)) (let ((next-node (continuation-next next-cont))) - ;; If next-cont does have a dest, it must be + ;; If NEXT-CONT does have a dest, it must be ;; unreachable, since there are no uses. ;; DELETE-CONTINUATION will mark the dest block as - ;; delete-p [and also this block, unless it is no + ;; DELETE-P [and also this block, unless it is no ;; longer backward reachable from the dest block.] (delete-continuation next-cont) (setf (node-prev next-node) last-cont) @@ -359,7 +372,7 @@ nil)))))) ;;; Join together two blocks which have the same ending/starting -;;; continuation. The code in Block2 is moved into Block1 and Block2 +;;; continuation. The code in BLOCK2 is moved into BLOCK1 and BLOCK2 ;;; is deleted from the DFO. We combine the optimize flags for the two ;;; blocks so that any indicated optimization gets done. (defun join-blocks (block1 block2) @@ -411,8 +424,8 @@ (unlink-node node)) (combination (let ((info (combination-kind node))) - (when (function-info-p info) - (let ((attr (function-info-attributes info))) + (when (fun-info-p info) + (let ((attr (fun-info-attributes info))) (when (and (ir1-attributep attr flushable) (not (ir1-attributep attr call))) (flush-dest (combination-fun node)) @@ -497,7 +510,7 @@ (defun ir1-optimize-return (node) (declare (type creturn node)) (let* ((tails (lambda-tail-set (return-lambda node))) - (funs (tail-set-functions tails))) + (funs (tail-set-funs tails))) (collect ((res *empty-type* values-type-union)) (dolist (fun funs) (let ((return (lambda-return fun))) @@ -509,7 +522,7 @@ (when (type/= (res) (tail-set-type tails)) (setf (tail-set-type tails) (res)) - (dolist (fun (tail-set-functions tails)) + (dolist (fun (tail-set-funs tails)) (dolist (ref (leaf-refs fun)) (reoptimize-continuation (node-cont ref))))))) @@ -548,13 +561,13 @@ (flush-dest test) (when (rest (block-succ block)) (unlink-blocks block victim)) - (setf (component-reanalyze (block-component (node-block node))) t) + (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 -;;; Use. The test must have >1 use, and must be immediately used by -;;; Use. Node must be the only node in its block (implying that +;;; Create a new copy of an IF node that tests the value of the node +;;; USE. The test must have >1 use, and must be immediately used by +;;; USE. NODE must be the only node in its block (implying that ;;; block-start = if-test). ;;; ;;; This optimization has an effect semantically similar to the @@ -568,7 +581,7 @@ ;;; become unreachable, resulting in a spurious note. (defun convert-if-if (use node) (declare (type node use) (type cif node)) - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((block (node-block node)) (test (if-test node)) (cblock (if-consequent node)) @@ -580,7 +593,7 @@ :consequent cblock :alternative ablock)) (new-block (continuation-starts-block new-cont))) - (prev-link new-node new-cont) + (link-node-to-previous-continuation new-node new-cont) (setf (continuation-dest new-cont) new-node) (add-continuation-use new-node dummy-cont) (setf (block-last new-block) new-node) @@ -650,7 +663,7 @@ (declaim (ftype (function (combination) (values)) ir1-optimize-combination)) (defun ir1-optimize-combination (node) (when (continuation-reoptimize (basic-combination-fun node)) - (propagate-function-change node)) + (propagate-fun-change node)) (let ((args (basic-combination-args node)) (kind (basic-combination-kind node))) (case kind @@ -668,7 +681,7 @@ (when arg (setf (continuation-reoptimize arg) nil))) - (let ((attr (function-info-attributes kind))) + (let ((attr (fun-info-attributes kind))) (when (and (ir1-attributep attr foldable) ;; KLUDGE: The next test could be made more sensitive, ;; only suppressing constant-folding of functions with @@ -687,21 +700,21 @@ ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host (let* ((ref (continuation-use (combination-fun node))) - (fun (leaf-name (ref-leaf ref)))) - (fboundp fun))) + (fun-name (leaf-source-name (ref-leaf ref)))) + (fboundp fun-name))) (constant-fold-call node) (return-from ir1-optimize-combination))) - (let ((fun (function-info-derive-type kind))) + (let ((fun (fun-info-derive-type kind))) (when fun (let ((res (funcall fun node))) (when res (derive-node-type node res) (maybe-terminate-block node nil))))) - (let ((fun (function-info-optimizer kind))) + (let ((fun (fun-info-optimizer kind))) (unless (and fun (funcall fun node)) - (dolist (x (function-info-transforms kind)) + (dolist (x (fun-info-transforms kind)) #!+sb-show (when *show-transforms-p* (let* ((cont (basic-combination-fun node)) @@ -715,20 +728,22 @@ (values)) -;;; If Call is to a function that doesn't return (i.e. return type is +;;; If CALL is to a function that 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 call's CONT to be a dummy continuation to ;;; prevent the use from confusing things. ;;; -;;; Except when called during IR1, we delete the continuation if it -;;; has no other uses. (If it does have other uses, we reoptimize.) +;;; Except when called during IR1 [FIXME: What does this mean? Except +;;; during IR1 conversion? What about IR1 optimization?], we delete +;;; the continuation if it has no other uses. (If it does have other +;;; uses, we reoptimize.) ;;; ;;; Termination on the basis of a continuation type assertion is ;;; inhibited when: ;;; -- The continuation is deleted (hence the assertion is spurious), or ;;; -- We are in IR1 conversion (where THE assertions are subject to ;;; weakening.) -(defun maybe-terminate-block (call ir1-p) +(defun maybe-terminate-block (call ir1-converting-not-optimizing-p) (declare (type basic-combination call)) (let* ((block (node-block call)) (cont (node-cont call)) @@ -737,9 +752,10 @@ (unless (or (and (eq call (block-last block)) (eq succ tail)) (block-delete-p block)) (when (or (and (eq (continuation-asserted-type cont) *empty-type*) - (not (or ir1-p (eq (continuation-kind cont) :deleted)))) + (not (or ir1-converting-not-optimizing-p + (eq (continuation-kind cont) :deleted)))) (eq (node-derived-type call) *empty-type*)) - (cond (ir1-p + (cond (ir1-converting-not-optimizing-p (delete-continuation-use call) (cond ((block-last block) @@ -767,29 +783,32 @@ ;;; wondering if something should be done to special-case the call. If ;;; CALL is a call to a global function, then see whether it defined ;;; or known: -;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert +;;; -- If a DEFINED-FUN should be inline expanded, then convert ;;; the expansion and change the call to call it. Expansion is ;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is ;;; true, we never expand, since this function has already been -;;; converted. Local call analysis will duplicate the definition if -;;; necessary. We claim that the parent form is LABELS for context -;;; declarations, since we don't want it to be considered a real -;;; global function. -;;; -- In addition to a direct check for the function name in the -;;; table, we also must check for slot accessors. If the function -;;; is a slot accessor, then we set the combination kind to the -;;; function info of %Slot-Setter or %Slot-Accessor, as -;;; appropriate. +;;; converted. Local call analysis will duplicate the definition +;;; if necessary. We claim that the parent form is LABELS for +;;; context declarations, since we don't want it to be considered +;;; a real global function. ;;; -- If it is a known function, mark it as such by setting the KIND. ;;; ;;; We return the leaf referenced (NIL if not a leaf) and the -;;; FUNCTION-INFO assigned. -(defun recognize-known-call (call ir1-p) +;;; FUN-INFO assigned. +;;; +;;; FIXME: The IR1-CONVERTING-NOT-OPTIMIZING-P argument is what the +;;; old CMU CL code called IR1-P, without explanation. My (WHN +;;; 2002-01-09) tentative understanding of it is that we can call this +;;; operation either in initial IR1 conversion or in later IR1 +;;; optimization, and it tells which is which. But it would be good +;;; for someone who really understands it to check whether this is +;;; really right. +(defun recognize-known-call (call ir1-converting-not-optimizing-p) (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (defined-function-p leaf) - (defined-function-inlinep leaf) + (inlinep (if (defined-fun-p leaf) + (defined-fun-inlinep leaf) :no-chance))) (cond ((eq inlinep :notinline) (values nil nil)) @@ -800,34 +819,32 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) - (defined-function-inline-expansion leaf) - (let ((fun (defined-function-functional leaf))) + (defined-fun-p leaf) + (defined-fun-inline-expansion leaf) + (let ((fun (defined-fun-functional leaf))) (or (not fun) (and (eq inlinep :inline) (functional-kind fun)))) (inline-expansion-ok call)) - (flet ((frob () + (flet (;; FIXME: Is this what the old CMU CL internal documentation + ;; called semi-inlining? A more descriptive name would + ;; be nice. -- WHN 2002-01-07 + (frob () (let ((res (ir1-convert-lambda-for-defun - (defined-function-inline-expansion leaf) + (defined-fun-inline-expansion leaf) leaf t #'ir1-convert-inline-lambda))) - (setf (defined-function-functional leaf) res) + (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) - (if ir1-p + (if ir1-converting-not-optimizing-p (frob) - (with-ir1-environment call + (with-ir1-environment-from-node call (frob) - (local-call-analyze *current-component*)))) + (locall-analyze-component *current-component*)))) (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) (t - (let* ((name (leaf-name leaf)) - (info (info :function :info - (if (slot-accessor-p leaf) - (if (consp name) - '%slot-setter - '%slot-accessor) - name)))) + (let ((info (info :function :info (leaf-source-name leaf)))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) @@ -839,49 +856,49 @@ ;;; syntax check, arg/result type processing, but still call ;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda, ;;; and that checking is done by local call analysis. -(defun validate-call-type (call type ir1-p) +(defun validate-call-type (call type ir1-converting-not-optimizing-p) (declare (type combination call) (type ctype type)) (cond ((not (fun-type-p type)) (aver (multiple-value-bind (val win) (csubtypep type (specifier-type 'function)) (or val (not win)))) - (recognize-known-call call ir1-p)) - ((valid-function-use call type - :argument-test #'always-subtypep - :result-test #'always-subtypep - ;; KLUDGE: Common Lisp is such a dynamic - ;; language that all we can do here in - ;; general is issue a STYLE-WARNING. It - ;; would be nice to issue a full WARNING - ;; in the special case of of type - ;; mismatches within a compilation unit - ;; (as in section 3.2.2.3 of the spec) - ;; but at least as of sbcl-0.6.11, we - ;; don't keep track of whether the - ;; mismatched data came from the same - ;; compilation unit, so we can't do that. - ;; -- WHN 2001-02-11 - ;; - ;; FIXME: Actually, I think we could - ;; issue a full WARNING if the call - ;; violates a DECLAIM FTYPE. - :error-function #'compiler-style-warning - :warning-function #'compiler-note) + (recognize-known-call call ir1-converting-not-optimizing-p)) + ((valid-fun-use call type + :argument-test #'always-subtypep + :result-test #'always-subtypep + ;; KLUDGE: Common Lisp is such a dynamic + ;; language that all we can do here in + ;; general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING + ;; in the special case of of type + ;; mismatches within a compilation unit + ;; (as in section 3.2.2.3 of the spec) + ;; but at least as of sbcl-0.6.11, we + ;; don't keep track of whether the + ;; mismatched data came from the same + ;; compilation unit, so we can't do that. + ;; -- WHN 2001-02-11 + ;; + ;; FIXME: Actually, I think we could + ;; issue a full WARNING if the call + ;; violates a DECLAIM FTYPE. + :lossage-fun #'compiler-style-warn + :unwinnage-fun #'compiler-note) (assert-call-type call type) - (maybe-terminate-block call ir1-p) - (recognize-known-call call ir1-p)) + (maybe-terminate-block call ir1-converting-not-optimizing-p) + (recognize-known-call call ir1-converting-not-optimizing-p)) (t (setf (combination-kind call) :error) (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has -;;; changed. If the call is local, we try to let-convert it, and +;;; changed. If the call is local, we try to LET-convert it, and ;;; derive the result type. If it is a :FULL call, we validate it ;;; against the type, which recognizes known calls, does inline ;;; expansion, etc. If a call to a predicate in a non-conditional ;;; position or to a function with a source transform, then we ;;; reconvert the form to give IR1 another chance. -(defun propagate-function-change (call) +(defun propagate-fun-change (call) (declare (type combination call)) (let ((*compiler-error-context* call) (fun-cont (basic-combination-fun call))) @@ -900,19 +917,30 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-name leaf)) + ((or (info :function :source-transform (leaf-source-name leaf)) (and info - (ir1-attributep (function-info-attributes info) + (ir1-attributep (fun-info-attributes info) predicate) (let ((dest (continuation-dest (node-cont call)))) (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (make-gensym-list (length - (combination-args call))))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) + (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))))))))))) (values)) ;;;; known function optimization @@ -961,7 +989,7 @@ (eq when :native)))) t) ((or (not constrained) - (valid-function-use node type :strict-result t)) + (valid-fun-use node type :strict-result t)) (multiple-value-bind (severity args) (catch 'give-up-ir1-transform (transform-call node (funcall fun node)) @@ -973,7 +1001,7 @@ (:aborted (setf (combination-kind node) :error) (when args - (apply #'compiler-warning args)) + (apply #'compiler-warn args)) (remhash node table) nil) (:failure @@ -987,11 +1015,10 @@ (remhash node table) nil)))) ((and flame - (valid-function-use node - type - :argument-test #'types-equal-or-intersect - :result-test - #'values-types-equal-or-intersect)) + (valid-fun-use node + type + :argument-test #'types-equal-or-intersect + :result-test #'values-types-equal-or-intersect)) (record-optimization-failure node transform type) t) (t @@ -1068,18 +1095,20 @@ ;;; integrated into the control flow. (defun transform-call (node res) (declare (type combination node) (list res)) - (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) + (with-ir1-environment-from-node node + (let ((new-fun (ir1-convert-inline-lambda + res + :debug-name "something inlined in TRANSFORM-CALL")) (ref (continuation-use (combination-fun node)))) (change-ref-leaf ref new-fun) (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) + (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 +;;; 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 ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. @@ -1090,10 +1119,10 @@ (declare (type combination call)) (let* ((args (mapcar #'continuation-value (combination-args call))) (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) + (fun-name (leaf-source-name (ref-leaf ref)))) (multiple-value-bind (values win) - (careful-call fun args call "constant folding") + (careful-call fun-name args call "constant folding") (if (not win) (setf (combination-kind call) :error) (let ((dummies (make-gensym-list (length args)))) @@ -1101,7 +1130,7 @@ call `(lambda ,dummies (declare (ignore ,@dummies)) - (values ,@(mapcar #'(lambda (x) `',x) values)))))))) + (values ,@(mapcar (lambda (x) `',x) values)))))))) (values)) @@ -1158,12 +1187,11 @@ ((or constant functional) t) (lambda-var (null (lambda-var-sets leaf))) - (defined-function - (not (eq (defined-function-inlinep leaf) :notinline))) + (defined-fun + (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function t) - (:constant t)))))) + (:global-function t)))))) ;;; 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. @@ -1226,7 +1254,7 @@ ;;; changes. We look at each changed argument. If the corresponding ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we ;;; consider substituting for the variable, and also propagate -;;; derived-type information for the arg to all the Var's refs. +;;; derived-type information for the arg to all the VAR's refs. ;;; ;;; Substitution is inhibited when the arg leaf's derived type isn't a ;;; subtype of the argument's asserted type. This prevents type @@ -1235,7 +1263,7 @@ ;;; ;;; Substitution of individual references is inhibited if the ;;; reference is in a different component from the home. This can only -;;; happen with closures over top-level lambda vars. In such cases, +;;; happen with closures over top level lambda vars. In such cases, ;;; the references may have already been compiled, and thus can't be ;;; retroactively modified. ;;; @@ -1243,7 +1271,7 @@ ;;; are done, then we delete the LET. ;;; ;;; Note that we are responsible for clearing the -;;; Continuation-Reoptimize flags. +;;; CONTINUATION-REOPTIMIZE flags. (defun propagate-let-args (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (combination-args call) @@ -1260,16 +1288,14 @@ (values-subtypep (leaf-type leaf) (continuation-asserted-type arg))) (propagate-to-refs var (continuation-type arg)) - (let ((this-comp (block-component (node-block use)))) + (let ((use-component (node-component use))) (substitute-leaf-if - #'(lambda (ref) - (cond ((eq (block-component (node-block ref)) - this-comp) - t) - (t - (aver (eq (functional-kind (lambda-home fun)) - :top-level)) - nil))) + (lambda (ref) + (cond ((eq (node-component ref) use-component) + t) + (t + (aver (lambda-toplevelish-p (lambda-home fun))) + nil))) leaf var)) t))))) ((and (null (rest (leaf-refs var))) @@ -1297,14 +1323,14 @@ (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) - (unless (or (functional-entry-function fun) + (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) - (union (mapcar #'(lambda (arg var) - (when (and arg - (continuation-reoptimize arg) - (null (basic-var-sets var))) - (continuation-type arg))) + (union (mapcar (lambda (arg var) + (when (and arg + (continuation-reoptimize arg) + (null (basic-var-sets var))) + (continuation-type arg))) (basic-combination-args call) vars)) (this-ref (continuation-use (basic-combination-fun call)))) @@ -1317,16 +1343,16 @@ (let ((dest (continuation-dest (node-cont ref)))) (unless (or (eq ref this-ref) (not dest)) (setq union - (mapcar #'(lambda (this-arg old) - (when old - (setf (continuation-reoptimize this-arg) nil) - (type-union (continuation-type this-arg) old))) + (mapcar (lambda (this-arg old) + (when old + (setf (continuation-reoptimize this-arg) nil) + (type-union (continuation-type this-arg) old))) (basic-combination-args dest) union))))) - (mapc #'(lambda (var type) - (when type - (propagate-to-refs var type))) + (mapc (lambda (var type) + (when type + (propagate-to-refs var type))) vars union))) (values)) @@ -1388,11 +1414,11 @@ (multiple-value-bind (types nvals) (values-types (continuation-derived-type arg)) (unless (eq nvals :unknown) - (mapc #'(lambda (var type) - (if (basic-var-sets var) - (propagate-from-sets var type) - (propagate-to-refs var type))) - vars + (mapc (lambda (var type) + (if (basic-var-sets var) + (propagate-from-sets var type) + (propagate-to-refs var type))) + vars (append types (make-list (max (- (length vars) nvals) 0) :initial-element (specifier-type 'null)))))) @@ -1446,14 +1472,14 @@ (when total-nvals (when (and min (< total-nvals min)) - (compiler-warning + (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ 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-warning + (compiler-warn "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ at most ~R." total-nvals max) @@ -1466,7 +1492,7 @@ min) (t nil)))) (when count - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((dums (make-gensym-list count)) (ignore (gensym)) (fun (ir1-convert-lambda @@ -1475,7 +1501,7 @@ (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) (aver (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) + (locall-analyze-component *current-component*) (aver (eq (basic-combination-kind node) :local))))))))) (values)) @@ -1510,7 +1536,7 @@ (mapc #'flush-dest (subseq vals nvars)) (setq vals (subseq vals 0 nvars))) ((< nvals nvars) - (with-ir1-environment use + (with-ir1-environment-from-node use (let ((node-prev (node-prev use))) (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) @@ -1521,7 +1547,8 @@ do (reference-constant prev cont nil) (res cont)) (setq vals (res))) - (prev-link use (car (last vals))))))) + (link-node-to-previous-continuation use + (car (last vals))))))) (setf (combination-args use) vals) (flush-dest (combination-fun use)) (let ((fun-cont (basic-combination-fun call))) @@ -1552,7 +1579,7 @@ (eq (continuation-fun-name (combination-fun use)) 'list)) (change-ref-leaf (continuation-use (combination-fun node)) - (find-free-function 'values "in a strange place")) + (find-free-fun 'values "in a strange place")) (setf (combination-kind node) :full) (let ((args (combination-args use))) (dolist (arg args)