+ (make-primcall src 'apply
+ (cons (for-value proc) args))))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src 'thunk? (proc))
+ (case ctx
+ ((effect)
+ (for-tail (make-seq src proc (make-void src))))
+ (else
+ (match (for-value proc)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (proc
+ (match (find-definition proc 2)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (_
+ (make-primcall src 'thunk? (list proc)))))))))
+
+ (($ <primcall> src name args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ (((? equality-primitive?)
+ ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+ (for-tail (make-const #f #t)))
+
+ (((? effect-free-primitive?) . args)
+ (fold-constants src name args ctx))
+
+ ((name . args)
+ (make-primcall src name args))))
+
+ (($ <call> src orig-proc orig-args)