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