From e8011f7c83587a9dc1b13281d0cc974bb0b054be Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 25 May 2011 23:02:28 +0000 Subject: [PATCH] 1.0.48.25: automatic &rest to &more conversion lp#504575 Automatically convert (values-list rest-arg) to (%more-arg-values more-context 0 more-count) when possible, making functions such as (defun foo (f1 f2 &rest args) (apply f1 args) (apply f2 args)) non-consing. The conversion is done iff: * The rest arg is never assigned to. * The rest arg only appears in VALUES-LIST (incl. APPLY) calls. * Those calls are all in either the same lambda that allocates the rest-list, or one that has been declared dynamic extent. (Conservative guess re. escaping.) The way this works is as follows: 1. When we convert a lambda with a non-ignored &rest argument, as add more-context and more-count arguments to the function, and stick their lambda-vars into arg-info-default of the &rest arg. 2. When we source-transform a values-list form, we check if its argument is a &rest argument for which context and count are available. If so, we source-transform into (%values-list-or-context list context count) 3. When we are optimizing, a deftransform fires for the form above. It checks if all the necessary conditions hold and converts into either %more-arg-values or values-list. The reason for this roundabout way of doing things lies in locall analysis: unless the extra context and count argument are used nontrivially when it runs, they get deleted -- and we don't know if we want them or not until the entire function has been converted. Absent a convenient pass between conversion and locall analysis, we must therefore do things in two stages. --- NEWS | 4 +++ doc/manual/efficiency.texinfo | 5 --- src/code/debug-int.lisp | 11 +++--- src/code/debug.lisp | 18 ++++++++-- src/compiler/debug-dump.lisp | 51 ++++++++++++++++----------- src/compiler/fndb.lisp | 2 ++ src/compiler/ir1tran-lambda.lisp | 29 +++++++++++---- src/compiler/locall.lisp | 16 +++++++++ src/compiler/node.lisp | 3 ++ src/compiler/srctran.lisp | 55 +++++++++++++++++++++++++++-- tests/debug.impure.lisp | 2 +- tests/dynamic-extent.impure.lisp | 72 ++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 13 files changed, 227 insertions(+), 43 deletions(-) diff --git a/NEWS b/NEWS index c4046b6..6fb8705 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,10 @@ changes relative to sbcl-1.0.48: spines, not their argumets. While portable code should not rely on this, particularly in combination with inlining, it should make dynamic-extent easier and safer to use. + * optimization: using a &REST argument only in APPLY or VALUES-LIST calls + allows the compiler to automatically elide rest-list allocation so long + as the call sites are in functions that the compiler knows cannot escape. + (lp#504575) * bug fix: blocking reads from FIFOs created by RUN-PROGRAM were uninterruptible, as well as blocking reads from socket streams created with for which :SERVE-EVENTS NIL. (regression from 1.0.42.43) diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo index 31fcee0..f69c366 100644 --- a/doc/manual/efficiency.texinfo +++ b/doc/manual/efficiency.texinfo @@ -215,11 +215,6 @@ Future plans include @itemize @item -Automatic detection of the common idiom of applying a function to some -defaults and a @code{&rest} list, even when this is not declared -@code{dynamic-extent}; - -@item Automatic detection of the common idiom of calling quantifiers with a closure, even when the closure is not declared @code{dynamic-extent}. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 89d1b7a..b37c0c0 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1409,10 +1409,13 @@ register." args (incf i) vars)) res)) (sb!c::more-arg - ;; Just ignore the fact that the next two args are - ;; the &MORE arg context and count, and act like they - ;; are regular arguments. - nil) + ;; The next two args are the &MORE arg context and count. + (push (list :more + (compiled-debug-fun-lambda-list-var + args (incf i) vars) + (compiled-debug-fun-lambda-list-var + args (incf i) vars)) + res)) (t ;; &KEY arg (push (list :keyword diff --git a/src/code/debug.lisp b/src/code/debug.lisp index cca2e62..adc28e0 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -247,6 +247,7 @@ thread, NIL otherwise." optional rest keyword + more deleted) `(etypecase ,element (sb!di:debug-var @@ -255,7 +256,8 @@ thread, NIL otherwise." (ecase (car ,element) (:optional ,@optional) (:rest ,@rest) - (:keyword ,@keyword))) + (:keyword ,@keyword) + (:more ,@more))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -301,7 +303,19 @@ thread, NIL otherwise." (return-from enumerating)) (push (make-unprintable-object "unavailable &REST argument") - reversed-result))))) + reversed-result))) + :more ((lambda-var-dispatch (second element) location + nil + (let ((context (sb!di:debug-var-value (second element) frame)) + (count (sb!di:debug-var-value (third element) frame))) + (setf reversed-result + (append (reverse + (multiple-value-list + (sb!c::%more-arg-values context 0 count))) + reversed-result)) + (return-from enumerating)) + (push (make-unprintable-object "unavailable &MORE argument") + reversed-result))))) frame)) (nreverse reversed-result)) (sb!di:lambda-list-unavailable () diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index faecc2b..6633b3f 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -464,27 +464,36 @@ (if (and od (eq (optional-dispatch-main-entry od) fun)) (let ((actual-vars (lambda-vars fun)) (saw-optional nil)) - (dolist (arg (optional-dispatch-arglist od)) - (let ((info (lambda-var-arg-info arg)) - (actual (pop actual-vars))) - (cond (info - (case (arg-info-kind info) - (:keyword - (res (arg-info-key info))) - (:rest - (res 'rest-arg)) - (:more-context - (res 'more-arg)) - (:optional - (unless saw-optional - (res 'optional-args) - (setq saw-optional t)))) - (res (debug-location-for actual var-locs)) - (when (arg-info-supplied-p info) - (res 'supplied-p) - (res (debug-location-for (pop actual-vars) var-locs)))) - (t - (res (debug-location-for actual var-locs))))))) + (labels ((one-arg (arg) + (let ((info (lambda-var-arg-info arg)) + (actual (pop actual-vars))) + (cond (info + (case (arg-info-kind info) + (:keyword + (res (arg-info-key info))) + (:rest + (let ((more (arg-info-default info))) + (cond ((and (consp more) (third more)) + (one-arg (first (arg-info-default info))) + (one-arg (second (arg-info-default info))) + (return-from one-arg)) + (more + (setf (arg-info-default info) t))) + (res 'rest-arg))) + (:more-context + (res 'more-arg)) + (:optional + (unless saw-optional + (res 'optional-args) + (setq saw-optional t)))) + (res (debug-location-for actual var-locs)) + (when (arg-info-supplied-p info) + (res 'supplied-p) + (res (debug-location-for (pop actual-vars) var-locs)))) + (t + (res (debug-location-for actual var-locs))))))) + (dolist (arg (optional-dispatch-arglist od)) + (one-arg arg)))) (dolist (var (lambda-vars fun)) (res (debug-location-for var var-locs))))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 9f1085f..75f0e00 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1395,6 +1395,8 @@ ;;;; magical compiler frobs +(defknown %values-list-or-context (t t t) * (always-translatable)) + (defknown %unary-truncate/single-float (single-float) integer (movable foldable flushable)) (defknown %unary-truncate/double-float (double-float) integer (movable foldable flushable)) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 0404588..4ae5cae 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -544,8 +544,7 @@ (arg-vars context-temp count-temp) (when rest - (arg-vals `(%listify-rest-args - ,n-context ,n-count))) + (arg-vals `(%listify-rest-args ,n-context ,n-count))) (when morep (arg-vals n-context) (arg-vals n-count)) @@ -561,6 +560,7 @@ (n-key (gensym "N-KEY-")) (n-value-temp (gensym "N-VALUE-TEMP-")) (n-allowp (gensym "N-ALLOWP-")) + (n-lose (gensym "N-LOSE-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) (policy *lexenv* (zerop safety)))) @@ -603,12 +603,13 @@ (tests clause))) (unless allowp - (temps n-allowp n-losep) + (temps n-allowp n-lose n-losep) (unless found-allow-p (tests `((eq ,n-key :allow-other-keys) (setq ,n-allowp ,n-value-temp)))) (tests `(t - (setq ,n-losep (list ,n-key))))) + (setq ,n-lose ,n-key + ,n-losep t)))) (body `(when (oddp ,n-count) @@ -637,7 +638,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-arg-error (car ,n-losep)))))))) + (%unknown-key-arg-error ,n-lose))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -683,7 +684,23 @@ (bind-vals)) (when rest (main-vars rest) - (main-vals '())) + (main-vals '()) + (unless (lambda-var-ignorep rest) + ;; Make up two extra variables, and squirrel them away in + ;; ARG-INFO-DEFAULT for transforming (VALUES-LIST REST) into + ;; (%MORE-ARG-VALUES CONTEXT 0 COUNT) when possible. + (let* ((context-name (gensym "REST-CONTEXT")) + (context (make-lambda-var :%source-name context-name + :arg-info (make-arg-info :kind :more-context))) + (count-name (gensym "REST-COUNT")) + (count (make-lambda-var :%source-name count-name + :arg-info (make-arg-info :kind :more-count) + :type (specifier-type 'index)))) + (setf (arg-info-default (lambda-var-arg-info rest)) (list context count) + (lambda-var-ever-used context) t + (lambda-var-ever-used count) t) + (setf more-context context + more-count count)))) (when more-context (main-vars more-context) (main-vals nil) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index b6d52c2..9e605c1 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -683,6 +683,22 @@ (call-args t))) (:rest (call-args `(list ,@more-temps)) + ;; &REST arguments may be accompanied by extra + ;; context and count arguments. We know this by + ;; the ARG-INFO-DEFAULT. Supply NIL and 0 or + ;; don't convert at all depending. + (let ((more (arg-info-default info))) + (when more + (unless (eq t more) + (destructuring-bind (context count &optional used) more + (declare (ignore context count)) + (when used + ;; We've already converted to use the more context + ;; instead of the rest list. + (return-from convert-more-call)))) + (call-args nil) + (call-args 0) + (setf (arg-info-default info) t))) (return)) (:keyword (return))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 1d5f635..c8ac71e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1078,6 +1078,9 @@ ;; the default for a keyword or optional, represented as the ;; original Lisp code. This is set to NIL in &KEY arguments that are ;; defaulted using the SUPPLIED-P arg. + ;; + ;; For &REST arguments this may contain information about more context + ;; the rest list comes from. (default nil :type t) ;; the actual key for a &KEY argument. Note that in ANSI CL this is ;; not necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ...). diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 83c40f6..f8f40b4 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3866,10 +3866,59 @@ (define-source-transform apply (fun arg &rest more-args) (let ((args (cons arg more-args))) `(multiple-value-call ,fun - ,@(mapcar (lambda (x) - `(values ,x)) - (butlast args)) + ,@(mapcar (lambda (x) `(values ,x)) (butlast args)) (values-list ,(car (last args)))))) + +;;; When &REST argument are at play, we also have extra context and count +;;; arguments -- convert to %VALUES-LIST-OR-CONTEXT when possible, so that the +;;; deftransform can decide what to do after everything has been converted. +(define-source-transform values-list (list) + (if (symbolp list) + (let* ((var (lexenv-find list vars)) + (info (when (lambda-var-p var) + (lambda-var-arg-info var)))) + (if (and info + (eq :rest (arg-info-kind info)) + (consp (arg-info-default info))) + (destructuring-bind (context count &optional used) (arg-info-default info) + (declare (ignore used)) + `(%values-list-or-context ,list ,context ,count)) + (values nil t))) + (values nil t))) + +(deftransform %values-list-or-context ((list context count) * * :node node) + (let* ((use (lvar-use list)) + (var (when (ref-p use) (ref-leaf use))) + (home (when (lambda-var-p var) (lambda-var-home var))) + (info (when (lambda-var-p var) (lambda-var-arg-info var)))) + (flet ((ref-good-for-more-context-p (ref) + (let ((dest (principal-lvar-end (node-lvar ref)))) + (and (combination-p dest) + ;; Uses outside VALUES-LIST will require a &REST list anyways, + ;; to it's no use saving effort here -- plus they might modify + ;; the list destructively. + (eq '%values-list-or-context (lvar-fun-name (combination-fun dest))) + ;; If the home lambda is different and isn't DX, it might + ;; escape -- in which case using the more context isn't safe. + (let ((clambda (node-home-lambda dest))) + (or (eq home clambda) + (leaf-dynamic-extent clambda))))))) + (let ((context-ok + (and info + (consp (arg-info-default info)) + (not (lambda-var-specvar var)) + (not (lambda-var-sets var)) + (every #'ref-good-for-more-context-p (lambda-var-refs var))))) + (cond (context-ok + (destructuring-bind (context count &optional used) (arg-info-default info) + (declare (ignore used)) + (setf (arg-info-default info) (list context count t))) + `(%more-arg-values context 0 count)) + (t + (when info + (setf (arg-info-default info) t)) + `(values-list list))))))) + ;;;; transforming FORMAT ;;;; diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index d0a5ec6..7323377 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -112,7 +112,7 @@ (and (equal (car spec) (car frame)) (args-equal (cdr spec) (cdr frame)))) - (print (list :mismatch spec frame)) + (print (list :wanted spec :got frame)) (setf result nil))) frame-specs backtrace) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 912b44e..16aa5e9 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -928,3 +928,75 @@ (with-test (:name :rest-stops-dynamic-extent) (assert (rest-stops-dx-ok))) +;;;; These tests aren't strictly speaking DX, but rather &REST -> &MORE +;;;; conversion. +(with-test (:name :rest-to-more-conversion) + (let ((f1 (compile nil `(lambda (f &rest args) + (apply f args))))) + (assert-no-consing (assert (eql f1 (funcall f1 #'identity f1))))) + (let ((f2 (compile nil `(lambda (f1 f2 &rest args) + (values (apply f1 args) (apply f2 args)))))) + (assert-no-consing (multiple-value-bind (a b) + (funcall f2 (lambda (x y z) (+ x y z)) (lambda (x y z) (- x y z)) + 1 2 3) + (assert (and (eql 6 a) (eql -4 b)))))) + (let ((f3 (compile nil `(lambda (f &optional x &rest args) + (when x + (apply f x args)))))) + (assert-no-consing (assert (eql 42 (funcall f3 + (lambda (a b c) (+ a b c)) + 11 + 10 + 21))))) + (let ((f4 (compile nil `(lambda (f &optional x &rest args &key y &allow-other-keys) + (apply f y x args))))) + (assert-no-consing (funcall f4 (lambda (y x yk y2 b c) + (assert (eq y 'y)) + (assert (= x 2)) + (assert (eq :y yk)) + (assert (eq y2 'y)) + (assert (eq b 'b)) + (assert (eq c 'c))) + 2 :y 'y 'b 'c))) + (let ((f5 (compile nil `(lambda (a b c &rest args) + (apply #'list* a b c args))))) + (assert (equal '(1 2 3 4 5 6 7) (funcall f5 1 2 3 4 5 6 '(7))))) + (let ((f6 (compile nil `(lambda (x y) + (declare (optimize speed)) + (concatenate 'string x y))))) + (assert (equal "foobar" (funcall f6 "foo" "bar")))) + (let ((f7 (compile nil `(lambda (&rest args) + (lambda (f) + (apply f args)))))) + (assert (equal '(a b c d e f) (funcall (funcall f7 'a 'b 'c 'd 'e 'f) 'list)))) + (let ((f8 (compile nil `(lambda (&rest args) + (flet ((foo (f) + (apply f args))) + #'foo))))) + (assert (equal '(a b c d e f) (funcall (funcall f8 'a 'b 'c 'd 'e 'f) 'list)))) + (let ((f9 (compile nil `(lambda (f &rest args) + (flet ((foo (g) + (apply g args))) + (declare (dynamic-extent #'foo)) + (funcall f #'foo)))))) + (assert (equal '(a b c d e f) + (funcall f9 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f)))) + (let ((f10 (compile nil `(lambda (f &rest args) + (flet ((foo (g) + (apply g args))) + (funcall f #'foo)))))) + (assert (equal '(a b c d e f) + (funcall f10 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f)))) + (let ((f11 (compile nil `(lambda (x y z) + (block out + (labels ((foo (x &rest rest) + (apply (lambda (&rest rest2) + (return-from out (values-list rest2))) + x rest))) + (if x + (foo x y z) + (foo y z x)))))))) + (multiple-value-bind (a b c) (funcall f11 1 2 3) + (assert (eql a 1)) + (assert (eql b 2)) + (assert (eql c 3))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5f395da..0067ef3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.48.24" +"1.0.48.25" -- 1.7.10.4