| 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 | ;;; $kif for test continuations, $kargs for continuations that bind |
| 31 | ;;; values, 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 | ;;; - $kentry 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 | ;;; - $kentry 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 src meta free |
| 75 | ;;; ($ $cont kentry |
| 76 | ;;; ($ $kentry 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. $kentry, $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 | ;;; $kif, 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 | $kif $kreceive $kargs $kentry $ktail $kclause |
| 123 | |
| 124 | ;; Expressions. |
| 125 | $void $const $prim $fun $call $callk $primcall $values $prompt |
| 126 | |
| 127 | ;; Fresh names. |
| 128 | label-counter var-counter |
| 129 | fresh-label fresh-var |
| 130 | with-fresh-name-state compute-max-label-and-var |
| 131 | let-fresh |
| 132 | |
| 133 | ;; Building macros. |
| 134 | build-cps-term build-cps-cont build-cps-exp |
| 135 | rewrite-cps-term rewrite-cps-cont rewrite-cps-exp |
| 136 | |
| 137 | ;; Misc. |
| 138 | parse-cps unparse-cps |
| 139 | make-cont-folder fold-conts fold-local-conts |
| 140 | visit-cont-successors)) |
| 141 | |
| 142 | ;; FIXME: Use SRFI-99, when Guile adds it. |
| 143 | (define-syntax define-record-type* |
| 144 | (lambda (x) |
| 145 | (define (id-append ctx . syms) |
| 146 | (datum->syntax ctx (apply symbol-append (map syntax->datum syms)))) |
| 147 | (syntax-case x () |
| 148 | ((_ name field ...) |
| 149 | (and (identifier? #'name) (and-map identifier? #'(field ...))) |
| 150 | (with-syntax ((cons (id-append #'name #'make- #'name)) |
| 151 | (pred (id-append #'name #'name #'?)) |
| 152 | ((getter ...) (map (lambda (f) |
| 153 | (id-append f #'name #'- f)) |
| 154 | #'(field ...)))) |
| 155 | #'(define-record-type name |
| 156 | (cons field ...) |
| 157 | pred |
| 158 | (field getter) |
| 159 | ...)))))) |
| 160 | |
| 161 | (define-syntax-rule (define-cps-type name field ...) |
| 162 | (begin |
| 163 | (define-record-type* name field ...) |
| 164 | (set-record-type-printer! name print-cps))) |
| 165 | |
| 166 | (define (print-cps exp port) |
| 167 | (format port "#<cps ~S>" (unparse-cps exp))) |
| 168 | |
| 169 | ;; Helper. |
| 170 | (define-record-type* $arity req opt rest kw allow-other-keys?) |
| 171 | |
| 172 | ;; Terms. |
| 173 | (define-cps-type $letk conts body) |
| 174 | (define-cps-type $continue k src exp) |
| 175 | (define-cps-type $letrec names syms funs body) |
| 176 | |
| 177 | ;; Continuations |
| 178 | (define-cps-type $cont k cont) |
| 179 | (define-cps-type $kif kt kf) |
| 180 | (define-cps-type $kreceive arity k) |
| 181 | (define-cps-type $kargs names syms body) |
| 182 | (define-cps-type $kentry self tail clause) |
| 183 | (define-cps-type $ktail) |
| 184 | (define-cps-type $kclause arity cont alternate) |
| 185 | |
| 186 | ;; Expressions. |
| 187 | (define-cps-type $void) |
| 188 | (define-cps-type $const val) |
| 189 | (define-cps-type $prim name) |
| 190 | (define-cps-type $fun src meta free body) |
| 191 | (define-cps-type $call proc args) |
| 192 | (define-cps-type $callk k proc args) |
| 193 | (define-cps-type $primcall name args) |
| 194 | (define-cps-type $values args) |
| 195 | (define-cps-type $prompt escape? tag handler) |
| 196 | |
| 197 | (define label-counter (make-parameter #f)) |
| 198 | (define var-counter (make-parameter #f)) |
| 199 | |
| 200 | (define (fresh-label) |
| 201 | (let ((count (or (label-counter) |
| 202 | (error "fresh-label outside with-fresh-name-state")))) |
| 203 | (label-counter (1+ count)) |
| 204 | count)) |
| 205 | |
| 206 | (define (fresh-var) |
| 207 | (let ((count (or (var-counter) |
| 208 | (error "fresh-var outside with-fresh-name-state")))) |
| 209 | (var-counter (1+ count)) |
| 210 | count)) |
| 211 | |
| 212 | (define-syntax-rule (let-fresh (label ...) (var ...) body ...) |
| 213 | (let ((label (fresh-label)) ... |
| 214 | (var (fresh-var)) ...) |
| 215 | body ...)) |
| 216 | |
| 217 | (define-syntax-rule (with-fresh-name-state fun body ...) |
| 218 | (begin |
| 219 | (when (or (label-counter) (var-counter)) |
| 220 | (error "with-fresh-name-state should not be called recursively")) |
| 221 | (call-with-values (lambda () |
| 222 | (compute-max-label-and-var fun)) |
| 223 | (lambda (max-label max-var) |
| 224 | (parameterize ((label-counter (1+ max-label)) |
| 225 | (var-counter (1+ max-var))) |
| 226 | body ...))))) |
| 227 | |
| 228 | (define-syntax build-arity |
| 229 | (syntax-rules (unquote) |
| 230 | ((_ (unquote exp)) exp) |
| 231 | ((_ (req opt rest kw allow-other-keys?)) |
| 232 | (make-$arity req opt rest kw allow-other-keys?)))) |
| 233 | |
| 234 | (define-syntax build-cont-body |
| 235 | (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause) |
| 236 | ((_ (unquote exp)) |
| 237 | exp) |
| 238 | ((_ ($kif kt kf)) |
| 239 | (make-$kif kt kf)) |
| 240 | ((_ ($kreceive req rest kargs)) |
| 241 | (make-$kreceive (make-$arity req '() rest '() #f) kargs)) |
| 242 | ((_ ($kargs (name ...) (sym ...) body)) |
| 243 | (make-$kargs (list name ...) (list sym ...) (build-cps-term body))) |
| 244 | ((_ ($kargs names syms body)) |
| 245 | (make-$kargs names syms (build-cps-term body))) |
| 246 | ((_ ($kentry self tail clause)) |
| 247 | (make-$kentry self (build-cps-cont tail) (build-cps-cont clause))) |
| 248 | ((_ ($ktail)) |
| 249 | (make-$ktail)) |
| 250 | ((_ ($kclause arity cont alternate)) |
| 251 | (make-$kclause (build-arity arity) (build-cps-cont cont) |
| 252 | (build-cps-cont alternate))))) |
| 253 | |
| 254 | (define-syntax build-cps-cont |
| 255 | (syntax-rules (unquote) |
| 256 | ((_ (unquote exp)) exp) |
| 257 | ((_ (k cont)) (make-$cont k (build-cont-body cont))))) |
| 258 | |
| 259 | (define-syntax build-cps-exp |
| 260 | (syntax-rules (unquote |
| 261 | $void $const $prim $fun $call $callk $primcall $values $prompt) |
| 262 | ((_ (unquote exp)) exp) |
| 263 | ((_ ($void)) (make-$void)) |
| 264 | ((_ ($const val)) (make-$const val)) |
| 265 | ((_ ($prim name)) (make-$prim name)) |
| 266 | ((_ ($fun src meta free body)) |
| 267 | (make-$fun src meta free (build-cps-cont body))) |
| 268 | ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) |
| 269 | ((_ ($call proc args)) (make-$call proc args)) |
| 270 | ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) |
| 271 | ((_ ($callk k proc args)) (make-$callk k proc args)) |
| 272 | ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) |
| 273 | ((_ ($primcall name args)) (make-$primcall name args)) |
| 274 | ((_ ($values (arg ...))) (make-$values (list arg ...))) |
| 275 | ((_ ($values args)) (make-$values args)) |
| 276 | ((_ ($prompt escape? tag handler)) |
| 277 | (make-$prompt escape? tag handler)))) |
| 278 | |
| 279 | (define-syntax build-cps-term |
| 280 | (syntax-rules (unquote $letk $letk* $letconst $letrec $continue) |
| 281 | ((_ (unquote exp)) |
| 282 | exp) |
| 283 | ((_ ($letk (unquote conts) body)) |
| 284 | (make-$letk conts (build-cps-term body))) |
| 285 | ((_ ($letk (cont ...) body)) |
| 286 | (make-$letk (list (build-cps-cont cont) ...) |
| 287 | (build-cps-term body))) |
| 288 | ((_ ($letk* () body)) |
| 289 | (build-cps-term body)) |
| 290 | ((_ ($letk* (cont conts ...) body)) |
| 291 | (build-cps-term ($letk (cont) ($letk* (conts ...) body)))) |
| 292 | ((_ ($letconst () body)) |
| 293 | (build-cps-term body)) |
| 294 | ((_ ($letconst ((name sym val) tail ...) body)) |
| 295 | (let-fresh (kconst) () |
| 296 | (build-cps-term |
| 297 | ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body)))) |
| 298 | ($continue kconst (let ((props (source-properties val))) |
| 299 | (and (pair? props) props)) |
| 300 | ($const val)))))) |
| 301 | ((_ ($letrec names gensyms funs body)) |
| 302 | (make-$letrec names gensyms funs (build-cps-term body))) |
| 303 | ((_ ($continue k src exp)) |
| 304 | (make-$continue k src (build-cps-exp exp))))) |
| 305 | |
| 306 | (define-syntax-rule (rewrite-cps-term x (pat body) ...) |
| 307 | (match x |
| 308 | (pat (build-cps-term body)) ...)) |
| 309 | (define-syntax-rule (rewrite-cps-cont x (pat body) ...) |
| 310 | (match x |
| 311 | (pat (build-cps-cont body)) ...)) |
| 312 | (define-syntax-rule (rewrite-cps-exp x (pat body) ...) |
| 313 | (match x |
| 314 | (pat (build-cps-exp body)) ...)) |
| 315 | |
| 316 | (define (parse-cps exp) |
| 317 | (define (src exp) |
| 318 | (let ((props (source-properties exp))) |
| 319 | (and (pair? props) props))) |
| 320 | (match exp |
| 321 | ;; Continuations. |
| 322 | (('letconst k (name sym c) body) |
| 323 | (build-cps-term |
| 324 | ($letk ((k ($kargs (name) (sym) |
| 325 | ,(parse-cps body)))) |
| 326 | ($continue k (src exp) ($const c))))) |
| 327 | (('let k (name sym val) body) |
| 328 | (build-cps-term |
| 329 | ($letk ((k ($kargs (name) (sym) |
| 330 | ,(parse-cps body)))) |
| 331 | ,(parse-cps val)))) |
| 332 | (('letk (cont ...) body) |
| 333 | (build-cps-term |
| 334 | ($letk ,(map parse-cps cont) ,(parse-cps body)))) |
| 335 | (('k sym body) |
| 336 | (build-cps-cont |
| 337 | (sym ,(parse-cps body)))) |
| 338 | (('kif kt kf) |
| 339 | (build-cont-body ($kif kt kf))) |
| 340 | (('kreceive req rest k) |
| 341 | (build-cont-body ($kreceive req rest k))) |
| 342 | (('kargs names syms body) |
| 343 | (build-cont-body ($kargs names syms ,(parse-cps body)))) |
| 344 | (('kentry self tail clause) |
| 345 | (build-cont-body |
| 346 | ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps)))) |
| 347 | (('ktail) |
| 348 | (build-cont-body |
| 349 | ($ktail))) |
| 350 | (('kclause (req opt rest kw allow-other-keys?) body) |
| 351 | (build-cont-body |
| 352 | ($kclause (req opt rest kw allow-other-keys?) |
| 353 | ,(parse-cps body) |
| 354 | ,#f))) |
| 355 | (('kclause (req opt rest kw allow-other-keys?) body alternate) |
| 356 | (build-cont-body |
| 357 | ($kclause (req opt rest kw allow-other-keys?) |
| 358 | ,(parse-cps body) |
| 359 | ,(parse-cps alternate)))) |
| 360 | (('kseq body) |
| 361 | (build-cont-body ($kargs () () ,(parse-cps body)))) |
| 362 | |
| 363 | ;; Calls. |
| 364 | (('continue k exp) |
| 365 | (build-cps-term ($continue k (src exp) ,(parse-cps exp)))) |
| 366 | (('void) |
| 367 | (build-cps-exp ($void))) |
| 368 | (('const exp) |
| 369 | (build-cps-exp ($const exp))) |
| 370 | (('prim name) |
| 371 | (build-cps-exp ($prim name))) |
| 372 | (('fun meta free body) |
| 373 | (build-cps-exp ($fun (src exp) meta free ,(parse-cps body)))) |
| 374 | (('letrec ((name sym fun) ...) body) |
| 375 | (build-cps-term |
| 376 | ($letrec name sym (map parse-cps fun) ,(parse-cps body)))) |
| 377 | (('call proc arg ...) |
| 378 | (build-cps-exp ($call proc arg))) |
| 379 | (('callk k proc arg ...) |
| 380 | (build-cps-exp ($callk k proc arg))) |
| 381 | (('primcall name arg ...) |
| 382 | (build-cps-exp ($primcall name arg))) |
| 383 | (('values arg ...) |
| 384 | (build-cps-exp ($values arg))) |
| 385 | (('prompt escape? tag handler) |
| 386 | (build-cps-exp ($prompt escape? tag handler))) |
| 387 | (_ |
| 388 | (error "unexpected cps" exp)))) |
| 389 | |
| 390 | (define (unparse-cps exp) |
| 391 | (match exp |
| 392 | ;; Continuations. |
| 393 | (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) |
| 394 | ($ $continue k src ($ $const c))) |
| 395 | `(letconst ,k (,name ,sym ,c) |
| 396 | ,(unparse-cps body))) |
| 397 | (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val) |
| 398 | `(let ,k (,name ,sym ,(unparse-cps val)) |
| 399 | ,(unparse-cps body))) |
| 400 | (($ $letk conts body) |
| 401 | `(letk ,(map unparse-cps conts) ,(unparse-cps body))) |
| 402 | (($ $cont sym body) |
| 403 | `(k ,sym ,(unparse-cps body))) |
| 404 | (($ $kif kt kf) |
| 405 | `(kif ,kt ,kf)) |
| 406 | (($ $kreceive ($ $arity req () rest '() #f) k) |
| 407 | `(kreceive ,req ,rest ,k)) |
| 408 | (($ $kargs () () body) |
| 409 | `(kseq ,(unparse-cps body))) |
| 410 | (($ $kargs names syms body) |
| 411 | `(kargs ,names ,syms ,(unparse-cps body))) |
| 412 | (($ $kentry self tail clause) |
| 413 | `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause))) |
| 414 | (($ $ktail) |
| 415 | `(ktail)) |
| 416 | (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate) |
| 417 | `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body) |
| 418 | . ,(if alternate (list (unparse-cps alternate)) '()))) |
| 419 | |
| 420 | ;; Calls. |
| 421 | (($ $continue k src exp) |
| 422 | `(continue ,k ,(unparse-cps exp))) |
| 423 | (($ $void) |
| 424 | `(void)) |
| 425 | (($ $const val) |
| 426 | `(const ,val)) |
| 427 | (($ $prim name) |
| 428 | `(prim ,name)) |
| 429 | (($ $fun src meta free body) |
| 430 | `(fun ,meta ,free ,(unparse-cps body))) |
| 431 | (($ $letrec names syms funs body) |
| 432 | `(letrec ,(map (lambda (name sym fun) |
| 433 | (list name sym (unparse-cps fun))) |
| 434 | names syms funs) |
| 435 | ,(unparse-cps body))) |
| 436 | (($ $call proc args) |
| 437 | `(call ,proc ,@args)) |
| 438 | (($ $callk k proc args) |
| 439 | `(callk ,k ,proc ,@args)) |
| 440 | (($ $primcall name args) |
| 441 | `(primcall ,name ,@args)) |
| 442 | (($ $values args) |
| 443 | `(values ,@args)) |
| 444 | (($ $prompt escape? tag handler) |
| 445 | `(prompt ,escape? ,tag ,handler)) |
| 446 | (_ |
| 447 | (error "unexpected cps" exp)))) |
| 448 | |
| 449 | (define-syntax-rule (make-cont-folder global? seed ...) |
| 450 | (lambda (proc fun seed ...) |
| 451 | (define (fold-values proc in seed ...) |
| 452 | (if (null? in) |
| 453 | (values seed ...) |
| 454 | (let-values (((seed ...) (proc (car in) seed ...))) |
| 455 | (fold-values proc (cdr in) seed ...)))) |
| 456 | |
| 457 | (define (cont-folder cont seed ...) |
| 458 | (match cont |
| 459 | (($ $cont k cont) |
| 460 | (let-values (((seed ...) (proc k cont seed ...))) |
| 461 | (match cont |
| 462 | (($ $kargs names syms body) |
| 463 | (term-folder body seed ...)) |
| 464 | |
| 465 | (($ $kentry self tail clause) |
| 466 | (let-values (((seed ...) (cont-folder tail seed ...))) |
| 467 | (if clause |
| 468 | (cont-folder clause seed ...) |
| 469 | (values seed ...)))) |
| 470 | |
| 471 | (($ $kclause arity body alternate) |
| 472 | (let-values (((seed ...) (cont-folder body seed ...))) |
| 473 | (if alternate |
| 474 | (cont-folder alternate seed ...) |
| 475 | (values seed ...)))) |
| 476 | |
| 477 | (_ (values seed ...))))))) |
| 478 | |
| 479 | (define (fun-folder fun seed ...) |
| 480 | (match fun |
| 481 | (($ $fun src meta free body) |
| 482 | (cont-folder body seed ...)))) |
| 483 | |
| 484 | (define (term-folder term seed ...) |
| 485 | (match term |
| 486 | (($ $letk conts body) |
| 487 | (let-values (((seed ...) (term-folder body seed ...))) |
| 488 | (fold-values cont-folder conts seed ...))) |
| 489 | |
| 490 | (($ $continue k src exp) |
| 491 | (match exp |
| 492 | (($ $fun) |
| 493 | (if global? |
| 494 | (fun-folder exp seed ...) |
| 495 | (values seed ...))) |
| 496 | (_ (values seed ...)))) |
| 497 | |
| 498 | (($ $letrec names syms funs body) |
| 499 | (let-values (((seed ...) (term-folder body seed ...))) |
| 500 | (if global? |
| 501 | (fold-values fun-folder funs seed ...) |
| 502 | (values seed ...)))))) |
| 503 | |
| 504 | (fun-folder fun seed ...))) |
| 505 | |
| 506 | (define (compute-max-label-and-var fun) |
| 507 | ((make-cont-folder #t max-label max-var) |
| 508 | (lambda (label cont max-label max-var) |
| 509 | (values (max label max-label) |
| 510 | (match cont |
| 511 | (($ $kargs names vars) |
| 512 | (fold max max-var vars)) |
| 513 | (($ $kentry self) |
| 514 | (max self max-var)) |
| 515 | (_ max-var)))) |
| 516 | fun |
| 517 | -1 |
| 518 | -1)) |
| 519 | |
| 520 | (define (fold-conts proc seed fun) |
| 521 | ((make-cont-folder #t seed) proc fun seed)) |
| 522 | |
| 523 | (define (fold-local-conts proc seed fun) |
| 524 | ((make-cont-folder #f seed) proc fun seed)) |
| 525 | |
| 526 | (define (visit-cont-successors proc cont) |
| 527 | (match cont |
| 528 | (($ $kargs names syms body) |
| 529 | (let lp ((body body)) |
| 530 | (match body |
| 531 | (($ $letk conts body) (lp body)) |
| 532 | (($ $letrec names vars funs body) (lp body)) |
| 533 | (($ $continue k src exp) |
| 534 | (match exp |
| 535 | (($ $prompt escape? tag handler) (proc k handler)) |
| 536 | (_ (proc k))))))) |
| 537 | |
| 538 | (($ $kif kt kf) (proc kt kf)) |
| 539 | |
| 540 | (($ $kreceive arity k) (proc k)) |
| 541 | |
| 542 | (($ $kclause arity ($ $cont kbody) #f) (proc kbody)) |
| 543 | |
| 544 | (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt)) |
| 545 | |
| 546 | (($ $kentry self tail ($ $cont clause)) (proc clause)) |
| 547 | |
| 548 | (($ $kentry self tail #f) (proc)) |
| 549 | |
| 550 | (($ $ktail) (proc)))) |