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

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; This pass converts Tree-IL to the continuation-passing style (CPS)
  22 ;;; language.
  23 ;;;
  24 ;;; CPS is a lower-level representation than Tree-IL.  Converting to
  25 ;;; CPS, beyond adding names for all control points and all values,
  26 ;;; simplifies expressions in the following ways, among others:
  27 ;;;
  28 ;;;   * Fixing the order of evaluation.
  29 ;;;
  30 ;;;   * Converting assigned variables to boxed variables.
  31 ;;;
  32 ;;;   * Requiring that Scheme's <letrec> has already been lowered to
  33 ;;;     <fix>.
  34 ;;;
  35 ;;;   * Inlining default-value initializers into lambda-case
  36 ;;;     expressions.
  37 ;;;
  38 ;;;   * Inlining prompt bodies.
  39 ;;;
  40 ;;;   * Turning toplevel and module references into primcalls.  This
  41 ;;;     involves explicitly modelling the "scope" of toplevel lookups
  42 ;;;     (indicating the module with respect to which toplevel bindings
  43 ;;;     are resolved).
  44 ;;;
  45 ;;; The utility of CPS is that it gives a name to everything: every
  46 ;;; intermediate value, and every control point (continuation).  As such
  47 ;;; it is more verbose than Tree-IL, but at the same time more simple as
  48 ;;; the number of concepts is reduced.
  49 ;;;
  50 ;;; Code:
  51
  52 (define-module (language tree-il compile-cps)
  53   #:use-module (ice-9 match)
  54   #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
  55   #:use-module (srfi srfi-26)
  56   #:use-module ((system foreign) #:select (make-pointer pointer->scm))
  57   #:use-module (language cps)
  58   #:use-module (language cps primitives)
  59   #:use-module (language tree-il analyze)
  60   #:use-module (language tree-il optimize)
  61   #:use-module ((language tree-il)
  62                 #:select
  63                 (<void>
  64                  <const> <primitive-ref> <lexical-ref> <lexical-set>
  65                  <module-ref> <module-set>
  66                  <toplevel-ref> <toplevel-set> <toplevel-define>
  67                  <conditional>
  68                  <call> <primcall>
  69                  <seq>
  70                  <lambda> <lambda-case>
  71                  <let> <letrec> <fix> <let-values>
  72                  <prompt> <abort>
  73                  make-conditional make-const make-primcall
  74                  tree-il-src
  75                  tree-il-fold))
  76   #:export (compile-cps))
  77
  78 ;;; Guile's semantics are that a toplevel lambda captures a reference on
  79 ;;; the current module, and that all contained lambdas use that module
  80 ;;; to resolve toplevel variables.  This parameter tracks whether or not
  81 ;;; we are in a toplevel lambda.  If we are in a lambda, the parameter
  82 ;;; is bound to a fresh name identifying the module that was current
  83 ;;; when the toplevel lambda is defined.
  84 ;;;
  85 ;;; This is more complicated than it need be.  Ideally we should resolve
  86 ;;; all toplevel bindings to bindings from specific modules, unless the
  87 ;;; binding is unbound.  This is always valid if the compilation unit
  88 ;;; sets the module explicitly, as when compiling a module, but it
  89 ;;; doesn't work for files auto-compiled for use with `load'.
  90 ;;;
  91 (define current-topbox-scope (make-parameter #f))
  92
  93 (define (toplevel-box src name bound? val-proc)
  94   (let-gensyms (name-sym bound?-sym kbox box)
  95     (build-cps-term
  96       ($letconst (('name name-sym name)
  97                   ('bound? bound?-sym bound?))
  98         ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
  99           ,(match (current-topbox-scope)
 100              (#f
 101               (build-cps-term
 102                 ($continue kbox
 103                   ($primcall 'resolve
 104                              (name-sym bound?-sym)))))
 105              (scope
 106               (let-gensyms (scope-sym)
 107                 (build-cps-term
 108                   ($letconst (('scope scope-sym scope))
 109                     ($continue kbox
 110                       ($primcall 'cached-toplevel-box
 111                                  (scope-sym name-sym bound?-sym)))))))))))))
 112
 113 (define (module-box src module name public? bound? val-proc)
 114   (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
 115     (build-cps-term
 116       ($letconst (('module module-sym module)
 117                   ('name name-sym name)
 118                   ('public? public?-sym public?)
 119                   ('bound? bound?-sym bound?))
 120         ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
 121           ($continue kbox
 122             ($primcall 'cached-module-box
 123                        (module-sym name-sym public?-sym bound?-sym))))))))
 124
 125 (define (capture-toplevel-scope src scope k)
 126   (let-gensyms (module scope-sym kmodule)
 127     (build-cps-term
 128       ($letconst (('scope scope-sym scope))
 129         ($letk ((kmodule src ($kargs ('module) (module)
 130                                ($continue k
 131                                  ($primcall 'cache-current-module!
 132                                             (module scope-sym))))))
 133           ($continue kmodule
 134             ($primcall 'current-module ())))))))
 135
 136 (define (fold-formals proc seed arity gensyms inits)
 137   (match arity
 138     (($ $arity req opt rest kw allow-other-keys?)
 139      (let ()
 140        (define (fold-req names gensyms seed)
 141          (match names
 142            (() (fold-opt opt gensyms inits seed))
 143            ((name . names)
 144             (proc name (car gensyms) #f
 145                   (fold-req names (cdr gensyms) seed)))))
 146        (define (fold-opt names gensyms inits seed)
 147          (match names
 148            (() (fold-rest rest gensyms inits seed))
 149            ((name . names)
 150             (proc name (car gensyms) (car inits)
 151                   (fold-opt names (cdr gensyms) (cdr inits) seed)))))
 152        (define (fold-rest rest gensyms inits seed)
 153          (match rest
 154            (#f (fold-kw kw gensyms inits seed))
 155            (name (proc name (car gensyms) #f
 156                        (fold-kw kw (cdr gensyms) inits seed)))))
 157        (define (fold-kw kw gensyms inits seed)
 158          (match kw
 159            (()
 160             (unless (null? gensyms)
 161               (error "too many gensyms"))
 162             (unless (null? inits)
 163               (error "too many inits"))
 164             seed)
 165            (((key name var) . kw)
 166             (unless (eq? var (car gensyms))
 167               (error "unexpected keyword arg order"))
 168             (proc name var (car inits)
 169                   (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
 170        (fold-req req gensyms seed)))))
 171
 172 (define (unbound? src sym kt kf)
 173   (define tc8-iflag 4)
 174   (define unbound-val 9)
 175   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
 176   (let-gensyms (unbound ktest)
 177     (build-cps-term
 178       ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
 179         ($letk ((ktest src ($kif kt kf)))
 180           ($continue ktest
 181             ($primcall 'eq? (sym unbound))))))))
 182
 183 (define (init-default-value name sym subst init body)
 184   (match (assq-ref subst sym)
 185     ((subst-sym box?)
 186      (let ((src (tree-il-src init)))
 187        (define (maybe-box k make-body)
 188          (if box?
 189              (let-gensyms (kbox phi)
 190                (build-cps-term
 191                  ($letk ((kbox src ($kargs (name) (phi)
 192                                      ($continue k ($primcall 'box (phi))))))
 193                    ,(make-body kbox))))
 194              (make-body k)))
 195        (let-gensyms (knext kbound kunbound)
 196          (build-cps-term
 197            ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
 198              ,(maybe-box
 199                knext
 200                (lambda (k)
 201                  (build-cps-term
 202                    ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
 203                            (kunbound src ($kargs () () ,(convert init k subst))))
 204                      ,(unbound? src sym kunbound kbound))))))))))))
 205
 206 ;; exp k-name alist -> term
 207 (define (convert exp k subst)
 208   ;; exp (v-name -> term) -> term
 209   (define (convert-arg exp k)
 210     (match exp
 211       (($ <lexical-ref> src name sym)
 212        (match (assq-ref subst sym)
 213          ((box #t)
 214           (let-gensyms (kunboxed unboxed)
 215             (build-cps-term
 216               ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
 217                 ($continue kunboxed ($primcall 'box-ref (box)))))))
 218          ((subst #f) (k subst))
 219          (#f (k sym))))
 220       (else
 221        (let ((src (tree-il-src exp)))
 222          (let-gensyms (karg arg)
 223            (build-cps-term
 224              ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
 225                ,(convert exp karg subst))))))))
 226   ;; (exp ...) ((v-name ...) -> term) -> term
 227   (define (convert-args exps k)
 228     (match exps
 229       (() (k '()))
 230       ((exp . exps)
 231        (convert-arg exp
 232          (lambda (name)
 233            (convert-args exps
 234              (lambda (names)
 235                (k (cons name names)))))))))
 236   (define (box-bound-var name sym body)
 237     (match (assq-ref subst sym)
 238       ((box #t)
 239        (let-gensyms (k)
 240          (build-cps-term
 241            ($letk ((k #f ($kargs (name) (box) ,body)))
 242              ($continue k ($primcall 'box (sym)))))))
 243       (else body)))
 244
 245   (match exp
 246     (($ <lexical-ref> src name sym)
 247      (match (assq-ref subst sym)
 248        ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
 249        ((subst #f) (build-cps-term ($continue k ($var subst))))
 250        (#f (build-cps-term ($continue k ($var sym))))))
 251
 252     (($ <void> src)
 253      (build-cps-term ($continue k ($void))))
 254
 255     (($ <const> src exp)
 256      (build-cps-term ($continue k ($const exp))))
 257
 258     (($ <primitive-ref> src name)
 259      (build-cps-term ($continue k ($prim name))))
 260
 261     (($ <lambda> fun-src meta body)
 262      (let ()
 263        (define (convert-clauses body ktail)
 264          (match body
 265            (#f '())
 266            (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 267             (let* ((arity (make-$arity req (or opt '()) rest
 268                                        (if kw (cdr kw) '()) (and kw (car kw))))
 269                    (names (fold-formals (lambda (name sym init names)
 270                                           (cons name names))
 271                                         '()
 272                                         arity gensyms inits)))
 273               (cons
 274                (let-gensyms (kclause kargs)
 275                  (build-cps-cont
 276                    (kclause
 277                     src
 278                     ($kclause ,arity
 279                       (kargs
 280                        src
 281                        ($kargs names gensyms
 282                          ,(fold-formals
 283                            (lambda (name sym init body)
 284                              (if init
 285                                  (init-default-value name sym subst init body)
 286                                  (box-bound-var name sym body)))
 287                            (convert body ktail subst)
 288                            arity gensyms inits)))))))
 289                (convert-clauses alternate ktail))))))
 290        (if (current-topbox-scope)
 291            (let-gensyms (kentry self ktail)
 292              (build-cps-term
 293                ($continue k
 294                  ($fun meta '()
 295                    (kentry fun-src
 296                            ($kentry self (ktail #f ($ktail))
 297                                     ,(convert-clauses body ktail)))))))
 298            (let-gensyms (scope kscope)
 299              (build-cps-term
 300                ($letk ((kscope fun-src
 301                                ($kargs () ()
 302                                  ,(parameterize ((current-topbox-scope scope))
 303                                     (convert exp k subst)))))
 304                  ,(capture-toplevel-scope fun-src scope kscope)))))))
 305
 306     (($ <module-ref> src mod name public?)
 307      (module-box
 308       src mod name public? #t
 309       (lambda (box)
 310         (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 311
 312     (($ <module-set> src mod name public? exp)
 313      (convert-arg exp
 314        (lambda (val)
 315          (module-box
 316           src mod name public? #f
 317           (lambda (box)
 318             (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 319
 320     (($ <toplevel-ref> src name)
 321      (toplevel-box
 322       src name #t
 323       (lambda (box)
 324         (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 325
 326     (($ <toplevel-set> src name exp)
 327      (convert-arg exp
 328        (lambda (val)
 329          (toplevel-box
 330           src name #f
 331           (lambda (box)
 332             (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 333
 334     (($ <toplevel-define> src name exp)
 335      (convert-arg exp
 336        (lambda (val)
 337          (let-gensyms (kname name-sym)
 338            (build-cps-term
 339              ($letconst (('name name-sym name))
 340                ($continue k ($primcall 'define! (name-sym val)))))))))
 341
 342     (($ <call> src proc args)
 343      (convert-args (cons proc args)
 344        (match-lambda
 345         ((proc . args)
 346          (build-cps-term ($continue k ($call proc args)))))))
 347
 348     (($ <primcall> src name args)
 349      (case name
 350        ((list)
 351         (convert (fold-right (lambda (elem tail)
 352                                (make-primcall src 'cons
 353                                               (list elem tail)))
 354                              (make-const src '())
 355                              args)
 356                  k subst))
 357        (else
 358         (if (branching-primitive? name)
 359             (convert (make-conditional src exp (make-const #f #t)
 360                                        (make-const #f #f))
 361                      k subst)
 362             (convert-args args
 363               (lambda (args)
 364                 (if (eq? name 'values)
 365                     (build-cps-term ($continue k ($values args)))
 366                     (build-cps-term ($continue k ($primcall name args))))))))))
 367
 368     ;; Prompts with inline handlers.
 369     (($ <prompt> src escape-only? tag body
 370         ($ <lambda> hsrc hmeta
 371            ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
 372      ;; Handler:
 373      ;;   khargs: check args returned to handler, -> khbody
 374      ;;   khbody: the handler, -> k
 375      ;;
 376      ;; Post-body:
 377      ;;   krest: collect return vals from body to list, -> kpop
 378      ;;   kpop: pop the prompt, -> kprim
 379      ;;   kprim: load the values primitive, -> kret
 380      ;;   kret: (apply values rvals), -> k
 381      ;;
 382      ;; Escape prompts evaluate the body with the continuation of krest.
 383      ;; Otherwise we do a no-inline call to body, continuing to krest.
 384      (convert-arg tag
 385        (lambda (tag)
 386          (let ((hnames (append hreq (if hrest (list hrest) '()))))
 387            (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
 388              (build-cps-term
 389                ($letk* ((khbody hsrc ($kargs hnames hsyms
 390                                        ,(fold box-bound-var
 391                                               (convert hbody k subst)
 392                                               hnames hsyms)))
 393                         (khargs hsrc ($ktrunc hreq hrest khbody))
 394                         (kpop src
 395                               ($kargs ('rest) (vals)
 396                                 ($letk ((kret
 397                                          src
 398                                          ($kargs () ()
 399                                            ($letk ((kprim
 400                                                     src
 401                                                     ($kargs ('prim) (prim)
 402                                                       ($continue k
 403                                                         ($primcall 'apply
 404                                                                    (prim vals))))))
 405                                              ($continue kprim
 406                                                ($prim 'values))))))
 407                                   ($continue kret
 408                                     ($primcall 'pop-prompt ())))))
 409                         (krest src ($ktrunc '() 'rest kpop)))
 410                  ,(if escape-only?
 411                       (build-cps-term
 412                         ($letk ((kbody (tree-il-src body)
 413                                        ($kargs () ()
 414                                          ,(convert body krest subst))))
 415                           ($continue kbody ($prompt #t tag khargs))))
 416                       (convert-arg body
 417                         (lambda (thunk)
 418                           (build-cps-term
 419                             ($letk ((kbody (tree-il-src body)
 420                                            ($kargs () ()
 421                                              ($continue krest
 422                                                ($primcall 'call-thunk/no-inline
 423                                                           (thunk))))))
 424                               ($continue kbody
 425                                 ($prompt #f tag khargs))))))))))))))
 426
 427     ;; Eta-convert prompts without inline handlers.
 428     (($ <prompt> src escape-only? tag body handler)
 429      (convert-args (list tag body handler)
 430        (lambda (args)
 431          (build-cps-term
 432            ($continue k ($primcall 'call-with-prompt args))))))
 433
 434     (($ <abort> src tag args tail)
 435      (convert-args (append (list tag) args (list tail))
 436        (lambda (args*)
 437          (build-cps-term ($continue k ($primcall 'abort args*))))))
 438
 439     (($ <conditional> src test consequent alternate)
 440      (let-gensyms (kif kt kf)
 441        (build-cps-term
 442          ($letk* ((kt (tree-il-src consequent) ($kargs () ()
 443                                                  ,(convert consequent k subst)))
 444                   (kf (tree-il-src alternate) ($kargs () ()
 445                                                 ,(convert alternate k subst)))
 446                   (kif src ($kif kt kf)))
 447            ,(match test
 448               (($ <primcall> src (? branching-primitive? name) args)
 449                (convert-args args
 450                  (lambda (args)
 451                    (build-cps-term ($continue kif ($primcall name args))))))
 452               (_ (convert-arg test
 453                    (lambda (test)
 454                      (build-cps-term ($continue kif ($var test)))))))))))
 455
 456     (($ <lexical-set> src name gensym exp)
 457      (convert-arg exp
 458        (lambda (exp)
 459          (match (assq-ref subst gensym)
 460            ((box #t)
 461             (build-cps-term
 462               ($continue k ($primcall 'box-set! (box exp)))))))))
 463
 464     (($ <seq> src head tail)
 465      (let-gensyms (ktrunc kseq)
 466        (build-cps-term
 467          ($letk* ((kseq (tree-il-src tail) ($kargs () ()
 468                                              ,(convert tail k subst)))
 469                   (ktrunc src ($ktrunc '() #f kseq)))
 470            ,(convert head ktrunc subst)))))
 471
 472     (($ <let> src names syms vals body)
 473      (let lp ((names names) (syms syms) (vals vals))
 474        (match (list names syms vals)
 475          ((() () ()) (convert body k subst))
 476          (((name . names) (sym . syms) (val . vals))
 477           (let-gensyms (klet)
 478             (build-cps-term
 479               ($letk ((klet src ($kargs (name) (sym)
 480                                   ,(box-bound-var name sym
 481                                                   (lp names syms vals)))))
 482                 ,(convert val klet subst))))))))
 483
 484     (($ <fix> src names gensyms funs body)
 485      ;; Some letrecs can be contified; that happens later.
 486      (if (current-topbox-scope)
 487          (let-gensyms (self)
 488            (build-cps-term
 489              ($letrec names
 490                       gensyms
 491                       (map (lambda (fun)
 492                              (match (convert fun k subst)
 493                                (($ $continue _ (and fun ($ $fun)))
 494                                 fun)))
 495                            funs)
 496                       ,(convert body k subst))))
 497          (let-gensyms (scope kscope)
 498            (build-cps-term
 499              ($letk ((kscope src ($kargs () ()
 500                                    ,(parameterize ((current-topbox-scope scope))
 501                                       (convert exp k subst)))))
 502                ,(capture-toplevel-scope src scope kscope))))))
 503
 504     (($ <let-values> src exp
 505         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
 506      (let ((names (append req (if rest (list rest) '()))))
 507        (let-gensyms (ktrunc kargs)
 508          (build-cps-term
 509            ($letk* ((kargs src ($kargs names syms
 510                                  ,(fold box-bound-var
 511                                         (convert body k subst)
 512                                         names syms)))
 513                     (ktrunc src ($ktrunc req rest kargs)))
 514              ,(convert exp ktrunc subst))))))))
 515
 516 (define (build-subst exp)
 517   "Compute a mapping from lexical gensyms to substituted gensyms.  The
 518 usual reason to replace one variable by another is assignment
 519 conversion.  Default argument values is the other reason.
 520
 521 Returns a list of (ORIG-SYM SUBST-SYM BOXED?).  A true value for BOXED?
 522 indicates that the replacement variable is in a box."
 523   (define (box-set-vars exp subst)
 524     (match exp
 525       (($ <lexical-set> src name sym exp)
 526        (if (assq sym subst)
 527            subst
 528            (cons (list sym (gensym "b") #t) subst)))
 529       (_ subst)))
 530   (define (default-args exp subst)
 531     (match exp
 532       (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
 533        (fold-formals (lambda (name sym init subst)
 534                        (if init
 535                            (let ((box? (match (assq-ref subst sym)
 536                                          ((box #t) #t)
 537                                          (#f #f)))
 538                                  (subst-sym (gensym (symbol->string name))))
 539                              (cons (list sym subst-sym box?) subst))
 540                            subst))
 541                      subst
 542                      (make-$arity req (or opt '()) rest
 543                                   (if kw (cdr kw) '()) (and kw (car kw)))
 544                      gensyms
 545                      inits))
 546       (_ subst)))
 547   (tree-il-fold box-set-vars default-args '() exp))
 548
 549 (define (cps-convert/thunk exp)
 550   (let ((src (tree-il-src exp)))
 551     (let-gensyms (kinit init ktail kclause kbody)
 552       (build-cps-exp
 553         ($fun '() '()
 554           (kinit src
 555                  ($kentry init
 556                    (ktail #f ($ktail))
 557                    ((kclause src
 558                             ($kclause ('() '() #f '() #f)
 559                               (kbody src
 560                                      ($kargs () ()
 561                                        ,(convert exp ktail
 562                                                  (build-subst exp))))))))))))))
 563
 564 (define *comp-module* (make-fluid))
 565
 566 (define %warning-passes
 567   `((unused-variable     . ,unused-variable-analysis)
 568     (unused-toplevel     . ,unused-toplevel-analysis)
 569     (unbound-variable    . ,unbound-variable-analysis)
 570     (arity-mismatch      . ,arity-analysis)
 571     (format              . ,format-analysis)))
 572
 573 (define (optimize-tree-il x e opts)
 574   (define warnings
 575     (or (and=> (memq #:warnings opts) cadr)
 576         '()))
 577
 578   ;; Go through the warning passes.
 579   (let ((analyses (filter-map (lambda (kind)
 580                                 (assoc-ref %warning-passes kind))
 581                               warnings)))
 582     (analyze-tree analyses x e))
 583
 584   (optimize x e opts))
 585
 586 (define (compile-cps exp env opts)
 587   (values (cps-convert/thunk (optimize-tree-il exp env opts))
 588           env
 589           env))
 590
 591 ;;; Local Variables:
 592 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
 593 ;;; eval: (put 'convert-args 'scheme-indent-function 1)
 594 ;;; End: