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     (($ <abort> src tag args ($ <const> _ ()))
 468      (convert-args (cons tag args)
 469        (lambda (args*)
 470          (build-cps-term
 471            ($continue k src
 472              ($primcall 'abort-to-prompt args*))))))
 473
 474     (($ <abort> src tag args tail)
 475      (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
 476                                  tag)
 477                            args
 478                            (list tail))
 479        (lambda (args*)
 480          (build-cps-term
 481            ($continue k src ($primcall 'apply args*))))))
 482
 483     (($ <conditional> src test consequent alternate)
 484      (let-fresh (kif kt kf) ()
 485        (build-cps-term
 486          ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
 487                   (kf ($kargs () () ,(convert alternate k subst)))
 488                   (kif ($kif kt kf)))
 489            ,(match test
 490               (($ <primcall> src (? branching-primitive? name) args)
 491                (convert-args args
 492                  (lambda (args)
 493                    (build-cps-term
 494                      ($continue kif src ($primcall name args))))))
 495               (_ (convert-arg test
 496                    (lambda (test)
 497                      (build-cps-term
 498                        ($continue kif src ($values (test))))))))))))
 499
 500     (($ <lexical-set> src name gensym exp)
 501      (convert-arg exp
 502        (lambda (exp)
 503          (match (assq-ref subst gensym)
 504            ((box #t)
 505             (build-cps-term
 506               ($continue k src ($primcall 'box-set! (box exp)))))))))
 507
 508     (($ <seq> src head tail)
 509      (let-fresh (kreceive kseq) (vals)
 510        (build-cps-term
 511          ($letk* ((kseq ($kargs ('vals) (vals)
 512                           ,(convert tail k subst)))
 513                   (kreceive ($kreceive '() 'vals kseq)))
 514            ,(convert head kreceive subst)))))
 515
 516     (($ <let> src names syms vals body)
 517      (let lp ((names names) (syms syms) (vals vals))
 518        (match (list names syms vals)
 519          ((() () ()) (convert body k subst))
 520          (((name . names) (sym . syms) (val . vals))
 521           (let-fresh (kreceive klet) (rest)
 522             (build-cps-term
 523               ($letk* ((klet ($kargs (name 'rest) (sym rest)
 524                                ,(box-bound-var name sym
 525                                                (lp names syms vals))))
 526                        (kreceive ($kreceive (list name) 'rest klet)))
 527                 ,(convert val kreceive subst))))))))
 528
 529     (($ <fix> src names gensyms funs body)
 530      ;; Some letrecs can be contified; that happens later.
 531      (if (current-topbox-scope)
 532          (let-fresh () (self)
 533            (build-cps-term
 534              ($letrec names
 535                       gensyms
 536                       (map (lambda (fun)
 537                              (match (convert fun k subst)
 538                                (($ $continue _ _ (and fun ($ $fun)))
 539                                 fun)))
 540                            funs)
 541                       ,(convert body k subst))))
 542          (let-fresh (kscope) (scope)
 543            (build-cps-term
 544              ($letk ((kscope ($kargs () ()
 545                                ,(parameterize ((current-topbox-scope scope))
 546                                   (convert exp k subst)))))
 547                ,(capture-toplevel-scope src scope kscope))))))
 548
 549     (($ <let-values> src exp
 550         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
 551      (let ((names (append req (if rest (list rest) '()))))
 552        (let-fresh (kreceive kargs) ()
 553          (build-cps-term
 554            ($letk* ((kargs ($kargs names syms
 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 substituted gensyms.  The
 563 usual reason to replace one variable by another is assignment
 564 conversion.  Default argument values is the other reason.
 565
 566 Returns a list of (ORIG-SYM SUBST-SYM BOXED?).  A true value for BOXED?
 567 indicates that the replacement variable is in a box."
 568   (define (box-set-vars exp subst)
 569     (match exp
 570       (($ <lexical-set> src name sym exp)
 571        (if (assq sym subst)
 572            subst
 573            (cons (list sym (gensym "b") #t) subst)))
 574       (_ subst)))
 575   (define (default-args exp subst)
 576     (match exp
 577       (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 578        (fold-formals (lambda (name sym init subst)
 579                        (if init
 580                            (let ((box? (match (assq-ref subst sym)
 581                                          ((box #t) #t)
 582                                          (#f #f)))
 583                                  (subst-sym (gensym (symbol->string name))))
 584                              (cons (list sym subst-sym box?) subst))
 585                            subst))
 586                      subst
 587                      (make-$arity req (or opt '()) rest
 588                                   (if kw (cdr kw) '()) (and kw (car kw)))
 589                      gensyms
 590                      inits))
 591       (_ subst)))
 592   (tree-il-fold box-set-vars default-args '() exp))
 593
 594 (define (cps-convert/thunk exp)
 595   (parameterize ((label-counter 0)
 596                  (var-counter 0))
 597     (let ((src (tree-il-src exp)))
 598       (let-fresh (kinit ktail kclause kbody) (init)
 599         (build-cps-exp
 600           ($fun src '() '()
 601                 (kinit ($kentry init
 602                            (ktail ($ktail))
 603                          ((kclause
 604                            ($kclause ('() '() #f '() #f)
 605                              (kbody ($kargs () ()
 606                                       ,(convert exp ktail
 607                                                 (build-subst exp)))))))))))))))
 608
 609 (define *comp-module* (make-fluid))
 610
 611 (define %warning-passes
 612   `((unused-variable     . ,unused-variable-analysis)
 613     (unused-toplevel     . ,unused-toplevel-analysis)
 614     (unbound-variable    . ,unbound-variable-analysis)
 615     (arity-mismatch      . ,arity-analysis)
 616     (format              . ,format-analysis)))
 617
 618 (define (optimize-tree-il x e opts)
 619   (define warnings
 620     (or (and=> (memq #:warnings opts) cadr)
 621         '()))
 622
 623   ;; Go through the warning passes.
 624   (let ((analyses (filter-map (lambda (kind)
 625                                 (assoc-ref %warning-passes kind))
 626                               warnings)))
 627     (analyze-tree analyses x e))
 628
 629   (optimize x e opts))
 630
 631 (define (fix-prompts exp)
 632   (post-order
 633    (lambda (exp)
 634      (match exp
 635        (($ <prompt> src escape-only? tag body
 636            ($ <lambda> hsrc hmeta
 637               ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
 638         exp)
 639
 640        ;; Eta-convert prompts without inline handlers.
 641        (($ <prompt> src escape-only? tag body handler)
 642         (let ((h (gensym "h "))
 643               (args (gensym "args ")))
 644           (make-let
 645            src (list 'h) (list h) (list handler)
 646            (make-seq
 647             src
 648             (make-conditional
 649              src
 650              (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
 651              (make-void src)
 652              (make-primcall
 653               src 'scm-error
 654               (list
 655                (make-const #f 'wrong-type-arg)
 656                (make-const #f "call-with-prompt")
 657                (make-const #f "Wrong type (expecting procedure): ~S")
 658                (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
 659                (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
 660             (make-prompt
 661              src escape-only? tag body
 662              (make-lambda
 663               src '()
 664               (make-lambda-case
 665                src '() #f 'args #f '() (list args)
 666                (make-primcall
 667                 src 'apply
 668                 (list (make-lexical-ref #f 'h h)
 669                       (make-lexical-ref #f 'args args)))
 670                #f)))))))
 671        (_ exp)))
 672    exp))
 673
 674 (define (compile-cps exp env opts)
 675   (values (cps-convert/thunk
 676            (fix-prompts (optimize-tree-il exp env opts)))
 677           env
 678           env))
 679
 680 ;;; Local Variables:
 681 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
 682 ;;; eval: (put 'convert-args 'scheme-indent-function 1)
 683 ;;; End: