module/language/cps.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 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 and source of a
  29 ;;; continuation, and then contains as a subterm the particular
  30 ;;; continuation instance: $kif for test continuations, $kargs for
  31 ;;; continuations that bind 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.
  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 ;;;   - $ktrunc 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 contains $kclause continuations, corresponding to
  65 ;;;     the case-lambda clauses of the function.  $kclause actually
  66 ;;;     contains the clause body.  This is because the $kclause
  67 ;;;     logically matches or doesn't match a given set of actual
  68 ;;;     arguments against a formal arity, then proceeds to a "body"
  69 ;;;     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 meta free
  75 ;;;           ($ $cont kentry src
  76 ;;;              ($ $kentry self ($ $cont ktail _ ($ $ktail))
  77 ;;;                 (($ $kclause arity
  78 ;;;                     ($ $cont kbody _ ($ $kargs names syms body)))
  79 ;;;                  ...))))
  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   #:export (;; Helper.
 111             $arity
 112             make-$arity
 113
 114             ;; Terms.
 115             $letk $continue $letrec
 116
 117             ;; Continuations.
 118             $cont
 119
 120             ;; Continuation bodies.
 121             $kif $ktrunc $kargs $kentry $ktail $kclause
 122
 123             ;; Expressions.
 124             $var $void $const $prim $fun $call $primcall $values $prompt
 125
 126             ;; Building macros.
 127             let-gensyms
 128             build-cps-term build-cps-cont build-cps-exp
 129             rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
 130
 131             ;; Misc.
 132             parse-cps unparse-cps
 133             fold-conts fold-local-conts))
 134
 135 ;; FIXME: Use SRFI-99, when Guile adds it.
 136 (define-syntax define-record-type*
 137   (lambda (x)
 138     (define (id-append ctx . syms)
 139       (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
 140     (syntax-case x ()
 141       ((_ name field ...)
 142        (and (identifier? #'name) (and-map identifier? #'(field ...)))
 143        (with-syntax ((cons (id-append #'name #'make- #'name))
 144                      (pred (id-append #'name #'name #'?))
 145                      ((getter ...) (map (lambda (f)
 146                                           (id-append f #'name #'- f))
 147                                         #'(field ...))))
 148          #'(define-record-type name
 149              (cons field ...)
 150              pred
 151              (field getter)
 152              ...))))))
 153
 154 (define-syntax-rule (define-cps-type name field ...)
 155   (begin
 156     (define-record-type* name field ...)
 157     (set-record-type-printer! name print-cps)))
 158
 159 (define (print-cps exp port)
 160   (format port "#<cps ~S>" (unparse-cps exp)))
 161
 162 ;; Helper.
 163 (define-record-type* $arity req opt rest kw allow-other-keys?)
 164
 165 ;; Terms.
 166 (define-cps-type $letk conts body)
 167 (define-cps-type $continue k exp)
 168 (define-cps-type $letrec names syms funs body)
 169
 170 ;; Continuations
 171 (define-cps-type $cont k src cont)
 172 (define-cps-type $kif kt kf)
 173 (define-cps-type $ktrunc arity k)
 174 (define-cps-type $kargs names syms body)
 175 (define-cps-type $kentry self tail clauses)
 176 (define-cps-type $ktail)
 177 (define-cps-type $kclause arity cont)
 178
 179 ;; Expressions.
 180 (define-cps-type $var sym)
 181 (define-cps-type $void)
 182 (define-cps-type $const val)
 183 (define-cps-type $prim name)
 184 (define-cps-type $fun meta free body)
 185 (define-cps-type $call proc args)
 186 (define-cps-type $primcall name args)
 187 (define-cps-type $values args)
 188 (define-cps-type $prompt escape? tag handler)
 189
 190 (define-syntax let-gensyms
 191   (syntax-rules ()
 192     ((_ (sym ...) body body* ...)
 193      (let ((sym (gensym (symbol->string 'sym))) ...)
 194        body body* ...))))
 195
 196 (define-syntax build-arity
 197   (syntax-rules (unquote)
 198     ((_ (unquote exp)) exp)
 199     ((_ (req opt rest kw allow-other-keys?))
 200      (make-$arity req opt rest kw allow-other-keys?))))
 201
 202 (define-syntax build-cont-body
 203   (syntax-rules (unquote $kif $ktrunc $kargs $kentry $ktail $kclause)
 204     ((_ (unquote exp))
 205      exp)
 206     ((_ ($kif kt kf))
 207      (make-$kif kt kf))
 208     ((_ ($ktrunc req rest kargs))
 209      (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
 210     ((_ ($kargs (name ...) (sym ...) body))
 211      (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
 212     ((_ ($kargs names syms body))
 213      (make-$kargs names syms (build-cps-term body)))
 214     ((_ ($kentry self tail (unquote clauses)))
 215      (make-$kentry self (build-cps-cont tail) clauses))
 216     ((_ ($kentry self tail (clause ...)))
 217      (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause) ...)))
 218     ((_ ($ktail))
 219      (make-$ktail))
 220     ((_ ($kclause arity cont))
 221      (make-$kclause (build-arity arity) (build-cps-cont cont)))))
 222
 223 (define-syntax build-cps-cont
 224   (syntax-rules (unquote)
 225     ((_ (unquote exp)) exp)
 226     ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
 227
 228 (define-syntax build-cps-exp
 229   (syntax-rules (unquote
 230                  $var $void $const $prim $fun $call $primcall $values $prompt)
 231     ((_ (unquote exp)) exp)
 232     ((_ ($var sym)) (make-$var sym))
 233     ((_ ($void)) (make-$void))
 234     ((_ ($const val)) (make-$const val))
 235     ((_ ($prim name)) (make-$prim name))
 236     ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
 237     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
 238     ((_ ($call proc args)) (make-$call proc args))
 239     ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
 240     ((_ ($primcall name args)) (make-$primcall name args))
 241     ((_ ($values (arg ...))) (make-$values (list arg ...)))
 242     ((_ ($values args)) (make-$values args))
 243     ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
 244
 245 (define-syntax build-cps-term
 246   (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
 247     ((_ (unquote exp))
 248      exp)
 249     ((_ ($letk (unquote conts) body))
 250      (make-$letk conts (build-cps-term body)))
 251     ((_ ($letk (cont ...) body))
 252      (make-$letk (list (build-cps-cont cont) ...)
 253                  (build-cps-term body)))
 254     ((_ ($letk* () body))
 255      (build-cps-term body))
 256     ((_ ($letk* (cont conts ...) body))
 257      (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
 258     ((_ ($letconst () body))
 259      (build-cps-term body))
 260     ((_ ($letconst ((name sym val) tail ...) body))
 261      (let-gensyms (kconst)
 262        (build-cps-term
 263          ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
 264            ($continue kconst ($const val))))))
 265     ((_ ($letrec names gensyms funs body))
 266      (make-$letrec names gensyms funs (build-cps-term body)))
 267     ((_ ($continue k exp))
 268      (make-$continue k (build-cps-exp exp)))))
 269
 270 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
 271   (match x
 272     (pat (build-cps-term body)) ...))
 273 (define-syntax-rule (rewrite-cps-cont x (pat body) ...)
 274   (match x
 275     (pat (build-cps-cont body)) ...))
 276 (define-syntax-rule (rewrite-cps-exp x (pat body) ...)
 277   (match x
 278     (pat (build-cps-exp body)) ...))
 279
 280 (define (parse-cps exp)
 281   (define (src exp)
 282     (let ((props (source-properties exp)))
 283       (and (pair? props) props)))
 284   (match exp
 285     ;; Continuations.
 286     (('letconst k (name sym c) body)
 287      (build-cps-term
 288        ($letk ((k (src exp) ($kargs (name) (sym)
 289                               ,(parse-cps body))))
 290          ($continue k ($const c)))))
 291     (('let k (name sym val) body)
 292      (build-cps-term
 293       ($letk ((k (src exp) ($kargs (name) (sym)
 294                              ,(parse-cps body))))
 295         ,(parse-cps val))))
 296     (('letk (cont ...) body)
 297      (build-cps-term
 298        ($letk ,(map parse-cps cont) ,(parse-cps body))))
 299     (('k sym body)
 300      (build-cps-cont
 301        (sym (src exp) ,(parse-cps body))))
 302     (('kif kt kf)
 303      (build-cont-body ($kif kt kf)))
 304     (('ktrunc req rest k)
 305      (build-cont-body ($ktrunc req rest k)))
 306     (('kargs names syms body)
 307      (build-cont-body ($kargs names syms ,(parse-cps body))))
 308     (('kentry self tail clauses)
 309      (build-cont-body
 310       ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
 311     (('ktail)
 312      (build-cont-body
 313       ($ktail)))
 314     (('kclause (req opt rest kw allow-other-keys?) body)
 315      (build-cont-body
 316       ($kclause (req opt rest kw allow-other-keys?)
 317         ,(parse-cps body))))
 318     (('kseq body)
 319      (build-cont-body ($kargs () () ,(parse-cps body))))
 320
 321     ;; Calls.
 322     (('continue k exp)
 323      (build-cps-term ($continue k ,(parse-cps exp))))
 324     (('var sym)
 325      (build-cps-exp ($var sym)))
 326     (('void)
 327      (build-cps-exp ($void)))
 328     (('const exp)
 329      (build-cps-exp ($const exp)))
 330     (('prim name)
 331      (build-cps-exp ($prim name)))
 332     (('fun meta free body)
 333      (build-cps-exp ($fun meta free ,(parse-cps body))))
 334     (('letrec ((name sym fun) ...) body)
 335      (build-cps-term
 336        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
 337     (('call proc arg ...)
 338      (build-cps-exp ($call proc arg)))
 339     (('primcall name arg ...)
 340      (build-cps-exp ($primcall name arg)))
 341     (('values arg ...)
 342      (build-cps-exp ($values arg)))
 343     (('prompt escape? tag handler)
 344      (build-cps-exp ($prompt escape? tag handler)))
 345     (_
 346      (error "unexpected cps" exp))))
 347
 348 (define (unparse-cps exp)
 349   (match exp
 350     ;; Continuations.
 351     (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
 352         ($ $continue k ($ $const c)))
 353      `(letconst ,k (,name ,sym ,c)
 354                 ,(unparse-cps body)))
 355     (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
 356      `(let ,k (,name ,sym ,(unparse-cps val))
 357            ,(unparse-cps body)))
 358     (($ $letk conts body)
 359      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
 360     (($ $cont sym src body)
 361      `(k ,sym ,(unparse-cps body)))
 362     (($ $kif kt kf)
 363      `(kif ,kt ,kf))
 364     (($ $ktrunc ($ $arity req () rest '() #f) k)
 365      `(ktrunc ,req ,rest ,k))
 366     (($ $kargs () () body)
 367      `(kseq ,(unparse-cps body)))
 368     (($ $kargs names syms body)
 369      `(kargs ,names ,syms ,(unparse-cps body)))
 370     (($ $kentry self tail clauses)
 371      `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
 372     (($ $ktail)
 373      `(ktail))
 374     (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
 375      `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
 376
 377     ;; Calls.
 378     (($ $continue k exp)
 379      `(continue ,k ,(unparse-cps exp)))
 380     (($ $var sym)
 381      `(var ,sym))
 382     (($ $void)
 383      `(void))
 384     (($ $const val)
 385      `(const ,val))
 386     (($ $prim name)
 387      `(prim ,name))
 388     (($ $fun meta free body)
 389      `(fun ,meta ,free ,(unparse-cps body)))
 390     (($ $letrec names syms funs body)
 391      `(letrec ,(map (lambda (name sym fun)
 392                       (list name sym (unparse-cps fun)))
 393                     names syms funs)
 394         ,(unparse-cps body)))
 395     (($ $call proc args)
 396      `(call ,proc ,@args))
 397     (($ $primcall name args)
 398      `(primcall ,name ,@args))
 399     (($ $values args)
 400      `(values ,@args))
 401     (($ $prompt escape? tag handler)
 402      `(prompt ,escape? ,tag ,handler))
 403     (_
 404      (error "unexpected cps" exp))))
 405
 406 (define (fold-conts proc seed fun)
 407   (define (cont-folder cont seed)
 408     (match cont
 409       (($ $cont k src cont)
 410        (let ((seed (proc k src cont seed)))
 411          (match cont
 412            (($ $kargs names syms body)
 413             (term-folder body seed))
 414
 415            (($ $kentry self tail clauses)
 416             (fold cont-folder (cont-folder tail seed) clauses))
 417
 418            (($ $kclause arity body)
 419             (cont-folder body seed))
 420
 421            (_ seed))))))
 422
 423   (define (fun-folder fun seed)
 424     (match fun
 425       (($ $fun meta free body)
 426        (cont-folder body seed))))
 427
 428   (define (term-folder term seed)
 429     (match term
 430       (($ $letk conts body)
 431        (fold cont-folder (term-folder body seed) conts))
 432
 433       (($ $continue k exp)
 434        (match exp
 435          (($ $fun) (fun-folder exp seed))
 436          (_ seed)))
 437
 438       (($ $letrec names syms funs body)
 439        (fold fun-folder (term-folder body seed) funs))))
 440
 441   (fun-folder fun seed))
 442
 443 (define (fold-local-conts proc seed cont)
 444   (define (cont-folder cont seed)
 445     (match cont
 446       (($ $cont k src cont)
 447        (let ((seed (proc k src cont seed)))
 448          (match cont
 449            (($ $kargs names syms body)
 450             (term-folder body seed))
 451
 452            (($ $kentry self tail clauses)
 453             (fold cont-folder (cont-folder tail seed) clauses))
 454
 455            (($ $kclause arity body)
 456             (cont-folder body seed))
 457
 458            (_ seed))))))
 459
 460   (define (term-folder term seed)
 461     (match term
 462       (($ $letk conts body)
 463        (fold cont-folder (term-folder body seed) conts))
 464
 465       (($ $continue) seed)
 466
 467       (($ $letrec names syms funs body) (term-folder body seed))))
 468
 469   (cont-folder cont seed))