oldts body seed ...)))
              (($ <prompt> src escape-only? tag body handler)
               (let*-values (((seed ...) (foldts tag seed ...))
                             ((seed ...) (foldts body seed ...)))
                 (foldts handler seed ...)))
              (($ <abort> src tag args tail)
               (let*-values (((seed ...) (foldts tag seed ...))
                             ((seed ...) (fold-values foldts args seed ...)))
                 (foldts tail seed ...)))
              (_
               (values seed ...)))))
        (up tree seed ...)))))

(define (tree-il-fold down up seed tree)
  "Traverse TREE, calling DOWN before visiting a sub-tree, and UP when
after visiting it.  Each of these procedures is invoked as `(PROC TREE
SEED)', where TREE is the sub-tree considered and SEED is the current
result, intially seeded with SEED.

This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''."
  ;; Multi-valued fold naturally puts the seeds at the end, whereas
  ;; normal fold puts the traversable at the end.  Adapt to the expected
  ;; argument order.
  ((make-tree-il-folder tree) tree down up seed))

(define (pre-post-order pre post x)
  (define (elts-eq? a b)
    (or (null? a)
        (and (eq? (car a) (car b))
             (elts-eq? (cdr a) (cdr b)))))
  (let lp ((x x))
    (post
     (let ((x (pre x)))
       (match x
         ((or ($ <void>)
              ($ <const>)
              ($ <primitive-ref>)
              ($ <lexical-ref>)
              ($ <module-ref>)
              ($ <toplevel-ref>))
          x)

         (($ <lexical-set> src name gensym exp)
          (let ((exp* (lp exp)))
            (if (eq? exp exp*)
                x
                (make-lexical-set src name gensym exp*))))

         (($ <module-set> src mod name public? exp)
          (let ((exp* (lp exp)))
            (if (eq? exp exp*)
                x
                (make-module-set src mod name public? exp*))))

         (($ <toplevel-set> src mod name exp)
          (let ((exp* (lp exp)))
            (if (eq? exp exp*)
                x
                (make-toplevel-set src mod name exp*))))

         (($ <toplevel-define> src mod name exp)
          (let ((exp* (lp exp)))
            (if (eq? exp exp*)
                x
                (make-toplevel-define src mod name exp*))))

         (($ <conditional> src test consequent alternate)
          (let ((test* (lp test))
                (consequent* (lp consequent))
                (alternate* (lp alternate)))
            (if (and (eq? test test*)
                     (eq? consequent consequent*)
                     (eq? alternate alternate*))
                x
                (make-conditional src test* consequent* alternate*))))

         (($ <call> src proc args)
          (let ((proc* (lp proc))
                (args* (map lp args)))
            (if (and (eq? proc proc*)
                     (elts-eq? args args*))
                x
                (make-call src proc* args*))))

         (($ <primcall> src name args)
          (let ((args* (map lp args)))
            (if (elts-eq? args args*)
                x
                (make-primcall src name args*))))

         (($ <seq> src head tail)
          (let ((head* (lp head))
                (tail* (lp tail)))
            (if (and (eq? head head*)
                     (eq? tail tail*))
                x
                (make-seq src head* tail*))))
      
         (($ <lambda> src meta body)
          (let ((body* (and body (lp body))))
            (if (eq? body body*)
                x
                (make-lambda src meta body*))))

         (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
          (let ((inits* (map lp inits))
                (body* (lp body))
                (alternate* (and alternate (lp alternate))))
            (if (and (elts-eq? inits inits*)
                     (eq? body body*)
                     (eq? alternate alternate*))
                x
                (make-lambda-case src req opt rest kw inits* gensyms body*
                                  alternate*))))

         (($ <let> src names gensyms vals body)
          (let ((vals* (map lp vals))
                (body* (lp body)))
            (if (and (elts-eq? vals vals*)
                     (eq? body body*))
                x
                (make-let src names gensyms vals* body*))))

         (($ <letrec> src in-order? names gensyms vals body)
          (let ((vals* (map lp vals))
                (body* (lp body)))
            (if (and (elts-eq? vals vals*)
                     (eq? body body*))
                x
                (make-letrec src in-order? names gensyms vals* body*))))

         (($ <fix> src names gensyms vals body)
          (let ((vals* (map lp vals))
                (body* (lp body)))
            (if (and (elts-eq? vals vals*)
                     (eq? body body*))
                x
                (make-fix src names gensyms vals* body*))))

         (($ <let-values> src exp body)
          (let ((exp* (lp exp))
                (body* (lp body)))
            (if (and (eq? exp exp*)
                     (eq? body body*))
                x
                (make-let-values src exp* body*))))

         (($ <prompt> src escape-only? tag body handler)
          (let ((tag* (lp tag))
                (body* (lp body))
                (handler* (lp handler)))
            (if (and (eq? tag tag*)
                     (eq? body body*)
                     (eq? handler handler*))
                x
                (make-prompt src escape-only? tag* body* handler*))))

         (($ <abort> src tag args tail)
          (let ((tag* (lp tag))
                (args* (map lp args))
                (tail* (lp tail)))
            (if (and (eq? tag tag*)
                     (elts-eq? args args*)
                     (eq? tail tail*))
                x
                (make-abort src tag* args* tail*)))))))))

(define (post-order f x)
  (pre-post-order (lambda (x) x) f x))

(define (pre-order f x)
  (pre-post-order f (lambda (x) x) x))

(define-syntax-rule (with-lexical src id . body)
  (let ((k (lambda (id) . body)))
    (match id
      (($ <lexical-ref>) (k id))
      (_
       (let ((tmp (gensym "v ")))
         (make-let src (list 'id) (list tmp) (list id)
                   (k (make-lexical-ref src 'id tmp))))))))
(define-syntax with-lexicals
  (syntax-rules ()
    ((with-lexicals src () . body) (let () . body))
    ((with-lexicals src (id . ids) . body)
     (with-lexical src id (with-lexicals src ids . body)))))

;; FIXME: We should have a better primitive than this.
(define (struct-nfields x)
  (/ (string-length (symbol->string (struct-layout x))) 2))

(define (tree-il=? a b)
  (cond
   ((struct? a)
    (and (struct? b)
         (eq? (struct-vtable a) (struct-vtable b))
         ;; Assume that all structs are tree-il, so we skip over the
         ;; src slot.
         (let lp ((n (1- (struct-nfields a))))
           (or (zero? n)
               (and (tree-il=? (struct-ref a n) (struct-ref b n))
                    (lp (1- n)))))))
   ((pair? a)
    (and (pair? b)
         (tree-il=? (car a) (car b))
         (tree-il=? (cdr a) (cdr b))))
   (else
    (equal? a b))))

(define-syntax hash-bits
  (make-variable-transformer
   (lambda (x)
     (syntax-case x ()
       (var
        (identifier? #'var)
        (logcount most-positive-fixnum))))))

(define (tree-il-hash exp)
  (let ((hash-depth 4)
        (hash-width 3))
    (define (hash-exp exp depth)
      (define (rotate x bits)
        (logior (ash x (- bits))
                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
      (define (mix h1 h2)
        (logxor h1 (rotate h2 8)))
      (define (hash-struct s)
        (let ((len (struct-nfields s))
              (h (hashq (struct-vtable s) most-positive-fixnum)))
          (if (zero? depth)
              h
              (let lp ((i (max (- len hash-width) 1)) (h h))
                (if (< i len)
                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
                    h)))))
      (define (hash-list l)
        (let ((h (hashq 'list most-positive-fixnum)))
          (if (zero? depth)
              h
              (let lp ((l l) (width 0) (h h))
                (if (< width hash-width)
                    (lp (cdr l) (1+ width)
                        (mix (hash-exp (car l) (1+ depth)) h))
                    h)))))
      (cond
       ((struct? exp) (hash-struct exp))
       ((list? exp) (hash-list exp))
       (else (hash exp most-positive-fixnum))))

    (hash-exp exp 0)))