(lambda () #f)))))
    (define (transform-primcall f cps label names vars k src op param args)
      (and f
           (match args
             ((arg0)
              (call-with-values (lambda () (lookup-pre-type types label arg0))
                (lambda (type0 min0 max0)
                  (call-with-values (lambda ()
                                      (f cps k src param arg0 type0 min0 max0))
                    (lambda (cps term)
                      (and term
                           (with-cps cps
                             (setk label ($kargs names vars ,term)))))))))
             ((arg0 arg1)
              (call-with-values (lambda () (lookup-pre-type types label arg0))
                (lambda (type0 min0 max0)
                  (call-with-values (lambda () (lookup-pre-type types label arg1))
                    (lambda (type1 min1 max1)
                      (call-with-values (lambda ()
                                          (f cps k src param arg0 type0 min0 max0
                                             arg1 type1 min1 max1))
                        (lambda (cps term)
                          (and term
                               (with-cps cps
                                 (setk label ($kargs names vars ,term)))))))))))
             (_ #f))))
    (define (reduce-primcall cps label names vars k src op param args)
      (cond
       ((transform-primcall (hashq-ref *primcall-macro-reducers* op)
                            cps label names vars k src op param args)
        => (lambda (cps)
             (match (intmap-ref cps label)
               (($ $kargs names vars
                   ($ $continue k src ($ $primcall op param args)))
                (reduce-primcall cps label names vars k src op param args)))))
       ((transform-primcall (hashq-ref *primcall-reducers* op)
                            cps label names vars k src op param args))
       (else cps)))
    (define (reduce-branch cps label names vars kf kt src op param args)
      (and=>
       (hashq-ref *branch-reducers* op)
       (lambda (reducer)
         (match args
           ((arg0)
            (call-with-values (lambda () (lookup-pre-type types label arg0))
              (lambda (type0 min0 max0)
                (call-with-values (lambda ()
                                    (reducer cps kf kt src param
                                             arg0 type0 min0 max0))
                  (lambda (cps term)
                    (and term
                         (with-cps cps
                           (setk label
                                 ($kargs names vars ,term)))))))))
           ((arg0 arg1)
            (call-with-values (lambda () (lookup-pre-type types label arg0))
              (lambda (type0 min0 max0)
                (call-with-values (lambda () (lookup-pre-type types label arg1))
                  (lambda (type1 min1 max1)
                    (call-with-values (lambda ()
                                        (reducer cps kf kt src param
                                                 arg0 type0 min0 max0
                                                 arg1 type1 min1 max1))
                      (lambda (cps term)
                        (and term
                             (with-cps cps
                               (setk label
                                     ($kargs names vars ,term)))))))))))))))
    (define (branch-folded cps label names vars src k)
      (with-cps cps
        (setk label
              ($kargs names vars
                ($continue k src ($values ()))))))
    (define (fold-unary-branch cps label names vars kf kt src op param arg)
      (and=>
       (hashq-ref *branch-folders* op)
       (lambda (folder)
         (call-with-values (lambda () (lookup-pre-type types label arg))
           (lambda (type min max)
             (call-with-values (lambda () (folder param type min max))
               (lambda (f? v)
                 ;; (when f? (pk 'folded-unary-branch label op arg v))
                 (and f?
                      (branch-folded cps label names vars src
                                     (if v kt kf))))))))))
    (define (fold-binary-branch cps label names vars kf kt src op param arg0 arg1)
      (and=>
       (hashq-ref *branch-folders* op)
       (lambda (folder)
         (call-with-values (lambda () (lookup-pre-type types label arg0))
           (lambda (type0 min0 max0)
             (call-with-values (lambda () (lookup-pre-type types label arg1))
               (lambda (type1 min1 max1)
                 (call-with-values (lambda ()
                                     (folder param type0 min0 max0 type1 min1 max1))
                   (lambda (f? v)
                     ;; (when f? (pk 'folded-binary-branch label op arg0 arg1 v))
                     (and f?
                          (branch-folded cps label names vars src
                                         (if v kt kf))))))))))))
    (define (fold-branch cps label names vars kf kt src op param args)
      (match args
        ((x)
         (fold-unary-branch cps label names vars kf kt src op param x))
        ((x y)
         (fold-binary-branch cps label names vars kf kt src op param x y))))
    (define (visit-primcall cps label names vars k src op param args)
      ;; We might be able to fold primcalls that define a value.
      (match (intmap-ref cps k)
        (($ $kargs (_) (def))
         (or (fold-primcall cps label names vars k src op param args def)
             (reduce-primcall cps label names vars k src op param args)))
        (_
         (reduce-primcall cps label names vars k src op param args))))
    (define (visit-branch cps label names vars kf kt src op param args)
      ;; We might be able to fold primcalls that branch.
      (or (fold-branch cps label names vars kf kt src op param args)
          (reduce-branch cps label names vars kf kt src op param args)
          cps))
    (define (visit-switch cps label names vars kf kt* src arg)
      ;; We might be able to fold or reduce a switch.
      (let ((ntargets (length kt*)))
        (call-with-values (lambda () (lookup-pre-type types label arg))
          (lambda (type min max)
            (cond
             ((<= ntargets min)
              (branch-folded cps label names vars src kf))
             ((= min max)
              (branch-folded cps label names vars src (list-ref kt* min)))
             (else
              ;; There are two more optimizations we could do here: one,
              ;; if max is less than ntargets, we can prune targets at
              ;; the end of the switch, and perhaps reduce the switch
              ;; back to a branch; and two, if min is greater than 0,
              ;; then we can subtract off min and prune targets at the
              ;; beginning.  Not done yet though.
              cps))))))
    (let lp ((label start) (cps cps))
      (if (<= label end)
          (lp (1+ label)
              (match (intmap-ref cps label)
                (($ $kargs names vars ($ $continue k src
                                         ($ $primcall op param args)))
                 (visit-primcall cps label names vars k src op param args))
                (($ $kargs names vars ($ $branch kf kt src op param args))
                 (visit-branch cps label names vars kf kt src op param args))
                (($ $kargs names vars ($ $switch kf kt* src arg))
                 (visit-switch cps label names vars kf kt* src arg))
                (_ cps)))
          cps))))

(define (fold-functions-in-renumbered-program f conts seed)
  (let* ((conts (persistent-intmap conts))
         (end (1+ (intmap-prev conts))))
    (let lp ((label 0) (seed seed))
      (if (eqv? label end)
          seed
          (match (intmap-ref conts label)
            (($ $kfun src meta self tail clause)
             (lp (1+ tail) (f label tail seed))))))))

(define (type-fold conts)
  ;; Type analysis wants a program whose labels are sorted.
  (let ((conts (renumber conts)))
    (with-fresh-name-state conts
      (persistent-intmap
       (fold-functions-in-renumbered-program local-type-fold conts conts)))))