module/language/tree-il/compile-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 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) #:hide (let-gensyms))
  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
  79 (define (toplevel-box src name bound? val-proc)
  80   (let-gensyms (name-sym bound?-sym kbox box)
  81     (build-cps-term
  82       ($letconst (('name name-sym name)
  83                   ('bound? bound?-sym bound?))
  84         ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
  85           ,(match (current-topbox-scope)
  86              (#f
  87               (build-cps-term
  88                 ($continue kbox
  89                   ($primcall 'resolve
  90                              (name-sym bound?-sym)))))
  91              (scope
  92               (let-gensyms (scope-sym)
  93                 (build-cps-term
  94                   ($letconst (('scope scope-sym scope))
  95                     ($continue kbox
  96                       ($primcall 'cached-toplevel-box
  97                                  (scope-sym name-sym bound?-sym)))))))))))))
  98
  99 (define (module-box src module name public? bound? val-proc)
 100   (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
 101     (build-cps-term
 102       ($letconst (('module module-sym module)
 103                   ('name name-sym name)
 104                   ('public? public?-sym public?)
 105                   ('bound? bound?-sym bound?))
 106         ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
 107           ($continue kbox
 108             ($primcall 'cached-module-box
 109                        (module-sym name-sym public?-sym bound?-sym))))))))
 110
 111 (define (capture-toplevel-scope src scope k)
 112   (let-gensyms (module scope-sym kmodule)
 113     (build-cps-term
 114       ($letconst (('scope scope-sym scope))
 115         ($letk ((kmodule src ($kargs ('module) (module)
 116                                ($continue k
 117                                  ($primcall 'cache-current-module!
 118                                             (module scope-sym))))))
 119           ($continue kmodule
 120             ($primcall 'current-module ())))))))
 121
 122 (define (fold-formals proc seed arity gensyms inits)
 123   (match arity
 124     (($ $arity req opt rest kw allow-other-keys?)
 125      (let ()
 126        (define (fold-req names gensyms seed)
 127          (match names
 128            (() (fold-opt opt gensyms inits seed))
 129            ((name . names)
 130             (proc name (car gensyms) #f
 131                   (fold-req names (cdr gensyms) seed)))))
 132        (define (fold-opt names gensyms inits seed)
 133          (match names
 134            (() (fold-rest rest gensyms inits seed))
 135            ((name . names)
 136             (proc name (car gensyms) (car inits)
 137                   (fold-opt names (cdr gensyms) (cdr inits) seed)))))
 138        (define (fold-rest rest gensyms inits seed)
 139          (match rest
 140            (#f (fold-kw kw gensyms inits seed))
 141            (name (proc name (car gensyms) #f
 142                        (fold-kw kw (cdr gensyms) inits seed)))))
 143        (define (fold-kw kw gensyms inits seed)
 144          (match kw
 145            (()
 146             (unless (null? gensyms)
 147               (error "too many gensyms"))
 148             (unless (null? inits)
 149               (error "too many inits"))
 150             seed)
 151            (((key name var) . kw)
 152             (unless (eq? var (car gensyms))
 153               (error "unexpected keyword arg order"))
 154             (proc name var (car inits)
 155                   (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
 156        (fold-req req gensyms seed)))))
 157
 158 (define (unbound? src sym kt kf)
 159   (define tc8-iflag 4)
 160   (define unbound-val 9)
 161   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
 162   (let-gensyms (unbound ktest)
 163     (build-cps-term
 164       ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
 165         ($letk ((ktest src ($kif kt kf)))
 166           ($continue ktest
 167             ($primcall 'eq? (sym unbound))))))))
 168
 169 (define (init-default-value name sym subst init body)
 170   (match (assq-ref subst sym)
 171     ((subst-sym box?)
 172      (let ((src (tree-il-src init)))
 173        (define (maybe-box k make-body)
 174          (if box?
 175              (let-gensyms (kbox phi)
 176                (build-cps-term
 177                  ($letk ((kbox src ($kargs (name) (phi)
 178                                      ($continue k ($primcall 'box (phi))))))
 179                    ,(make-body kbox))))
 180              (make-body k)))
 181        (let-gensyms (knext kbound kunbound)
 182          (build-cps-term
 183            ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
 184              ,(maybe-box
 185                knext
 186                (lambda (k)
 187                  (build-cps-term
 188                    ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
 189                            (kunbound src ($kargs () () ,(convert init k subst))))
 190                      ,(unbound? src sym kunbound kbound))))))))))))
 191
 192 ;; exp k-name alist -> term
 193 (define (convert exp k subst)
 194   ;; exp (v-name -> term) -> term
 195   (define (convert-arg exp k)
 196     (match exp
 197       (($ <lexical-ref> src name sym)
 198        (match (assq-ref subst sym)
 199          ((box #t)
 200           (let-gensyms (kunboxed unboxed)
 201             (build-cps-term
 202               ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
 203                 ($continue kunboxed ($primcall 'box-ref (box)))))))
 204          ((subst #f) (k subst))
 205          (#f (k sym))))
 206       (else
 207        (let ((src (tree-il-src exp)))
 208          (let-gensyms (karg arg)
 209            (build-cps-term
 210              ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
 211                ,(convert exp karg subst))))))))
 212   ;; (exp ...) ((v-name ...) -> term) -> term
 213   (define (convert-args exps k)
 214     (match exps
 215       (() (k '()))
 216       ((exp . exps)
 217        (convert-arg exp
 218          (lambda (name)
 219            (convert-args exps
 220              (lambda (names)
 221                (k (cons name names)))))))))
 222   (define (box-bound-var name sym body)
 223     (match (assq-ref subst sym)
 224       ((box #t)
 225        (let-gensyms (k)
 226          (build-cps-term
 227            ($letk ((k #f ($kargs (name) (box) ,body)))
 228              ($continue k ($primcall 'box (sym)))))))
 229       (else body)))
 230
 231   (match exp
 232     (($ <lexical-ref> src name sym)
 233      (match (assq-ref subst sym)
 234        ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
 235        ((subst #f) (build-cps-term ($continue k ($var subst))))
 236        (#f (build-cps-term ($continue k ($var sym))))))
 237
 238     (($ <void> src)
 239      (build-cps-term ($continue k ($void))))
 240
 241     (($ <const> src exp)
 242      (build-cps-term ($continue k ($const exp))))
 243
 244     (($ <primitive-ref> src name)
 245      (build-cps-term ($continue k ($prim name))))
 246
 247     (($ <lambda> fun-src meta body)
 248      (let ()
 249        (define (convert-clauses body ktail)
 250          (match body
 251            (#f '())
 252            (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 253             (let* ((arity (make-$arity req (or opt '()) rest
 254                                        (if kw (cdr kw) '()) (and kw (car kw))))
 255                    (names (fold-formals (lambda (name sym init names)
 256                                           (cons name names))
 257                                         '()
 258                                         arity gensyms inits)))
 259               (cons
 260                (let-gensyms (kclause kargs)
 261                  (build-cps-cont
 262                    (kclause
 263                     src
 264                     ($kclause ,arity
 265                       (kargs
 266                        src
 267                        ($kargs names gensyms
 268                          ,(fold-formals
 269                            (lambda (name sym init body)
 270                              (if init
 271                                  (init-default-value name sym subst init body)
 272                                  (box-bound-var name sym body)))
 273                            (convert body ktail subst)
 274                            arity gensyms inits)))))))
 275                (convert-clauses alternate ktail))))))
 276        (if (current-topbox-scope)
 277            (let-gensyms (kentry self ktail)
 278              (build-cps-term
 279                ($continue k
 280                  ($fun meta '()
 281                    (kentry fun-src
 282                            ($kentry self (ktail #f ($ktail))
 283                                     ,(convert-clauses body ktail)))))))
 284            (let-gensyms (scope kscope)
 285              (build-cps-term
 286                ($letk ((kscope fun-src
 287                                ($kargs () ()
 288                                  ,(parameterize ((current-topbox-scope scope))
 289                                     (convert exp k subst)))))
 290                  ,(capture-toplevel-scope fun-src scope kscope)))))))
 291
 292     (($ <module-ref> src mod name public?)
 293      (module-box
 294       src mod name public? #t
 295       (lambda (box)
 296         (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 297
 298     (($ <module-set> src mod name public? exp)
 299      (convert-arg exp
 300        (lambda (val)
 301          (module-box
 302           src mod name public? #f
 303           (lambda (box)
 304             (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 305
 306     (($ <toplevel-ref> src name)
 307      (toplevel-box
 308       src name #t
 309       (lambda (box)
 310         (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 311
 312     (($ <toplevel-set> src name exp)
 313      (convert-arg exp
 314        (lambda (val)
 315          (toplevel-box
 316           src name #f
 317           (lambda (box)
 318             (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 319
 320     (($ <toplevel-define> src name exp)
 321      (convert-arg exp
 322        (lambda (val)
 323          (let-gensyms (kname name-sym)
 324            (build-cps-term
 325              ($letconst (('name name-sym name))
 326                ($continue k ($primcall 'define! (name-sym val)))))))))
 327
 328     (($ <call> src proc args)
 329      (convert-args (cons proc args)
 330        (match-lambda
 331         ((proc . args)
 332          (build-cps-term ($continue k ($call proc args)))))))
 333
 334     (($ <primcall> src name args)
 335      (cond
 336       ((branching-primitive? name)
 337        (convert (make-conditional src exp (make-const #f #t)
 338                                   (make-const #f #f))
 339                 k subst))
 340       ((and (eq? name 'vector)
 341             (and-map (match-lambda
 342                       ((or ($ <const>)
 343                            ($ <void>)
 344                            ($ <lambda>)
 345                            ($ <lexical-ref>)) #t)
 346                       (_ #f))
 347                      args))
 348        ;; Some macros generate calls to "vector" with like 300
 349        ;; arguments.  Since we eventually compile to make-vector and
 350        ;; vector-set!, it reduces live variable pressure to allocate the
 351        ;; vector first, then set values as they are produced, if we can
 352        ;; prove that no value can capture the continuation.  (More on
 353        ;; that caveat here:
 354        ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
 355        ;;
 356        ;; Normally we would do this transformation in the compiler, but
 357        ;; it's quite tricky there and quite easy here, so hold your nose
 358        ;; while we drop some smelly code.
 359        (convert (let ((len (length args)))
 360                   (let-gensyms (v)
 361                     (make-let src
 362                               (list 'v)
 363                               (list v)
 364                               (list (make-primcall src 'make-vector
 365                                                    (list (make-const #f len)
 366                                                          (make-const #f #f))))
 367                               (fold (lambda (arg n tail)
 368                                       (make-seq
 369                                        src
 370                                        (make-primcall
 371                                         src 'vector-set!
 372                                         (list (make-lexical-ref src 'v v)
 373                                               (make-const #f n)
 374                                               arg))
 375                                        tail))
 376                                     (make-lexical-ref src 'v v)
 377                                     (reverse args) (reverse (iota len))))))
 378         k subst))
 379       (else
 380        (convert-args args
 381          (lambda (args)
 382            (build-cps-term ($continue k ($primcall name args))))))))
 383
 384     ;; Prompts with inline handlers.
 385     (($ <prompt> src escape-only? tag body
 386         ($ <lambda> hsrc hmeta
 387            ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
 388      ;; Handler:
 389      ;;   khargs: check args returned to handler, -> khbody
 390      ;;   khbody: the handler, -> k
 391      ;;
 392      ;; Post-body:
 393      ;;   krest: collect return vals from body to list, -> kpop
 394      ;;   kpop: pop the prompt, -> kprim
 395      ;;   kprim: load the values primitive, -> kret
 396      ;;   kret: (apply values rvals), -> k
 397      ;;
 398      ;; Escape prompts evaluate the body with the continuation of krest.
 399      ;; Otherwise we do a no-inline call to body, continuing to krest.
 400      (convert-arg tag
 401        (lambda (tag)
 402          (let ((hnames (append hreq (if hrest (list hrest) '()))))
 403            (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
 404              (build-cps-term
 405                ($letk* ((khbody hsrc ($kargs hnames hsyms
 406                                        ,(fold box-bound-var
 407                                               (convert hbody k subst)
 408                                               hnames hsyms)))
 409                         (khargs hsrc ($ktrunc hreq hrest khbody))
 410                         (kpop src
 411                               ($kargs ('rest) (vals)
 412                                 ($letk ((kret
 413                                          src
 414                                          ($kargs () ()
 415                                            ($letk ((kprim
 416                                                     src
 417                                                     ($kargs ('prim) (prim)
 418                                                       ($continue k
 419                                                         ($primcall 'apply
 420                                                                    (prim vals))))))
 421                                              ($continue kprim
 422                                                ($prim 'values))))))
 423                                   ($continue kret
 424                                     ($primcall 'unwind ())))))
 425                         (krest src ($ktrunc '() 'rest kpop)))
 426                  ,(if escape-only?
 427                       (build-cps-term
 428                         ($letk ((kbody (tree-il-src body)
 429                                        ($kargs () ()
 430                                          ,(convert body krest subst))))
 431                           ($continue kbody ($prompt #t tag khargs kpop))))
 432                       (convert-arg body
 433                         (lambda (thunk)
 434                           (build-cps-term
 435                             ($letk ((kbody (tree-il-src body)
 436                                            ($kargs () ()
 437                                              ($continue krest
 438                                                ($primcall 'call-thunk/no-inline
 439                                                           (thunk))))))
 440                               ($continue kbody
 441                                 ($prompt #f tag khargs kpop))))))))))))))
 442
 443     ;; Eta-convert prompts without inline handlers.
 444     (($ <prompt> src escape-only? tag body handler)
 445      (let-gensyms (h args)
 446        (convert
 447         (make-let
 448          src (list 'h) (list h) (list handler)
 449          (make-seq
 450           src
 451           (make-conditional
 452            src
 453            (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
 454            (make-void src)
 455            (make-primcall
 456             src 'scm-error
 457             (list
 458              (make-const #f 'wrong-type-arg)
 459              (make-const #f "call-with-prompt")
 460              (make-const #f "Wrong type (expecting procedure): ~S")
 461              (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
 462              (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
 463           (make-prompt
 464            src escape-only? tag body
 465            (make-lambda
 466             src '()
 467             (make-lambda-case
 468              src '() #f 'args #f '() (list args)
 469              (make-primcall
 470               src 'apply
 471               (list (make-lexical-ref #f 'h h)
 472                     (make-lexical-ref #f 'args args)))
 473              #f)))))
 474         k
 475         subst)))
 476
 477     (($ <abort> src tag args ($ <const> _ ()))
 478      (convert-args (cons tag args)
 479        (lambda (args*)
 480          (build-cps-term
 481            ($continue k ($primcall 'abort-to-prompt args*))))))
 482
 483     (($ <abort> src tag args tail)
 484      (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
 485                                  tag)
 486                            args
 487                            (list tail))
 488        (lambda (args*)
 489          (build-cps-term
 490            ($continue k ($primcall 'apply args*))))))
 491
 492     (($ <conditional> src test consequent alternate)
 493      (let-gensyms (kif kt kf)
 494        (build-cps-term
 495          ($letk* ((kt (tree-il-src consequent) ($kargs () ()
 496                                                  ,(convert consequent k subst)))
 497                   (kf (tree-il-src alternate) ($kargs () ()
 498                                                 ,(convert alternate k subst)))
 499                   (kif src ($kif kt kf)))
 500            ,(match test
 501               (($ <primcall> src (? branching-primitive? name) args)
 502                (convert-args args
 503                  (lambda (args)
 504                    (build-cps-term ($continue kif ($primcall name args))))))
 505               (_ (convert-arg test
 506                    (lambda (test)
 507                      (build-cps-term ($continue kif ($var test)))))))))))
 508
 509     (($ <lexical-set> src name gensym exp)
 510      (convert-arg exp
 511        (lambda (exp)
 512          (match (assq-ref subst gensym)
 513            ((box #t)
 514             (build-cps-term
 515               ($continue k ($primcall 'box-set! (box exp)))))))))
 516
 517     (($ <seq> src head tail)
 518      (let-gensyms (ktrunc kseq)
 519        (build-cps-term
 520          ($letk* ((kseq (tree-il-src tail) ($kargs () ()
 521                                              ,(convert tail k subst)))
 522                   (ktrunc src ($ktrunc '() #f kseq)))
 523            ,(convert head ktrunc subst)))))
 524
 525     (($ <let> src names syms vals body)
 526      (let lp ((names names) (syms syms) (vals vals))
 527        (match (list names syms vals)
 528          ((() () ()) (convert body k subst))
 529          (((name . names) (sym . syms) (val . vals))
 530           (let-gensyms (klet)
 531             (build-cps-term
 532               ($letk ((klet src ($kargs (name) (sym)
 533                                   ,(box-bound-var name sym
 534                                                   (lp names syms vals)))))
 535                 ,(convert val klet subst))))))))
 536
 537     (($ <fix> src names gensyms funs body)
 538      ;; Some letrecs can be contified; that happens later.
 539      (if (current-topbox-scope)
 540          (let-gensyms (self)
 541            (build-cps-term
 542              ($letrec names
 543                       gensyms
 544                       (map (lambda (fun)
 545                              (match (convert fun k subst)
 546                                (($ $continue _ (and fun ($ $fun)))
 547                                 fun)))
 548                            funs)
 549                       ,(convert body k subst))))
 550          (let-gensyms (scope kscope)
 551            (build-cps-term
 552              ($letk ((kscope src ($kargs () ()
 553                                    ,(parameterize ((current-topbox-scope scope))
 554                                       (convert exp k subst)))))
 555                ,(capture-toplevel-scope src scope kscope))))))
 556
 557     (($ <let-values> src exp
 558         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
 559      (let ((names (append req (if rest (list rest) '()))))
 560        (let-gensyms (ktrunc kargs)
 561          (build-cps-term
 562            ($letk* ((kargs src ($kargs names syms
 563                                  ,(fold box-bound-var
 564                                         (convert body k subst)
 565                                         names syms)))
 566                     (ktrunc src ($ktrunc req rest kargs)))
 567              ,(convert exp ktrunc subst))))))))
 568
 569 (define (build-subst exp)
 570   "Compute a mapping from lexical gensyms to substituted gensyms.  The
 571 usual reason to replace one variable by another is assignment
 572 conversion.  Default argument values is the other reason.
 573
 574 Returns a list of (ORIG-SYM SUBST-SYM BOXED?).  A true value for BOXED?
 575 indicates that the replacement variable is in a box."
 576   (define (box-set-vars exp subst)
 577     (match exp
 578       (($ <lexical-set> src name sym exp)
 579        (if (assq sym subst)
 580            subst
 581            (cons (list sym (gensym "b") #t) subst)))
 582       (_ subst)))
 583   (define (default-args exp subst)
 584     (match exp
 585       (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 586        (fold-formals (lambda (name sym init subst)
 587                        (if init
 588                            (let ((box? (match (assq-ref subst sym)
 589                                          ((box #t) #t)
 590                                          (#f #f)))
 591                                  (subst-sym (gensym (symbol->string name))))
 592                              (cons (list sym subst-sym box?) subst))
 593                            subst))
 594                      subst
 595                      (make-$arity req (or opt '()) rest
 596                                   (if kw (cdr kw) '()) (and kw (car kw)))
 597                      gensyms
 598                      inits))
 599       (_ subst)))
 600   (tree-il-fold box-set-vars default-args '() exp))
 601
 602 (define (cps-convert/thunk exp)
 603   (let ((src (tree-il-src exp)))
 604     (let-gensyms (kinit init ktail kclause kbody)
 605       (build-cps-exp
 606         ($fun '() '()
 607           (kinit src
 608                  ($kentry init
 609                    (ktail #f ($ktail))
 610                    ((kclause src
 611                             ($kclause ('() '() #f '() #f)
 612                               (kbody src
 613                                      ($kargs () ()
 614                                        ,(convert exp ktail
 615                                                  (build-subst exp))))))))))))))
 616
 617 (define *comp-module* (make-fluid))
 618
 619 (define %warning-passes
 620   `((unused-variable     . ,unused-variable-analysis)
 621     (unused-toplevel     . ,unused-toplevel-analysis)
 622     (unbound-variable    . ,unbound-variable-analysis)
 623     (arity-mismatch      . ,arity-analysis)
 624     (format              . ,format-analysis)))
 625
 626 (define (optimize-tree-il x e opts)
 627   (define warnings
 628     (or (and=> (memq #:warnings opts) cadr)
 629         '()))
 630
 631   ;; Go through the warning passes.
 632   (let ((analyses (filter-map (lambda (kind)
 633                                 (assoc-ref %warning-passes kind))
 634                               warnings)))
 635     (analyze-tree analyses x e))
 636
 637   (optimize x e opts))
 638
 639 (define (compile-cps exp env opts)
 640   (values (cps-convert/thunk (optimize-tree-il exp env opts))
 641           env
 642           env))
 643
 644 ;;; Local Variables:
 645 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
 646 ;;; eval: (put 'convert-args 'scheme-indent-function 1)
 647 ;;; End: