module/language/tree-il/compile-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 pass converts Tree-IL to the continuation-passing style (CPS)
  22 ;;; language.
  23 ;;;
  24 ;;; CPS is a lower-level representation than Tree-IL.  Converting to
  25 ;;; CPS, beyond adding names for all control points and all values,
  26 ;;; simplifies expressions in the following ways, among others:
  27 ;;;
  28 ;;;   * Fixing the order of evaluation.
  29 ;;;
  30 ;;;   * Converting assigned variables to boxed variables.
  31 ;;;
  32 ;;;   * Requiring that Scheme's <letrec> has already been lowered to
  33 ;;;     <fix>.
  34 ;;;
  35 ;;;   * Inlining default-value initializers into lambda-case
  36 ;;;     expressions.
  37 ;;;
  38 ;;;   * Inlining prompt bodies.
  39 ;;;
  40 ;;;   * Turning toplevel and module references into primcalls.  This
  41 ;;;     involves explicitly modelling the "scope" of toplevel lookups
  42 ;;;     (indicating the module with respect to which toplevel bindings
  43 ;;;     are resolved).
  44 ;;;
  45 ;;; The utility of CPS is that it gives a name to everything: every
  46 ;;; intermediate value, and every control point (continuation).  As such
  47 ;;; it is more verbose than Tree-IL, but at the same time more simple as
  48 ;;; the number of concepts is reduced.
  49 ;;;
  50 ;;; Code:
  51
  52 (define-module (language tree-il compile-cps)
  53   #:use-module (ice-9 match)
  54   #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
  55   #:use-module (srfi srfi-26)
  56   #:use-module ((system foreign) #:select (make-pointer pointer->scm))
  57   #:use-module (language cps)
  58   #:use-module (language cps primitives)
  59   #:use-module (language tree-il analyze)
  60   #:use-module (language tree-il optimize)
  61   #:use-module (language tree-il)
  62   #:export (compile-cps))
  63
  64 ;;; Guile's semantics are that a toplevel lambda captures a reference on
  65 ;;; the current module, and that all contained lambdas use that module
  66 ;;; to resolve toplevel variables.  This parameter tracks whether or not
  67 ;;; we are in a toplevel lambda.  If we are in a lambda, the parameter
  68 ;;; is bound to a fresh name identifying the module that was current
  69 ;;; when the toplevel lambda is defined.
  70 ;;;
  71 ;;; This is more complicated than it need be.  Ideally we should resolve
  72 ;;; all toplevel bindings to bindings from specific modules, unless the
  73 ;;; binding is unbound.  This is always valid if the compilation unit
  74 ;;; sets the module explicitly, as when compiling a module, but it
  75 ;;; doesn't work for files auto-compiled for use with `load'.
  76 ;;;
  77 (define current-topbox-scope (make-parameter #f))
  78 (define scope-counter (make-parameter #f))
  79
  80 (define (fresh-scope-id)
  81   (let ((scope-id (scope-counter)))
  82     (scope-counter (1+ scope-id))
  83     scope-id))
  84
  85 (define (toplevel-box src name bound? val-proc)
  86   (let-fresh (kbox) (name-sym bound?-sym box)
  87     (build-cps-term
  88       ($letconst (('name name-sym name)
  89                   ('bound? bound?-sym bound?))
  90         ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
  91           ,(match (current-topbox-scope)
  92              (#f
  93               (build-cps-term
  94                 ($continue kbox src
  95                   ($primcall 'resolve
  96                              (name-sym bound?-sym)))))
  97              (scope-id
  98               (let-fresh () (scope-sym)
  99                 (build-cps-term
 100                   ($letconst (('scope scope-sym scope-id))
 101                     ($continue kbox src
 102                       ($primcall 'cached-toplevel-box
 103                                  (scope-sym name-sym bound?-sym)))))))))))))
 104
 105 (define (module-box src module name public? bound? val-proc)
 106   (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
 107     (build-cps-term
 108       ($letconst (('module module-sym module)
 109                   ('name name-sym name)
 110                   ('public? public?-sym public?)
 111                   ('bound? bound?-sym bound?))
 112         ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
 113           ($continue kbox src
 114             ($primcall 'cached-module-box
 115                        (module-sym name-sym public?-sym bound?-sym))))))))
 116
 117 (define (capture-toplevel-scope src scope-id k)
 118   (let-fresh (kmodule) (module scope-sym)
 119     (build-cps-term
 120       ($letconst (('scope scope-sym scope-id))
 121         ($letk ((kmodule ($kargs ('module) (module)
 122                            ($continue k src
 123                              ($primcall 'cache-current-module!
 124                                         (module scope-sym))))))
 125           ($continue kmodule src
 126             ($primcall 'current-module ())))))))
 127
 128 (define (fold-formals proc seed arity gensyms inits)
 129   (match arity
 130     (($ $arity req opt rest kw allow-other-keys?)
 131      (let ()
 132        (define (fold-req names gensyms seed)
 133          (match names
 134            (() (fold-opt opt gensyms inits seed))
 135            ((name . names)
 136             (proc name (car gensyms) #f
 137                   (fold-req names (cdr gensyms) seed)))))
 138        (define (fold-opt names gensyms inits seed)
 139          (match names
 140            (() (fold-rest rest gensyms inits seed))
 141            ((name . names)
 142             (proc name (car gensyms) (car inits)
 143                   (fold-opt names (cdr gensyms) (cdr inits) seed)))))
 144        (define (fold-rest rest gensyms inits seed)
 145          (match rest
 146            (#f (fold-kw kw gensyms inits seed))
 147            (name (proc name (car gensyms) #f
 148                        (fold-kw kw (cdr gensyms) inits seed)))))
 149        (define (fold-kw kw gensyms inits seed)
 150          (match kw
 151            (()
 152             (unless (null? gensyms)
 153               (error "too many gensyms"))
 154             (unless (null? inits)
 155               (error "too many inits"))
 156             seed)
 157            (((key name var) . kw)
 158             ;; Could be that var is not a gensym any more.
 159             (when (symbol? var)
 160               (unless (eq? var (car gensyms))
 161                 (error "unexpected keyword arg order")))
 162             (proc name (car gensyms) (car inits)
 163                   (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
 164        (fold-req req gensyms seed)))))
 165
 166 (define (unbound? src var kt kf)
 167   (define tc8-iflag 4)
 168   (define unbound-val 9)
 169   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
 170   (let-fresh (ktest) (unbound)
 171     (build-cps-term
 172       ($letconst (('unbound unbound
 173                             (pointer->scm (make-pointer unbound-bits))))
 174         ($letk ((ktest ($kif kt kf)))
 175           ($continue ktest src
 176             ($primcall 'eq? (var unbound))))))))
 177
 178 (define (init-default-value name sym subst init body)
 179   (match (hashq-ref subst sym)
 180     ((orig-var subst-var box?)
 181      (let ((src (tree-il-src init)))
 182        (define (maybe-box k make-body)
 183          (if box?
 184              (let-fresh (kbox) (phi)
 185                (build-cps-term
 186                  ($letk ((kbox ($kargs (name) (phi)
 187                                  ($continue k src ($primcall 'box (phi))))))
 188                    ,(make-body kbox))))
 189              (make-body k)))
 190        (let-fresh (knext kbound kunbound kreceive krest) (val rest)
 191          (build-cps-term
 192            ($letk ((knext ($kargs (name) (subst-var) ,body)))
 193              ,(maybe-box
 194                knext
 195                (lambda (k)
 196                  (build-cps-term
 197                    ($letk ((kbound ($kargs () () ($continue k src
 198                                                    ($values (orig-var)))))
 199                            (krest ($kargs (name 'rest) (val rest)
 200                                     ($continue k src ($values (val)))))
 201                            (kreceive ($kreceive (list name) 'rest krest))
 202                            (kunbound ($kargs () ()
 203                                        ,(convert init kreceive subst))))
 204                      ,(unbound? src orig-var kunbound kbound))))))))))))
 205
 206 ;; exp k-name alist -> term
 207 (define (convert exp k subst)
 208   ;; exp (v-name -> term) -> term
 209   (define (convert-arg exp k)
 210     (match exp
 211       (($ <lexical-ref> src name sym)
 212        (match (hashq-ref subst sym)
 213          ((orig-var box #t)
 214           (let-fresh (kunboxed) (unboxed)
 215             (build-cps-term
 216               ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
 217                 ($continue kunboxed src ($primcall 'box-ref (box)))))))
 218          ((orig-var subst-var #f) (k subst-var))
 219          (var (k var))))
 220       (else
 221        (let-fresh (kreceive karg) (arg rest)
 222          (build-cps-term
 223            ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
 224                    (kreceive ($kreceive '(arg) 'rest karg)))
 225              ,(convert exp kreceive subst)))))))
 226   ;; (exp ...) ((v-name ...) -> term) -> term
 227   (define (convert-args exps k)
 228     (match exps
 229       (() (k '()))
 230       ((exp . exps)
 231        (convert-arg exp
 232          (lambda (name)
 233            (convert-args exps
 234              (lambda (names)
 235                (k (cons name names)))))))))
 236   (define (box-bound-var name sym body)
 237     (match (hashq-ref subst sym)
 238       ((orig-var subst-var #t)
 239        (let-fresh (k) ()
 240          (build-cps-term
 241            ($letk ((k ($kargs (name) (subst-var) ,body)))
 242              ($continue k #f ($primcall 'box (orig-var)))))))
 243       (else body)))
 244   (define (bound-var sym)
 245     (match (hashq-ref subst sym)
 246       ((var . _) var)
 247       ((? exact-integer? var) var)))
 248
 249   (match exp
 250     (($ <lexical-ref> src name sym)
 251      (rewrite-cps-term (hashq-ref subst sym)
 252        ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
 253        ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
 254        (var ($continue k src ($values (var))))))
 255
 256     (($ <void> src)
 257      (build-cps-term ($continue k src ($void))))
 258
 259     (($ <const> src exp)
 260      (build-cps-term ($continue k src ($const exp))))
 261
 262     (($ <primitive-ref> src name)
 263      (build-cps-term ($continue k src ($prim name))))
 264
 265     (($ <lambda> fun-src meta body)
 266      (let ()
 267        (define (convert-clauses body ktail)
 268          (match body
 269            (#f #f)
 270            (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 271             (let* ((arity (make-$arity req (or opt '()) rest
 272                                        (map (match-lambda
 273                                              ((kw name sym)
 274                                               (list kw name (bound-var sym))))
 275                                             (if kw (cdr kw) '()))
 276                                        (and kw (car kw))))
 277                    (names (fold-formals (lambda (name sym init names)
 278                                           (cons name names))
 279                                         '()
 280                                         arity gensyms inits)))
 281               (let ((bound-vars (map bound-var gensyms)))
 282                 (let-fresh (kclause kargs) ()
 283                   (build-cps-cont
 284                     (kclause
 285                      ($kclause ,arity
 286                        (kargs
 287                         ($kargs names bound-vars
 288                           ,(fold-formals
 289                             (lambda (name sym init body)
 290                               (if init
 291                                   (init-default-value name sym subst init body)
 292                                   (box-bound-var name sym body)))
 293                             (convert body ktail subst)
 294                             arity gensyms inits)))
 295                        ,(convert-clauses alternate ktail))))))))))
 296        (if (current-topbox-scope)
 297            (let-fresh (kfun ktail) (self)
 298              (build-cps-term
 299                ($continue k fun-src
 300                  ($fun '()
 301                    (kfun ($kfun fun-src meta self (ktail ($ktail))
 302                              ,(convert-clauses body ktail)))))))
 303            (let ((scope-id (fresh-scope-id)))
 304              (let-fresh (kscope) ()
 305                (build-cps-term
 306                  ($letk ((kscope
 307                           ($kargs () ()
 308                             ,(parameterize ((current-topbox-scope scope-id))
 309                                (convert exp k subst)))))
 310                    ,(capture-toplevel-scope fun-src scope-id kscope))))))))
 311
 312     (($ <module-ref> src mod name public?)
 313      (module-box
 314       src mod name public? #t
 315       (lambda (box)
 316         (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
 317
 318     (($ <module-set> src mod name public? exp)
 319      (convert-arg exp
 320        (lambda (val)
 321          (module-box
 322           src mod name public? #f
 323           (lambda (box)
 324             (build-cps-term
 325               ($continue k src ($primcall 'box-set! (box val)))))))))
 326
 327     (($ <toplevel-ref> src name)
 328      (toplevel-box
 329       src name #t
 330       (lambda (box)
 331         (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
 332
 333     (($ <toplevel-set> src name exp)
 334      (convert-arg exp
 335        (lambda (val)
 336          (toplevel-box
 337           src name #f
 338           (lambda (box)
 339             (build-cps-term
 340               ($continue k src ($primcall 'box-set! (box val)))))))))
 341
 342     (($ <toplevel-define> src name exp)
 343      (convert-arg exp
 344        (lambda (val)
 345          (let-fresh (kname) (name-sym)
 346            (build-cps-term
 347              ($letconst (('name name-sym name))
 348                ($continue k src ($primcall 'define! (name-sym val)))))))))
 349
 350     (($ <call> src proc args)
 351      (convert-args (cons proc args)
 352        (match-lambda
 353         ((proc . args)
 354          (build-cps-term ($continue k src ($call proc args)))))))
 355
 356     (($ <primcall> src name args)
 357      (cond
 358       ((branching-primitive? name)
 359        (convert-args args
 360          (lambda (args)
 361            (let-fresh (kt kf kif) ()
 362              (build-cps-term
 363                ($letk ((kt ($kargs () () ($continue k src ($const #t))))
 364                        (kf ($kargs () () ($continue k src ($const #f))))
 365                        (kif ($kif kt kf)))
 366                  ($continue kif src ($primcall name args))))))))
 367       ((and (eq? name 'list)
 368             (and-map (match-lambda
 369                       ((or ($ <const>)
 370                            ($ <void>)
 371                            ($ <lambda>)
 372                            ($ <lexical-ref>)) #t)
 373                       (_ #f))
 374                      args))
 375        ;; See note below in `canonicalize' about `vector'.  The same
 376        ;; thing applies to `list'.
 377        (let lp ((args args) (k k))
 378          (match args
 379            (()
 380             (build-cps-term
 381               ($continue k src ($const '()))))
 382            ((arg . args)
 383             (let-fresh (ktail) (tail)
 384               (build-cps-term
 385                 ($letk ((ktail ($kargs ('tail) (tail)
 386                                  ,(convert-arg arg
 387                                     (lambda (head)
 388                                       (build-cps-term
 389                                         ($continue k src
 390                                           ($primcall 'cons (head tail)))))))))
 391                   ,(lp args ktail))))))))
 392       (else
 393        (convert-args args
 394          (lambda (args)
 395            (build-cps-term ($continue k src ($primcall name args))))))))
 396
 397     ;; Prompts with inline handlers.
 398     (($ <prompt> src escape-only? tag body
 399         ($ <lambda> hsrc hmeta
 400            ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
 401      ;; Handler:
 402      ;;   khargs: check args returned to handler, -> khbody
 403      ;;   khbody: the handler, -> k
 404      ;;
 405      ;; Post-body:
 406      ;;   krest: collect return vals from body to list, -> kpop
 407      ;;   kpop: pop the prompt, -> kprim
 408      ;;   kprim: load the values primitive, -> kret
 409      ;;   kret: (apply values rvals), -> k
 410      ;;
 411      ;; Escape prompts evaluate the body with the continuation of krest.
 412      ;; Otherwise we do a no-inline call to body, continuing to krest.
 413      (convert-arg tag
 414        (lambda (tag)
 415          (let ((hnames (append hreq (if hrest (list hrest) '())))
 416                (bound-vars (map bound-var hsyms)))
 417            (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
 418              (build-cps-term
 419                ;; FIXME: Attach hsrc to $kreceive.
 420                ($letk* ((khbody ($kargs hnames bound-vars
 421                                   ,(fold box-bound-var
 422                                          (convert hbody k subst)
 423                                          hnames hsyms)))
 424                         (khargs ($kreceive hreq hrest khbody))
 425                         (kpop ($kargs ('rest) (vals)
 426                                 ($letk ((kret
 427                                          ($kargs () ()
 428                                            ($letk ((kprim
 429                                                     ($kargs ('prim) (prim)
 430                                                       ($continue k src
 431                                                         ($primcall 'apply
 432                                                                    (prim vals))))))
 433                                              ($continue kprim src
 434                                                ($prim 'values))))))
 435                                   ($continue kret src
 436                                     ($primcall 'unwind ())))))
 437                         (krest ($kreceive '() 'rest kpop)))
 438                  ,(if escape-only?
 439                       (build-cps-term
 440                         ($letk ((kbody ($kargs () ()
 441                                          ,(convert body krest subst))))
 442                           ($continue kbody src ($prompt #t tag khargs))))
 443                       (convert-arg body
 444                         (lambda (thunk)
 445                           (build-cps-term
 446                             ($letk ((kbody ($kargs () ()
 447                                              ($continue krest (tree-il-src body)
 448                                                ($primcall 'call-thunk/no-inline
 449                                                           (thunk))))))
 450                               ($continue kbody (tree-il-src body)
 451                                 ($prompt #f tag khargs))))))))))))))
 452
 453     (($ <abort> src tag args ($ <const> _ ()))
 454      (convert-args (cons tag args)
 455        (lambda (args*)
 456          (build-cps-term
 457            ($continue k src
 458              ($primcall 'abort-to-prompt args*))))))
 459
 460     (($ <abort> src tag args tail)
 461      (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
 462                                  tag)
 463                            args
 464                            (list tail))
 465        (lambda (args*)
 466          (build-cps-term
 467            ($continue k src ($primcall 'apply args*))))))
 468
 469     (($ <conditional> src test consequent alternate)
 470      (let-fresh (kif kt kf) ()
 471        (build-cps-term
 472          ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
 473                   (kf ($kargs () () ,(convert alternate k subst)))
 474                   (kif ($kif kt kf)))
 475            ,(match test
 476               (($ <primcall> src (? branching-primitive? name) args)
 477                (convert-args args
 478                  (lambda (args)
 479                    (build-cps-term
 480                      ($continue kif src ($primcall name args))))))
 481               (_ (convert-arg test
 482                    (lambda (test)
 483                      (build-cps-term
 484                        ($continue kif src ($values (test))))))))))))
 485
 486     (($ <lexical-set> src name gensym exp)
 487      (convert-arg exp
 488        (lambda (exp)
 489          (match (hashq-ref subst gensym)
 490            ((orig-var box #t)
 491             (build-cps-term
 492               ($continue k src ($primcall 'box-set! (box exp)))))))))
 493
 494     (($ <seq> src head tail)
 495      (let-fresh (kreceive kseq) (vals)
 496        (build-cps-term
 497          ($letk* ((kseq ($kargs ('vals) (vals)
 498                           ,(convert tail k subst)))
 499                   (kreceive ($kreceive '() 'vals kseq)))
 500            ,(convert head kreceive subst)))))
 501
 502     (($ <let> src names syms vals body)
 503      (let lp ((names names) (syms syms) (vals vals))
 504        (match (list names syms vals)
 505          ((() () ()) (convert body k subst))
 506          (((name . names) (sym . syms) (val . vals))
 507           (let-fresh (kreceive klet) (rest)
 508             (build-cps-term
 509               ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
 510                                ,(box-bound-var name sym
 511                                                (lp names syms vals))))
 512                        (kreceive ($kreceive (list name) 'rest klet)))
 513                 ,(convert val kreceive subst))))))))
 514
 515     (($ <fix> src names gensyms funs body)
 516      ;; Some letrecs can be contified; that happens later.
 517      (if (current-topbox-scope)
 518          (let-fresh () (self)
 519            (build-cps-term
 520              ($letrec names
 521                       (map bound-var gensyms)
 522                       (map (lambda (fun)
 523                              (match (convert fun k subst)
 524                                (($ $continue _ _ (and fun ($ $fun)))
 525                                 fun)))
 526                            funs)
 527                       ,(convert body k subst))))
 528          (let ((scope-id (fresh-scope-id)))
 529            (let-fresh (kscope) ()
 530              (build-cps-term
 531                ($letk ((kscope
 532                         ($kargs () ()
 533                           ,(parameterize ((current-topbox-scope scope-id))
 534                              (convert exp k subst)))))
 535                  ,(capture-toplevel-scope src scope-id kscope)))))))
 536
 537     (($ <let-values> src exp
 538         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
 539      (let ((names (append req (if rest (list rest) '())))
 540            (bound-vars (map bound-var syms)))
 541        (let-fresh (kreceive kargs) ()
 542          (build-cps-term
 543            ($letk* ((kargs ($kargs names bound-vars
 544                              ,(fold box-bound-var
 545                                     (convert body k subst)
 546                                     names syms)))
 547                     (kreceive ($kreceive req rest kargs)))
 548              ,(convert exp kreceive subst))))))))
 549
 550 (define (build-subst exp)
 551   "Compute a mapping from lexical gensyms to CPS variable indexes.  CPS
 552 uses small integers to identify variables, instead of gensyms.
 553
 554 This subst table serves an additional purpose of mapping variables to
 555 replacements.  The usual reason to replace one variable by another is
 556 assignment conversion.  Default argument values is the other reason.
 557
 558 The result is a hash table mapping symbols to substitutions (in the case
 559 that a variable is substituted) or to indexes.  A substitution is a list
 560 of the form:
 561
 562   (ORIG-INDEX SUBST-INDEX BOXED?)
 563
 564 A true value for BOXED?  indicates that the replacement variable is in a
 565 box.  If a variable is not substituted, the mapped value is a small
 566 integer."
 567   (let ((table (make-hash-table)))
 568     (define (down exp)
 569       (match exp
 570         (($ <lexical-set> src name sym exp)
 571          (match (hashq-ref table sym)
 572            ((orig subst #t) #t)
 573            ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
 574            ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
 575         (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 576          (fold-formals (lambda (name sym init seed)
 577                          (hashq-set! table sym
 578                                      (if init
 579                                          (list (fresh-var) (fresh-var) #f)
 580                                          (fresh-var))))
 581                        #f
 582                        (make-$arity req (or opt '()) rest
 583                                     (if kw (cdr kw) '()) (and kw (car kw)))
 584                        gensyms
 585                        inits))
 586         (($ <let> src names gensyms vals body)
 587          (for-each (lambda (sym)
 588                      (hashq-set! table sym (fresh-var)))
 589                    gensyms))
 590         (($ <fix> src names gensyms vals body)
 591          (for-each (lambda (sym)
 592                      (hashq-set! table sym (fresh-var)))
 593                    gensyms))
 594         (_ #t))
 595       (values))
 596     (define (up exp) (values))
 597     ((make-tree-il-folder) exp down up)
 598     table))
 599
 600 (define (cps-convert/thunk exp)
 601   (parameterize ((label-counter 0)
 602                  (var-counter 0)
 603                  (scope-counter 0))
 604     (let ((src (tree-il-src exp)))
 605       (let-fresh (kinit ktail kclause kbody) (init)
 606         (build-cps-cont
 607           (kinit ($kfun src '() init (ktail ($ktail))
 608                    (kclause
 609                     ($kclause ('() '() #f '() #f)
 610                       (kbody ($kargs () ()
 611                                ,(convert exp ktail
 612                                          (build-subst exp))))
 613                       ,#f)))))))))
 614
 615 (define *comp-module* (make-fluid))
 616
 617 (define %warning-passes
 618   `((unused-variable     . ,unused-variable-analysis)
 619     (unused-toplevel     . ,unused-toplevel-analysis)
 620     (unbound-variable    . ,unbound-variable-analysis)
 621     (arity-mismatch      . ,arity-analysis)
 622     (format              . ,format-analysis)))
 623
 624 (define (optimize-tree-il x e opts)
 625   (define warnings
 626     (or (and=> (memq #:warnings opts) cadr)
 627         '()))
 628
 629   ;; Go through the warning passes.
 630   (let ((analyses (filter-map (lambda (kind)
 631                                 (assoc-ref %warning-passes kind))
 632                               warnings)))
 633     (analyze-tree analyses x e))
 634
 635   (optimize x e opts))
 636
 637 (define (canonicalize exp)
 638   (post-order
 639    (lambda (exp)
 640      (match exp
 641        (($ <primcall> src 'vector
 642            (and args
 643                 ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
 644                  ...)))
 645         ;; Some macros generate calls to "vector" with like 300
 646         ;; arguments.  Since we eventually compile to make-vector and
 647         ;; vector-set!, it reduces live variable pressure to allocate the
 648         ;; vector first, then set values as they are produced, if we can
 649         ;; prove that no value can capture the continuation.  (More on
 650         ;; that caveat here:
 651         ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
 652         ;;
 653         ;; Normally we would do this transformation in the compiler, but
 654         ;; it's quite tricky there and quite easy here, so hold your nose
 655         ;; while we drop some smelly code.
 656         (let ((len (length args))
 657               (v (gensym "v ")))
 658           (make-let src
 659                     (list 'v)
 660                     (list v)
 661                     (list (make-primcall src 'make-vector
 662                                          (list (make-const #f len)
 663                                                (make-const #f #f))))
 664                     (fold (lambda (arg n tail)
 665                             (make-seq
 666                              src
 667                              (make-primcall
 668                               src 'vector-set!
 669                               (list (make-lexical-ref src 'v v)
 670                                     (make-const #f n)
 671                                     arg))
 672                              tail))
 673                           (make-lexical-ref src 'v v)
 674                           (reverse args) (reverse (iota len))))))
 675
 676        (($ <prompt> src escape-only? tag body
 677            ($ <lambda> hsrc hmeta
 678               ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
 679         exp)
 680
 681        ;; Eta-convert prompts without inline handlers.
 682        (($ <prompt> src escape-only? tag body handler)
 683         (let ((h (gensym "h "))
 684               (args (gensym "args ")))
 685           (make-let
 686            src (list 'h) (list h) (list handler)
 687            (make-seq
 688             src
 689             (make-conditional
 690              src
 691              (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
 692              (make-void src)
 693              (make-primcall
 694               src 'scm-error
 695               (list
 696                (make-const #f 'wrong-type-arg)
 697                (make-const #f "call-with-prompt")
 698                (make-const #f "Wrong type (expecting procedure): ~S")
 699                (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
 700                (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
 701             (make-prompt
 702              src escape-only? tag body
 703              (make-lambda
 704               src '()
 705               (make-lambda-case
 706                src '() #f 'args #f '() (list args)
 707                (make-primcall
 708                 src 'apply
 709                 (list (make-lexical-ref #f 'h h)
 710                       (make-lexical-ref #f 'args args)))
 711                #f)))))))
 712        (_ exp)))
 713    exp))
 714
 715 (define (compile-cps exp env opts)
 716   (values (cps-convert/thunk
 717            (canonicalize (optimize-tree-il exp env opts)))
 718           env
 719           env))
 720
 721 ;;; Local Variables:
 722 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
 723 ;;; eval: (put 'convert-args 'scheme-indent-function 1)
 724 ;;; End: