module/language/cps.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; This is the continuation-passing style (CPS) intermediate language
  22 ;;; (IL) for Guile.
  23 ;;;
  24 ;;; There are two kinds of terms in CPS: terms that bind continuations,
  25 ;;; and terms that call continuations.
  26 ;;;
  27 ;;; $letk binds a set of mutually recursive continuations, each one an
  28 ;;; instance of $cont.  A $cont declares the name of a continuation, and
  29 ;;; then contains as a subterm the particular continuation instance:
  30 ;;; $kargs for continuations that bind values, $ktail for the tail
  31 ;;; continuation, etc.
  32 ;;;
  33 ;;; $continue nodes call continuations.  The expression contained in the
  34 ;;; $continue node determines the value or values that are passed to the
  35 ;;; target continuation: $const to pass a constant value, $values to
  36 ;;; pass multiple named values, etc.  $continue nodes also record the source at which
  37 ;;;
  38 ;;; Additionally there is $letrec, a term that binds mutually recursive
  39 ;;; functions.  The contification pass will turn $letrec into $letk if
  40 ;;; it can do so.  Otherwise, the closure conversion pass will desugar
  41 ;;; $letrec into an equivalent sequence of make-closure primcalls and
  42 ;;; subsequent initializations of the captured variables of the
  43 ;;; closures.  You can think of $letrec as pertaining to "high CPS",
  44 ;;; whereas later passes will only see "low CPS", which does not have
  45 ;;; $letrec.
  46 ;;;
  47 ;;; This particular formulation of CPS was inspired by Andrew Kennedy's
  48 ;;; 2007 paper, "Compiling with Continuations, Continued".  All Guile
  49 ;;; hackers should read that excellent paper!  As in Kennedy's paper,
  50 ;;; continuations are second-class, and may be thought of as basic block
  51 ;;; labels.  All values are bound to variables using continuation calls:
  52 ;;; even constants!
  53 ;;;
  54 ;;; There are some Guile-specific quirks as well:
  55 ;;;
  56 ;;;   - $kreceive represents a continuation that receives multiple values,
  57 ;;;     but which truncates them to some number of required values,
  58 ;;;     possibly with a rest list.
  59 ;;;
  60 ;;;   - $kfun labels an entry point for a $fun (a function), and
  61 ;;;     contains a $ktail representing the formal argument which is the
  62 ;;;     function's continuation.
  63 ;;;
  64 ;;;   - $kfun also contain a $kclause continuation, corresponding to
  65 ;;;     the first case-lambda clause of the function.  $kclause actually
  66 ;;;     contains the clause body, and the subsequent clause (if any).
  67 ;;;     This is because the $kclause logically matches or doesn't match
  68 ;;;     a given set of actual arguments against a formal arity, then
  69 ;;;     proceeds to a "body" continuation (which is a $kargs).
  70 ;;;
  71 ;;;     That's to say that a $fun can be matched like this:
  72 ;;;
  73 ;;;     (match f
  74 ;;;       (($ $fun free
  75 ;;;           ($ $cont kfun
  76 ;;;              ($ $kfun src meta self ($ $cont ktail ($ $ktail))
  77 ;;;                 ($ $kclause arity
  78 ;;;                    ($ $cont kbody ($ $kargs names syms body))
  79 ;;;                    alternate))))
  80 ;;;         #t))
  81 ;;;
  82 ;;;     A $continue to ktail is in tail position.  $kfun, $kclause,
  83 ;;;     and $ktail will never be seen elsewhere in a CPS term.
  84 ;;;
  85 ;;;   - $prompt continues to the body of the prompt, having pushed on a
  86 ;;;     prompt whose handler will continue at its "handler"
  87 ;;;     continuation.  The continuation of the prompt is responsible for
  88 ;;;     popping the prompt.
  89 ;;;
  90 ;;; In summary:
  91 ;;;
  92 ;;;   - $letk, $letrec, and $continue are terms.
  93 ;;;
  94 ;;;   - $cont is a continuation, containing a continuation body ($kargs,
  95 ;;;     $ktail, etc).
  96 ;;;
  97 ;;;   - $continue terms contain an expression ($call, $const, $fun,
  98 ;;;     etc).
  99 ;;;
 100 ;;; See (language tree-il compile-cps) for details on how Tree-IL
 101 ;;; converts to CPS.
 102 ;;;
 103 ;;; Code:
 104
 105 (define-module (language cps)
 106   #:use-module (ice-9 match)
 107   #:use-module ((srfi srfi-1) #:select (fold))
 108   #:use-module (srfi srfi-9)
 109   #:use-module (srfi srfi-9 gnu)
 110   #:use-module (srfi srfi-11)
 111   #:export (;; Helper.
 112             $arity
 113             make-$arity
 114
 115             ;; Terms.
 116             $letk $continue $letrec
 117
 118             ;; Continuations.
 119             $cont
 120
 121             ;; Continuation bodies.
 122             $kreceive $kargs $kfun $ktail $kclause
 123
 124             ;; Expressions.
 125             $void $const $prim $fun $closure $branch
 126             $call $callk $primcall $values $prompt
 127
 128             ;; First-order CPS root.
 129             $program
 130
 131             ;; Fresh names.
 132             label-counter var-counter
 133             fresh-label fresh-var
 134             with-fresh-name-state compute-max-label-and-var
 135             let-fresh
 136
 137             ;; Building macros.
 138             build-cps-term build-cps-cont build-cps-exp
 139             rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
 140
 141             ;; Misc.
 142             parse-cps unparse-cps
 143             make-global-cont-folder make-local-cont-folder
 144             fold-conts fold-local-conts
 145             visit-cont-successors))
 146
 147 ;; FIXME: Use SRFI-99, when Guile adds it.
 148 (define-syntax define-record-type*
 149   (lambda (x)
 150     (define (id-append ctx . syms)
 151       (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
 152     (syntax-case x ()
 153       ((_ name field ...)
 154        (and (identifier? #'name) (and-map identifier? #'(field ...)))
 155        (with-syntax ((cons (id-append #'name #'make- #'name))
 156                      (pred (id-append #'name #'name #'?))
 157                      ((getter ...) (map (lambda (f)
 158                                           (id-append f #'name #'- f))
 159                                         #'(field ...))))
 160          #'(define-record-type name
 161              (cons field ...)
 162              pred
 163              (field getter)
 164              ...))))))
 165
 166 (define-syntax-rule (define-cps-type name field ...)
 167   (begin
 168     (define-record-type* name field ...)
 169     (set-record-type-printer! name print-cps)))
 170
 171 (define (print-cps exp port)
 172   (format port "#<cps ~S>" (unparse-cps exp)))
 173
 174 ;; Helper.
 175 (define-record-type* $arity req opt rest kw allow-other-keys?)
 176
 177 ;; Terms.
 178 (define-cps-type $letk conts body)
 179 (define-cps-type $continue k src exp)
 180 (define-cps-type $letrec names syms funs body) ; Higher-order.
 181
 182 ;; Continuations
 183 (define-cps-type $cont k cont)
 184 (define-cps-type $kreceive arity k)
 185 (define-cps-type $kargs names syms body)
 186 (define-cps-type $kfun src meta self tail clause)
 187 (define-cps-type $ktail)
 188 (define-cps-type $kclause arity cont alternate)
 189
 190 ;; Expressions.
 191 (define-cps-type $void)
 192 (define-cps-type $const val)
 193 (define-cps-type $prim name)
 194 (define-cps-type $fun free body) ; Higher-order.
 195 (define-cps-type $closure label nfree) ; First-order.
 196 (define-cps-type $branch k exp)
 197 (define-cps-type $call proc args)
 198 (define-cps-type $callk k proc args) ; First-order.
 199 (define-cps-type $primcall name args)
 200 (define-cps-type $values args)
 201 (define-cps-type $prompt escape? tag handler)
 202
 203 ;; The root of a higher-order CPS term is $cont containing a $kfun.  The
 204 ;; root of a first-order CPS term is a $program.
 205 (define-cps-type $program funs)
 206
 207 (define label-counter (make-parameter #f))
 208 (define var-counter (make-parameter #f))
 209
 210 (define (fresh-label)
 211   (let ((count (or (label-counter)
 212                    (error "fresh-label outside with-fresh-name-state"))))
 213     (label-counter (1+ count))
 214     count))
 215
 216 (define (fresh-var)
 217   (let ((count (or (var-counter)
 218                    (error "fresh-var outside with-fresh-name-state"))))
 219     (var-counter (1+ count))
 220     count))
 221
 222 (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
 223   (let ((label (fresh-label)) ...
 224         (var (fresh-var)) ...)
 225     body ...))
 226
 227 (define-syntax-rule (with-fresh-name-state fun body ...)
 228   (call-with-values (lambda () (compute-max-label-and-var fun))
 229     (lambda (max-label max-var)
 230       (parameterize ((label-counter (1+ max-label))
 231                      (var-counter (1+ max-var)))
 232         body ...))))
 233
 234 (define-syntax build-arity
 235   (syntax-rules (unquote)
 236     ((_ (unquote exp)) exp)
 237     ((_ (req opt rest kw allow-other-keys?))
 238      (make-$arity req opt rest kw allow-other-keys?))))
 239
 240 (define-syntax build-cont-body
 241   (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
 242     ((_ (unquote exp))
 243      exp)
 244     ((_ ($kreceive req rest kargs))
 245      (make-$kreceive (make-$arity req '() rest '() #f) kargs))
 246     ((_ ($kargs (name ...) (unquote syms) body))
 247      (make-$kargs (list name ...) syms (build-cps-term body)))
 248     ((_ ($kargs (name ...) (sym ...) body))
 249      (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
 250     ((_ ($kargs names syms body))
 251      (make-$kargs names syms (build-cps-term body)))
 252     ((_ ($kfun src meta self tail clause))
 253      (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
 254     ((_ ($ktail))
 255      (make-$ktail))
 256     ((_ ($kclause arity cont alternate))
 257      (make-$kclause (build-arity arity) (build-cps-cont cont)
 258                     (build-cps-cont alternate)))))
 259
 260 (define-syntax build-cps-cont
 261   (syntax-rules (unquote)
 262     ((_ (unquote exp)) exp)
 263     ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
 264
 265 (define-syntax build-cps-exp
 266   (syntax-rules (unquote
 267                  $void $const $prim $fun $closure $branch
 268                  $call $callk $primcall $values $prompt)
 269     ((_ (unquote exp)) exp)
 270     ((_ ($void)) (make-$void))
 271     ((_ ($const val)) (make-$const val))
 272     ((_ ($prim name)) (make-$prim name))
 273     ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
 274     ((_ ($closure k nfree)) (make-$closure k nfree))
 275     ((_ ($call proc (unquote args))) (make-$call proc args))
 276     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
 277     ((_ ($call proc args)) (make-$call proc args))
 278     ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
 279     ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
 280     ((_ ($callk k proc args)) (make-$callk k proc args))
 281     ((_ ($primcall name (unquote args))) (make-$primcall name args))
 282     ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
 283     ((_ ($primcall name args)) (make-$primcall name args))
 284     ((_ ($values (unquote args))) (make-$values args))
 285     ((_ ($values (arg ...))) (make-$values (list arg ...)))
 286     ((_ ($values args)) (make-$values args))
 287     ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
 288     ((_ ($prompt escape? tag handler))
 289      (make-$prompt escape? tag handler))))
 290
 291 (define-syntax build-cps-term
 292   (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
 293     ((_ (unquote exp))
 294      exp)
 295     ((_ ($letk (unquote conts) body))
 296      (make-$letk conts (build-cps-term body)))
 297     ((_ ($letk (cont ...) body))
 298      (make-$letk (list (build-cps-cont cont) ...)
 299                  (build-cps-term body)))
 300     ((_ ($letk* () body))
 301      (build-cps-term body))
 302     ((_ ($letk* (cont conts ...) body))
 303      (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
 304     ((_ ($letconst () body))
 305      (build-cps-term body))
 306     ((_ ($letconst ((name sym val) tail ...) body))
 307      (let-fresh (kconst) ()
 308        (build-cps-term
 309          ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
 310            ($continue kconst (let ((props (source-properties val)))
 311                                (and (pair? props) props))
 312              ($const val))))))
 313     ((_ ($letrec names gensyms funs body))
 314      (make-$letrec names gensyms funs (build-cps-term body)))
 315     ((_ ($program (unquote conts)))
 316      (make-$program conts))
 317     ((_ ($program (cont ...)))
 318      (make-$program (list (build-cps-cont cont) ...)))
 319     ((_ ($program conts))
 320      (make-$program conts))
 321     ((_ ($continue k src exp))
 322      (make-$continue k src (build-cps-exp exp)))))
 323
 324 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
 325   (match x
 326     (pat (build-cps-term body)) ...))
 327 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
 328   (match x
 329     (pat (build-cps-cont body)) ...))
 330 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
 331   (match x
 332     (pat (build-cps-exp body)) ...))
 333
 334 (define (parse-cps exp)
 335   (define (src exp)
 336     (let ((props (source-properties exp)))
 337       (and (pair? props) props)))
 338   (match exp
 339     ;; Continuations.
 340     (('letconst k (name sym c) body)
 341      (build-cps-term
 342        ($letk ((k ($kargs (name) (sym)
 343                     ,(parse-cps body))))
 344          ($continue k (src exp) ($const c)))))
 345     (('let k (name sym val) body)
 346      (build-cps-term
 347       ($letk ((k ($kargs (name) (sym)
 348                    ,(parse-cps body))))
 349         ,(parse-cps val))))
 350     (('letk (cont ...) body)
 351      (build-cps-term
 352        ($letk ,(map parse-cps cont) ,(parse-cps body))))
 353     (('k sym body)
 354      (build-cps-cont
 355        (sym ,(parse-cps body))))
 356     (('kreceive req rest k)
 357      (build-cont-body ($kreceive req rest k)))
 358     (('kargs names syms body)
 359      (build-cont-body ($kargs names syms ,(parse-cps body))))
 360     (('kfun src meta self tail clause)
 361      (build-cont-body
 362       ($kfun (src exp) meta self ,(parse-cps tail)
 363         ,(and=> clause parse-cps))))
 364     (('ktail)
 365      (build-cont-body
 366       ($ktail)))
 367     (('kclause (req opt rest kw allow-other-keys?) body)
 368      (build-cont-body
 369       ($kclause (req opt rest kw allow-other-keys?)
 370         ,(parse-cps body)
 371         ,#f)))
 372     (('kclause (req opt rest kw allow-other-keys?) body alternate)
 373      (build-cont-body
 374       ($kclause (req opt rest kw allow-other-keys?)
 375         ,(parse-cps body)
 376         ,(parse-cps alternate))))
 377     (('kseq body)
 378      (build-cont-body ($kargs () () ,(parse-cps body))))
 379
 380     ;; Calls.
 381     (('continue k exp)
 382      (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
 383     (('void)
 384      (build-cps-exp ($void)))
 385     (('const exp)
 386      (build-cps-exp ($const exp)))
 387     (('prim name)
 388      (build-cps-exp ($prim name)))
 389     (('fun free body)
 390      (build-cps-exp ($fun free ,(parse-cps body))))
 391     (('closure k nfree)
 392      (build-cps-exp ($closure k nfree)))
 393     (('letrec ((name sym fun) ...) body)
 394      (build-cps-term
 395        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
 396     (('program (cont ...))
 397      (build-cps-term ($program ,(map parse-cps cont))))
 398     (('call proc arg ...)
 399      (build-cps-exp ($call proc arg)))
 400     (('callk k proc arg ...)
 401      (build-cps-exp ($callk k proc arg)))
 402     (('primcall name arg ...)
 403      (build-cps-exp ($primcall name arg)))
 404     (('branch k exp)
 405      (build-cps-exp ($branch k ,(parse-cps exp))))
 406     (('values arg ...)
 407      (build-cps-exp ($values arg)))
 408     (('prompt escape? tag handler)
 409      (build-cps-exp ($prompt escape? tag handler)))
 410     (_
 411      (error "unexpected cps" exp))))
 412
 413 (define (unparse-cps exp)
 414   (match exp
 415     ;; Continuations.
 416     (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
 417         ($ $continue k src ($ $const c)))
 418      `(letconst ,k (,name ,sym ,c)
 419                 ,(unparse-cps body)))
 420     (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
 421      `(let ,k (,name ,sym ,(unparse-cps val))
 422            ,(unparse-cps body)))
 423     (($ $letk conts body)
 424      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
 425     (($ $cont sym body)
 426      `(k ,sym ,(unparse-cps body)))
 427     (($ $kreceive ($ $arity req () rest '() #f) k)
 428      `(kreceive ,req ,rest ,k))
 429     (($ $kargs () () body)
 430      `(kseq ,(unparse-cps body)))
 431     (($ $kargs names syms body)
 432      `(kargs ,names ,syms ,(unparse-cps body)))
 433     (($ $kfun src meta self tail clause)
 434      `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
 435     (($ $ktail)
 436      `(ktail))
 437     (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
 438      `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
 439                . ,(if alternate (list (unparse-cps alternate)) '())))
 440
 441     ;; Calls.
 442     (($ $continue k src exp)
 443      `(continue ,k ,(unparse-cps exp)))
 444     (($ $void)
 445      `(void))
 446     (($ $const val)
 447      `(const ,val))
 448     (($ $prim name)
 449      `(prim ,name))
 450     (($ $fun free body)
 451      `(fun ,free ,(unparse-cps body)))
 452     (($ $closure k nfree)
 453      `(closure ,k ,nfree))
 454     (($ $letrec names syms funs body)
 455      `(letrec ,(map (lambda (name sym fun)
 456                       (list name sym (unparse-cps fun)))
 457                     names syms funs)
 458         ,(unparse-cps body)))
 459     (($ $program conts)
 460      `(program ,(map unparse-cps conts)))
 461     (($ $call proc args)
 462      `(call ,proc ,@args))
 463     (($ $callk k proc args)
 464      `(callk ,k ,proc ,@args))
 465     (($ $primcall name args)
 466      `(primcall ,name ,@args))
 467     (($ $branch k exp)
 468      `(branch ,k ,(unparse-cps exp)))
 469     (($ $values args)
 470      `(values ,@args))
 471     (($ $prompt escape? tag handler)
 472      `(prompt ,escape? ,tag ,handler))
 473     (_
 474      (error "unexpected cps" exp))))
 475
 476 (define-syntax-rule (make-global-cont-folder seed ...)
 477   (lambda (proc cont seed ...)
 478     (define (cont-folder cont seed ...)
 479       (match cont
 480         (($ $cont k cont)
 481          (let-values (((seed ...) (proc k cont seed ...)))
 482            (match cont
 483              (($ $kargs names syms body)
 484               (term-folder body seed ...))
 485
 486              (($ $kfun src meta self tail clause)
 487               (let-values (((seed ...) (cont-folder tail seed ...)))
 488                 (if clause
 489                     (cont-folder clause seed ...)
 490                     (values seed ...))))
 491
 492              (($ $kclause arity body alternate)
 493               (let-values (((seed ...) (cont-folder body seed ...)))
 494                 (if alternate
 495                     (cont-folder alternate seed ...)
 496                     (values seed ...))))
 497
 498              (_ (values seed ...)))))))
 499
 500     (define (fun-folder fun seed ...)
 501       (match fun
 502         (($ $fun free body)
 503          (cont-folder body seed ...))))
 504
 505     (define (term-folder term seed ...)
 506       (match term
 507         (($ $letk conts body)
 508          (let-values (((seed ...) (term-folder body seed ...)))
 509            (let lp ((conts conts) (seed seed) ...)
 510              (if (null? conts)
 511                  (values seed ...)
 512                  (let-values (((seed ...) (cont-folder (car conts) seed ...)))
 513                    (lp (cdr conts) seed ...))))))
 514
 515         (($ $continue k src exp)
 516          (match exp
 517            (($ $fun) (fun-folder exp seed ...))
 518            (_ (values seed ...))))
 519
 520         (($ $letrec names syms funs body)
 521          (let-values (((seed ...) (term-folder body seed ...)))
 522            (let lp ((funs funs) (seed seed) ...)
 523              (if (null? funs)
 524                  (values seed ...)
 525                  (let-values (((seed ...) (fun-folder (car funs) seed ...)))
 526                    (lp (cdr funs) seed ...))))))))
 527
 528     (cont-folder cont seed ...)))
 529
 530 (define-syntax-rule (make-local-cont-folder seed ...)
 531   (lambda (proc cont seed ...)
 532     (define (cont-folder cont seed ...)
 533       (match cont
 534         (($ $cont k (and cont ($ $kargs names syms body)))
 535          (let-values (((seed ...) (proc k cont seed ...)))
 536            (term-folder body seed ...)))
 537         (($ $cont k cont)
 538          (proc k cont seed ...))))
 539     (define (term-folder term seed ...)
 540       (match term
 541         (($ $letk conts body)
 542          (let-values (((seed ...) (term-folder body seed ...)))
 543            (let lp ((conts conts) (seed seed) ...)
 544              (match conts
 545                (() (values seed ...))
 546                ((cont) (cont-folder cont seed ...))
 547                ((cont . conts)
 548                 (let-values (((seed ...) (cont-folder cont seed ...)))
 549                   (lp conts seed ...)))))))
 550         (($ $letrec names syms funs body) (term-folder body seed ...))
 551         (_ (values seed ...))))
 552     (define (clause-folder clause seed ...)
 553       (match clause
 554         (($ $cont k (and cont ($ $kclause arity body alternate)))
 555          (let-values (((seed ...) (proc k cont seed ...)))
 556            (if alternate
 557                (let-values (((seed ...) (cont-folder body seed ...)))
 558                  (clause-folder alternate seed ...))
 559                (cont-folder body seed ...))))))
 560     (match cont
 561       (($ $cont k (and cont ($ $kfun src meta self tail clause)))
 562        (let*-values (((seed ...) (proc k cont seed ...))
 563                      ((seed ...) (if clause
 564                                      (clause-folder clause seed ...)
 565                                      (values seed ...))))
 566          (cont-folder tail seed ...))))))
 567
 568 (define (compute-max-label-and-var fun)
 569   (match fun
 570     (($ $cont)
 571      ((make-global-cont-folder max-label max-var)
 572       (lambda (label cont max-label max-var)
 573         (values (max label max-label)
 574                 (match cont
 575                   (($ $kargs names vars body)
 576                    (let lp ((body body) (max-var (fold max max-var vars)))
 577                      (match body
 578                        (($ $letk conts body) (lp body max-var))
 579                        (($ $letrec names vars funs body)
 580                         (lp body (fold max max-var vars)))
 581                        (_ max-var))))
 582                   (($ $kfun src meta self)
 583                    (max self max-var))
 584                   (_ max-var))))
 585       fun -1 -1))
 586     (($ $program conts)
 587      (define (fold/2 proc in s0 s1)
 588       (if (null? in)
 589           (values s0 s1)
 590           (let-values (((s0 s1) (proc (car in) s0 s1)))
 591             (fold/2 proc (cdr in) s0 s1))))
 592      (let lp ((conts conts) (max-label -1) (max-var -1))
 593        (if (null? conts)
 594            (values max-label max-var)
 595            (call-with-values (lambda ()
 596                                ((make-local-cont-folder max-label max-var)
 597                                 (lambda (label cont max-label max-var)
 598                                   (values (max label max-label)
 599                                           (match cont
 600                                             (($ $kargs names vars body)
 601                                              (fold max max-var vars))
 602                                             (($ $kfun src meta self)
 603                                              (max self max-var))
 604                                             (_ max-var))))
 605                                 (car conts) max-label max-var))
 606              (lambda (max-label max-var)
 607                (lp (cdr conts) max-label max-var))))))))
 608
 609 (define (fold-conts proc seed fun)
 610   ((make-global-cont-folder seed) proc fun seed))
 611
 612 (define (fold-local-conts proc seed fun)
 613   ((make-local-cont-folder seed) proc fun seed))
 614
 615 (define (visit-cont-successors proc cont)
 616   (match cont
 617     (($ $kargs names syms body)
 618      (let lp ((body body))
 619        (match body
 620          (($ $letk conts body) (lp body))
 621          (($ $letrec names vars funs body) (lp body))
 622          (($ $continue k src exp)
 623           (match exp
 624             (($ $prompt escape? tag handler) (proc k handler))
 625             (($ $branch kt) (proc k kt))
 626             (_ (proc k)))))))
 627
 628     (($ $kreceive arity k) (proc k))
 629
 630     (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
 631
 632     (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
 633
 634     (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
 635
 636     (($ $kfun src meta self tail #f) (proc))
 637
 638     (($ $ktail) (proc))))