+
+;;;; transforming references to &REST argument
+
+;;; We add magical &MORE arguments to all functions with &REST. If ARG names
+;;; the &REST argument, this returns the lambda-vars for the context and
+;;; count.
+(defun possible-rest-arg-context (arg)
+ (when (symbolp arg)
+ (let* ((var (lexenv-find arg vars))
+ (info (when (lambda-var-p var)
+ (lambda-var-arg-info var))))
+ (when (and info
+ (eq :rest (arg-info-kind info))
+ (consp (arg-info-default info)))
+ (values-list (arg-info-default info))))))
+
+(defun mark-more-context-used (rest-var)
+ (let ((info (lambda-var-arg-info rest-var)))
+ (aver (eq :rest (arg-info-kind info)))
+ (destructuring-bind (context count &optional used) (arg-info-default info)
+ (unless used
+ (setf (arg-info-default info) (list context count t))))))
+
+(defun mark-more-context-invalid (rest-var)
+ (let ((info (lambda-var-arg-info rest-var)))
+ (aver (eq :rest (arg-info-kind info)))
+ (setf (arg-info-default info) t)))
+
+;;; This determines of we the REF to a &REST variable is headed towards
+;;; parts unknown, or if we can really use the context.
+(defun rest-var-more-context-ok (lvar)
+ (let* ((use (lvar-use lvar))
+ (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)))
+ (restp (when info (eq :rest (arg-info-kind info)))))
+ (flet ((ref-good-for-more-context-p (ref)
+ (let ((dest (principal-lvar-end (node-lvar ref))))
+ (and (combination-p dest)
+ ;; If the destination is to anything but these, we're going to
+ ;; actually need the rest list -- and since other operations
+ ;; might modify the list destructively, the using the context
+ ;; isn't good anywhere else either.
+ (lvar-fun-is (combination-fun dest)
+ '(%rest-values %rest-ref %rest-length
+ %rest-null %rest-true))
+ ;; 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 ((ok (and restp
+ (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)))))
+ (if ok
+ (mark-more-context-used var)
+ (when restp
+ (mark-more-context-invalid var)))
+ ok))))
+
+;;; VALUES-LIST -> %REST-VALUES
+(define-source-transform values-list (list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-values ,list ,context ,count)
+ (values nil t))))
+
+;;; NTH -> %REST-REF
+(define-source-transform nth (n list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-ref ,n ,list ,context ,count)
+ `(car (nthcdr ,n ,list)))))
+
+(define-source-transform elt (seq n)
+ (if (policy *lexenv* (= safety 3))
+ (values nil t)
+ (multiple-value-bind (context count) (possible-rest-arg-context seq)
+ (if context
+ `(%rest-ref ,n ,seq ,context ,count)
+ (values nil t)))))
+
+;;; CAxR -> %REST-REF
+(defun source-transform-car (list nth)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-ref ,nth ,list ,context ,count)
+ (values nil t))))
+
+(define-source-transform car (list)
+ (source-transform-car list 0))
+
+(define-source-transform cadr (list)
+ (or (source-transform-car list 1)
+ `(car (cdr ,list))))
+
+(define-source-transform caddr (list)
+ (or (source-transform-car list 2)
+ `(car (cdr (cdr ,list)))))
+
+(define-source-transform cadddr (list)
+ (or (source-transform-car list 3)
+ `(car (cdr (cdr (cdr ,list))))))
+
+;;; LENGTH -> %REST-LENGTH
+(defun source-transform-length (list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-length ,list ,context ,count)
+ (values nil t))))
+(define-source-transform length (list) (source-transform-length list))
+(define-source-transform list-length (list) (source-transform-length list))
+
+;;; ENDP, NULL and NOT -> %REST-NULL
+;;;
+;;; Outside &REST convert into an IF so that IF optimizations will eliminate
+;;; redundant negations.
+(defun source-transform-null (x op)
+ (multiple-value-bind (context count) (possible-rest-arg-context x)
+ (cond (context
+ `(%rest-null ',op ,x ,context ,count))
+ ((eq 'endp op)
+ `(if (the list ,x) nil t))
+ (t
+ `(if ,x nil t)))))
+(define-source-transform not (x) (source-transform-null x 'not))
+(define-source-transform null (x) (source-transform-null x 'null))
+(define-source-transform endp (x) (source-transform-null x 'endp))
+
+(deftransform %rest-values ((list context count))
+ (if (rest-var-more-context-ok list)
+ `(%more-arg-values context 0 count)
+ `(values-list list)))
+
+(deftransform %rest-ref ((n list context count))
+ (cond ((rest-var-more-context-ok list)
+ `(and (< (the index n) count)
+ (%more-arg context n)))
+ ((and (constant-lvar-p n) (zerop (lvar-value n)))
+ `(car list))
+ (t
+ `(nth n list))))
+
+(deftransform %rest-length ((list context count))
+ (if (rest-var-more-context-ok list)
+ 'count
+ `(length list)))
+
+(deftransform %rest-null ((op list context count))
+ (aver (constant-lvar-p op))
+ (if (rest-var-more-context-ok list)
+ `(eql 0 count)
+ `(,(lvar-value op) list)))
+
+(deftransform %rest-true ((list context count))
+ (if (rest-var-more-context-ok list)
+ `(not (eql 0 count))
+ `list))