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