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 ;;; $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   (call-with-values (lambda ()
 219                       (compute-max-label-and-var fun))
 220     (lambda (max-label max-var)
 221       (parameterize ((label-counter (1+ max-label))
 222                      (var-counter (1+ max-var)))
 223         body ...))))
 224
 225 (define-syntax build-arity
 226   (syntax-rules (unquote)
 227     ((_ (unquote exp)) exp)
 228     ((_ (req opt rest kw allow-other-keys?))
 229      (make-$arity req opt rest kw allow-other-keys?))))
 230
 231 (define-syntax build-cont-body
 232   (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
 233     ((_ (unquote exp))
 234      exp)
 235     ((_ ($kif kt kf))
 236      (make-$kif kt kf))
 237     ((_ ($kreceive req rest kargs))
 238      (make-$kreceive (make-$arity req '() rest '() #f) kargs))
 239     ((_ ($kargs (name ...) (sym ...) body))
 240      (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
 241     ((_ ($kargs names syms body))
 242      (make-$kargs names syms (build-cps-term body)))
 243     ((_ ($kentry self tail clause))
 244      (make-$kentry self (build-cps-cont tail) (build-cps-cont clause)))
 245     ((_ ($ktail))
 246      (make-$ktail))
 247     ((_ ($kclause arity cont alternate))
 248      (make-$kclause (build-arity arity) (build-cps-cont cont)
 249                     (build-cps-cont alternate)))))
 250
 251 (define-syntax build-cps-cont
 252   (syntax-rules (unquote)
 253     ((_ (unquote exp)) exp)
 254     ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
 255
 256 (define-syntax build-cps-exp
 257   (syntax-rules (unquote
 258                  $void $const $prim $fun $call $callk $primcall $values $prompt)
 259     ((_ (unquote exp)) exp)
 260     ((_ ($void)) (make-$void))
 261     ((_ ($const val)) (make-$const val))
 262     ((_ ($prim name)) (make-$prim name))
 263     ((_ ($fun src meta free body))
 264      (make-$fun src meta free (build-cps-cont body)))
 265     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
 266     ((_ ($call proc args)) (make-$call proc args))
 267     ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
 268     ((_ ($callk k proc args)) (make-$callk k proc args))
 269     ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
 270     ((_ ($primcall name args)) (make-$primcall name args))
 271     ((_ ($values (arg ...))) (make-$values (list arg ...)))
 272     ((_ ($values args)) (make-$values args))
 273     ((_ ($prompt escape? tag handler))
 274      (make-$prompt escape? tag handler))))
 275
 276 (define-syntax build-cps-term
 277   (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
 278     ((_ (unquote exp))
 279      exp)
 280     ((_ ($letk (unquote conts) body))
 281      (make-$letk conts (build-cps-term body)))
 282     ((_ ($letk (cont ...) body))
 283      (make-$letk (list (build-cps-cont cont) ...)
 284                  (build-cps-term body)))
 285     ((_ ($letk* () body))
 286      (build-cps-term body))
 287     ((_ ($letk* (cont conts ...) body))
 288      (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
 289     ((_ ($letconst () body))
 290      (build-cps-term body))
 291     ((_ ($letconst ((name sym val) tail ...) body))
 292      (let-fresh (kconst) ()
 293        (build-cps-term
 294          ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
 295            ($continue kconst (let ((props (source-properties val)))
 296                                (and (pair? props) props))
 297              ($const val))))))
 298     ((_ ($letrec names gensyms funs body))
 299      (make-$letrec names gensyms funs (build-cps-term body)))
 300     ((_ ($continue k src exp))
 301      (make-$continue k src (build-cps-exp exp)))))
 302
 303 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
 304   (match x
 305     (pat (build-cps-term body)) ...))
 306 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
 307   (match x
 308     (pat (build-cps-cont body)) ...))
 309 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
 310   (match x
 311     (pat (build-cps-exp body)) ...))
 312
 313 (define (parse-cps exp)
 314   (define (src exp)
 315     (let ((props (source-properties exp)))
 316       (and (pair? props) props)))
 317   (match exp
 318     ;; Continuations.
 319     (('letconst k (name sym c) body)
 320      (build-cps-term
 321        ($letk ((k ($kargs (name) (sym)
 322                     ,(parse-cps body))))
 323          ($continue k (src exp) ($const c)))))
 324     (('let k (name sym val) body)
 325      (build-cps-term
 326       ($letk ((k ($kargs (name) (sym)
 327                    ,(parse-cps body))))
 328         ,(parse-cps val))))
 329     (('letk (cont ...) body)
 330      (build-cps-term
 331        ($letk ,(map parse-cps cont) ,(parse-cps body))))
 332     (('k sym body)
 333      (build-cps-cont
 334        (sym ,(parse-cps body))))
 335     (('kif kt kf)
 336      (build-cont-body ($kif kt kf)))
 337     (('kreceive req rest k)
 338      (build-cont-body ($kreceive req rest k)))
 339     (('kargs names syms body)
 340      (build-cont-body ($kargs names syms ,(parse-cps body))))
 341     (('kentry self tail clause)
 342      (build-cont-body
 343       ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps))))
 344     (('ktail)
 345      (build-cont-body
 346       ($ktail)))
 347     (('kclause (req opt rest kw allow-other-keys?) body)
 348      (build-cont-body
 349       ($kclause (req opt rest kw allow-other-keys?)
 350         ,(parse-cps body)
 351         ,#f)))
 352     (('kclause (req opt rest kw allow-other-keys?) body alternate)
 353      (build-cont-body
 354       ($kclause (req opt rest kw allow-other-keys?)
 355         ,(parse-cps body)
 356         ,(parse-cps alternate))))
 357     (('kseq body)
 358      (build-cont-body ($kargs () () ,(parse-cps body))))
 359
 360     ;; Calls.
 361     (('continue k exp)
 362      (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
 363     (('void)
 364      (build-cps-exp ($void)))
 365     (('const exp)
 366      (build-cps-exp ($const exp)))
 367     (('prim name)
 368      (build-cps-exp ($prim name)))
 369     (('fun meta free body)
 370      (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
 371     (('letrec ((name sym fun) ...) body)
 372      (build-cps-term
 373        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
 374     (('call proc arg ...)
 375      (build-cps-exp ($call proc arg)))
 376     (('callk k proc arg ...)
 377      (build-cps-exp ($callk k proc arg)))
 378     (('primcall name arg ...)
 379      (build-cps-exp ($primcall name arg)))
 380     (('values arg ...)
 381      (build-cps-exp ($values arg)))
 382     (('prompt escape? tag handler)
 383      (build-cps-exp ($prompt escape? tag handler)))
 384     (_
 385      (error "unexpected cps" exp))))
 386
 387 (define (unparse-cps exp)
 388   (match exp
 389     ;; Continuations.
 390     (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
 391         ($ $continue k src ($ $const c)))
 392      `(letconst ,k (,name ,sym ,c)
 393                 ,(unparse-cps body)))
 394     (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
 395      `(let ,k (,name ,sym ,(unparse-cps val))
 396            ,(unparse-cps body)))
 397     (($ $letk conts body)
 398      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
 399     (($ $cont sym body)
 400      `(k ,sym ,(unparse-cps body)))
 401     (($ $kif kt kf)
 402      `(kif ,kt ,kf))
 403     (($ $kreceive ($ $arity req () rest '() #f) k)
 404      `(kreceive ,req ,rest ,k))
 405     (($ $kargs () () body)
 406      `(kseq ,(unparse-cps body)))
 407     (($ $kargs names syms body)
 408      `(kargs ,names ,syms ,(unparse-cps body)))
 409     (($ $kentry self tail clause)
 410      `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause)))
 411     (($ $ktail)
 412      `(ktail))
 413     (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
 414      `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
 415                . ,(if alternate (list (unparse-cps alternate)) '())))
 416
 417     ;; Calls.
 418     (($ $continue k src exp)
 419      `(continue ,k ,(unparse-cps exp)))
 420     (($ $void)
 421      `(void))
 422     (($ $const val)
 423      `(const ,val))
 424     (($ $prim name)
 425      `(prim ,name))
 426     (($ $fun src meta free body)
 427      `(fun ,meta ,free ,(unparse-cps body)))
 428     (($ $letrec names syms funs body)
 429      `(letrec ,(map (lambda (name sym fun)
 430                       (list name sym (unparse-cps fun)))
 431                     names syms funs)
 432         ,(unparse-cps body)))
 433     (($ $call proc args)
 434      `(call ,proc ,@args))
 435     (($ $callk k proc args)
 436      `(callk ,k ,proc ,@args))
 437     (($ $primcall name args)
 438      `(primcall ,name ,@args))
 439     (($ $values args)
 440      `(values ,@args))
 441     (($ $prompt escape? tag handler)
 442      `(prompt ,escape? ,tag ,handler))
 443     (_
 444      (error "unexpected cps" exp))))
 445
 446 (define-syntax-rule (make-cont-folder global? seed ...)
 447   (lambda (proc fun seed ...)
 448     (define (fold-values proc in seed ...)
 449       (if (null? in)
 450           (values seed ...)
 451           (let-values (((seed ...) (proc (car in) seed ...)))
 452             (fold-values proc (cdr in) seed ...))))
 453
 454     (define (cont-folder cont seed ...)
 455       (match cont
 456         (($ $cont k cont)
 457          (let-values (((seed ...) (proc k cont seed ...)))
 458            (match cont
 459              (($ $kargs names syms body)
 460               (term-folder body seed ...))
 461
 462              (($ $kentry self tail clause)
 463               (let-values (((seed ...) (cont-folder tail seed ...)))
 464                 (if clause
 465                     (cont-folder clause seed ...)
 466                     (values seed ...))))
 467
 468              (($ $kclause arity body alternate)
 469               (let-values (((seed ...) (cont-folder body seed ...)))
 470                 (if alternate
 471                     (cont-folder alternate seed ...)
 472                     (values seed ...))))
 473
 474              (_ (values seed ...)))))))
 475
 476     (define (fun-folder fun seed ...)
 477       (match fun
 478         (($ $fun src meta free body)
 479          (cont-folder body seed ...))))
 480
 481     (define (term-folder term seed ...)
 482       (match term
 483         (($ $letk conts body)
 484          (let-values (((seed ...) (term-folder body seed ...)))
 485            (fold-values cont-folder conts seed ...)))
 486
 487         (($ $continue k src exp)
 488          (match exp
 489            (($ $fun)
 490             (if global?
 491                 (fun-folder exp seed ...)
 492                 (values seed ...)))
 493            (_ (values seed ...))))
 494
 495         (($ $letrec names syms funs body)
 496          (let-values (((seed ...) (term-folder body seed ...)))
 497            (if global?
 498                (fold-values fun-folder funs seed ...)
 499                (values seed ...))))))
 500
 501     (fun-folder fun seed ...)))
 502
 503 (define (compute-max-label-and-var fun)
 504   ((make-cont-folder #t max-label max-var)
 505    (lambda (label cont max-label max-var)
 506      (values (max label max-label)
 507              (match cont
 508                (($ $kargs names vars body)
 509                 (let lp ((body body) (max-var (fold max max-var vars)))
 510                   (match body
 511                     (($ $letk conts body) (lp body max-var))
 512                     (($ $letrec names vars funs body)
 513                      (lp body (fold max max-var vars)))
 514                     (_ max-var))))
 515                (($ $kentry self)
 516                 (max self max-var))
 517                (_ max-var))))
 518    fun
 519    -1
 520    -1))
 521
 522 (define (fold-conts proc seed fun)
 523   ((make-cont-folder #t seed) proc fun seed))
 524
 525 (define (fold-local-conts proc seed fun)
 526   ((make-cont-folder #f seed) proc fun seed))
 527
 528 (define (visit-cont-successors proc cont)
 529   (match cont
 530     (($ $kargs names syms body)
 531      (let lp ((body body))
 532        (match body
 533          (($ $letk conts body) (lp body))
 534          (($ $letrec names vars funs body) (lp body))
 535          (($ $continue k src exp)
 536           (match exp
 537             (($ $prompt escape? tag handler) (proc k handler))
 538             (_ (proc k)))))))
 539
 540     (($ $kif kt kf) (proc kt kf))
 541
 542     (($ $kreceive arity k) (proc k))
 543
 544     (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
 545
 546     (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
 547
 548     (($ $kentry self tail ($ $cont clause)) (proc clause))
 549
 550     (($ $kentry self tail #f) (proc))
 551
 552     (($ $ktail) (proc))))