diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index a3200e54646a886834508b81b44c780e66cfd4af..68c3cd10312b2d34ca293836aac7fdeadb519d59 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -335,10 +335,7 @@ (setf (node-reoptimize node) t) (ir1-optimize-return node)) (mv-combination - (when (and (eq (basic-combination-kind node) :local) - (continuation-reoptimize - (first (basic-combination-args node)))) - (ir1-optimize-mv-bind node))) + (ir1-optimize-mv-combination node)) (exit (let ((value (exit-value node))) (when value @@ -1199,6 +1196,36 @@ ;;;; Multiple values optimization: +;;; IR1-OPTIMIZE-MV-COMBINATION -- Internal +;;; +;;; Do stuff to notice a change to a MV combination node. +;;; +(defun ir1-optimize-mv-combination (node) + (if (eq (basic-combination-kind node) :local) + (let ((arg (first (basic-combination-args node)))) + (when (continuation-reoptimize arg) + (unless (convert-mv-bind-to-let node) + (ir1-optimize-mv-bind node)))) + (let* ((fun (basic-combination-fun node)) + (fun-changed (continuation-reoptimize fun)) + (args (basic-combination-args node))) + (when fun-changed + (setf (continuation-reoptimize fun) nil) + (let ((use (continuation-use fun))) + (when (and (ref-p use) (functional-p (ref-leaf use)) + (not (eq (ref-inlinep use) :notinline))) + (convert-call-if-possible use node) + (when (eq (basic-combination-kind node) :local)) + (maybe-let-convert (ref-leaf use))))) + (when (and (not (eq (basic-combination-kind node) :local)) + (or fun-changed (find-if #'continuation-reoptimize args)) + (not (eq (continuation-function-name fun) '%throw))) + (ir1-optimize-mv-call node)) + (dolist (arg args) + (setf (continuation-reoptimize arg) nil)))) + (undefined-value)) + + ;;; IR1-OPTIMIZE-MV-BIND -- Internal ;;; ;;; Propagate derived type info from the values continuation to the vars. @@ -1223,7 +1250,87 @@ (undefined-value)) -;;; VALUES IR1 optimizer -- Internal +;;; IR1-OPTIMIZE-MV-CALL -- Internal +;;; +;;; If possible, convert a general MV call to an MV-BIND. We can do this +;;; if: +;;; -- The function has a known fixed number of arguments, or +;;; -- All the arguments yield a known fixed number of values. +;;; +;;; What we do is change the function in the MV-CALL to be a lambda that "looks +;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that +;;; this call can be converted (the next time around.) This new lambda just +;;; calls the actual function with the MV-BIND variables as arguments. +;;; +;;; In order to avoid loss of argument count checking, we only do the +;;; transformation according to a known number of expected argument if safety +;;; is unimportant. We can always convert if we know the number of actual +;;; values, since the normal call that we build will still do any appropriate +;;; argument count checking. +;;; +;;; We only attempt the transformation if the called function is a constant +;;; reference. This allows us to just splice the leaf into the new function, +;;; instead of trying to somehow bind the function expression. The leaf must +;;; be constant because we are evaluating it again in a different place. This +;;; also has the effect of squelching multiple warnings when there is an +;;; argument count error. +;;; +(defun ir1-optimize-mv-call (node) + (let ((fun (basic-combination-fun node)) + (total-nvals 0) + (*compiler-error-context* node) + (ref (continuation-use (basic-combination-fun node)))) + + (unless (and (ref-p ref) (constant-reference-p ref)) + (return-from ir1-optimize-mv-call)) + + (multiple-value-bind (min max) + (function-type-nargs (continuation-type fun)) + (dolist (arg (basic-combination-args node)) + (multiple-value-bind (types nvals) + (values-types (continuation-derived-type arg)) + (declare (ignore types)) + (when (eq nvals :unknown) + (setq total-nvals nil) + (return)) + (incf total-nvals nvals))) + + (when total-nvals + (when (and min (< total-nvals min)) + (compiler-warning + "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ + at least ~R." + total-nvals min) + (setf (ref-inlinep ref) :notinline) + (return-from ir1-optimize-mv-call)) + (when (and max (> total-nvals max)) + (compiler-warning + "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ + at most ~R." + total-nvals max) + (setf (ref-inlinep ref) :notinline) + (return-from ir1-optimize-mv-call))) + + (let ((count (cond (total-nvals) + ((and (policy node (zerop safety)) (eql min max)) + min) + (t nil)))) + (when count + (with-ir1-environment node + (let* ((dums (loop repeat count collect (gensym))) + (ignore (gensym)) + (fun (ir1-convert-lambda + `(lambda (&optional ,@dums &rest ,ignore) + (declare (ignore ,ignore)) + (funcall ,(ref-leaf ref) ,@dums))))) + (change-ref-leaf ref fun) + (setf (basic-combination-kind node) :full) + (local-call-analyze *current-component*))))))) + + (undefined-value)) + + +;;; CONVERT-MV-BIND-TO-LET -- Internal ;;; ;;; If we see: ;;; (multiple-value-bind (x y) @@ -1239,46 +1346,75 @@ ;;; VALUES, discard the corresponding continuations. If there are insufficient ;;; args, insert references to NIL. ;;; -(defoptimizer (values optimizer) ((&rest ignore) node) - (declare (ignore ignore)) - (let ((dest (continuation-dest (node-cont node)))) - (when (and (mv-combination-p dest) - (eq (basic-combination-kind dest) :local) - (eq (continuation-use (first (basic-combination-args dest))) - node)) - (let* ((fun (combination-lambda dest)) +(defun convert-mv-bind-to-let (call) + (declare (type mv-combination call)) + (let* ((arg (first (basic-combination-args call))) + (use (continuation-use arg))) + (when (and (combination-p use) + (eq (continuation-function-name (combination-fun use)) + 'values)) + (let* ((fun (combination-lambda call)) (vars (lambda-vars fun)) - (vals (combination-args node)) + (vals (combination-args use)) (nvars (length vars)) (nvals (length vals))) (cond ((> nvals nvars) (mapc #'flush-dest (subseq vals nvars)) (setq vals (subseq vals 0 nvars))) ((< nvals nvars) - (with-ir1-environment node - (let ((node-prev (node-prev node))) - (setf (node-prev node) nil) + (with-ir1-environment use + (let ((node-prev (node-prev use))) + (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) (collect ((res vals)) - (loop as cont = (make-continuation node) + (loop as cont = (make-continuation use) and prev = node-prev then cont repeat (- nvars nvals) do (reference-constant prev cont nil) (res cont)) (setq vals (res))) - (prev-link node (car (last vals))))))) - (setf (combination-args node) vals) - (flush-dest (combination-fun node)) - (let ((fun-cont (basic-combination-fun dest))) - (setf (continuation-dest fun-cont) node) - (setf (combination-fun node) fun-cont)) - (setf (combination-kind node) :local) + (prev-link use (car (last vals))))))) + (setf (combination-args use) vals) + (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-kind use) :local) (setf (functional-kind fun) :let) - (flush-dest (first (basic-combination-args dest))) - (unlink-node dest) + (flush-dest (first (basic-combination-args call))) + (unlink-node call) (when vals (reoptimize-continuation (first vals))) - (propagate-to-args node fun)) + (propagate-to-args use fun)) + t))) + + +;;; VALUES-LIST IR1 optimizer -- Internal +;;; +;;; If we see: +;;; (values-list (list x y z)) +;;; +;;; Convert to: +;;; (values x y z) +;;; +;;; In implementation, this is somewhat similar to 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.) +;;; +(defoptimizer (values-list optimizer) ((list) node) + (let ((use (continuation-use list))) + (when (and (combination-p use) + (eq (continuation-function-name (combination-fun use)) + 'list)) + (change-ref-leaf (continuation-use (combination-fun node)) + (find-free-function 'values "in a strange place")) + (setf (combination-kind node) :full) + (let ((args (combination-args use))) + (dolist (arg args) + (setf (continuation-dest arg) node)) + (setf (combination-args use) nil) + (flush-dest list) + (setf (combination-args node) args)) t)))