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)
@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}.
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
optional
rest
keyword
+ more
deleted)
`(etypecase ,element
(sb!di:debug-var
(ecase (car ,element)
(:optional ,@optional)
(:rest ,@rest)
- (:keyword ,@keyword)))
+ (:keyword ,@keyword)
+ (:more ,@more)))
(symbol
(aver (eq ,element :deleted))
,@deleted)))
(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 ()
(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)))))
\f
;;;; 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))
(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))
(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))))
(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)
(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)
(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)
(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)))
;; 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))) ...).
(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)))))))
+
\f
;;;; transforming FORMAT
;;;;
(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)
(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)))))
;;; 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"
projects / sbcl.git / commitdiff