module/language/tree-il/compile-cps.scm

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