| 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) #:hide (let-gensyms)) |
| 62 | #:export (compile-cps)) |
| 63 | |
| 64 | ;;; Guile's semantics are that a toplevel lambda captures a reference on |
| 65 | ;;; the current module, and that all contained lambdas use that module |
| 66 | ;;; to resolve toplevel variables. This parameter tracks whether or not |
| 67 | ;;; we are in a toplevel lambda. If we are in a lambda, the parameter |
| 68 | ;;; is bound to a fresh name identifying the module that was current |
| 69 | ;;; when the toplevel lambda is defined. |
| 70 | ;;; |
| 71 | ;;; This is more complicated than it need be. Ideally we should resolve |
| 72 | ;;; all toplevel bindings to bindings from specific modules, unless the |
| 73 | ;;; binding is unbound. This is always valid if the compilation unit |
| 74 | ;;; sets the module explicitly, as when compiling a module, but it |
| 75 | ;;; doesn't work for files auto-compiled for use with `load'. |
| 76 | ;;; |
| 77 | (define current-topbox-scope (make-parameter #f)) |
| 78 | |
| 79 | (define (toplevel-box src name bound? val-proc) |
| 80 | (let-gensyms (name-sym bound?-sym kbox box) |
| 81 | (build-cps-term |
| 82 | ($letconst (('name name-sym name) |
| 83 | ('bound? bound?-sym bound?)) |
| 84 | ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) |
| 85 | ,(match (current-topbox-scope) |
| 86 | (#f |
| 87 | (build-cps-term |
| 88 | ($continue kbox src |
| 89 | ($primcall 'resolve |
| 90 | (name-sym bound?-sym))))) |
| 91 | (scope |
| 92 | (let-gensyms (scope-sym) |
| 93 | (build-cps-term |
| 94 | ($letconst (('scope scope-sym scope)) |
| 95 | ($continue kbox src |
| 96 | ($primcall 'cached-toplevel-box |
| 97 | (scope-sym name-sym bound?-sym))))))))))))) |
| 98 | |
| 99 | (define (module-box src module name public? bound? val-proc) |
| 100 | (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box) |
| 101 | (build-cps-term |
| 102 | ($letconst (('module module-sym module) |
| 103 | ('name name-sym name) |
| 104 | ('public? public?-sym public?) |
| 105 | ('bound? bound?-sym bound?)) |
| 106 | ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) |
| 107 | ($continue kbox src |
| 108 | ($primcall 'cached-module-box |
| 109 | (module-sym name-sym public?-sym bound?-sym)))))))) |
| 110 | |
| 111 | (define (capture-toplevel-scope src scope k) |
| 112 | (let-gensyms (module scope-sym kmodule) |
| 113 | (build-cps-term |
| 114 | ($letconst (('scope scope-sym scope)) |
| 115 | ($letk ((kmodule ($kargs ('module) (module) |
| 116 | ($continue k src |
| 117 | ($primcall 'cache-current-module! |
| 118 | (module scope-sym)))))) |
| 119 | ($continue kmodule src |
| 120 | ($primcall 'current-module ()))))))) |
| 121 | |
| 122 | (define (fold-formals proc seed arity gensyms inits) |
| 123 | (match arity |
| 124 | (($ $arity req opt rest kw allow-other-keys?) |
| 125 | (let () |
| 126 | (define (fold-req names gensyms seed) |
| 127 | (match names |
| 128 | (() (fold-opt opt gensyms inits seed)) |
| 129 | ((name . names) |
| 130 | (proc name (car gensyms) #f |
| 131 | (fold-req names (cdr gensyms) seed))))) |
| 132 | (define (fold-opt names gensyms inits seed) |
| 133 | (match names |
| 134 | (() (fold-rest rest gensyms inits seed)) |
| 135 | ((name . names) |
| 136 | (proc name (car gensyms) (car inits) |
| 137 | (fold-opt names (cdr gensyms) (cdr inits) seed))))) |
| 138 | (define (fold-rest rest gensyms inits seed) |
| 139 | (match rest |
| 140 | (#f (fold-kw kw gensyms inits seed)) |
| 141 | (name (proc name (car gensyms) #f |
| 142 | (fold-kw kw (cdr gensyms) inits seed))))) |
| 143 | (define (fold-kw kw gensyms inits seed) |
| 144 | (match kw |
| 145 | (() |
| 146 | (unless (null? gensyms) |
| 147 | (error "too many gensyms")) |
| 148 | (unless (null? inits) |
| 149 | (error "too many inits")) |
| 150 | seed) |
| 151 | (((key name var) . kw) |
| 152 | (unless (eq? var (car gensyms)) |
| 153 | (error "unexpected keyword arg order")) |
| 154 | (proc name var (car inits) |
| 155 | (fold-kw kw (cdr gensyms) (cdr inits) seed))))) |
| 156 | (fold-req req gensyms seed))))) |
| 157 | |
| 158 | (define (unbound? src sym kt kf) |
| 159 | (define tc8-iflag 4) |
| 160 | (define unbound-val 9) |
| 161 | (define unbound-bits (logior (ash unbound-val 8) tc8-iflag)) |
| 162 | (let-gensyms (unbound ktest) |
| 163 | (build-cps-term |
| 164 | ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits)))) |
| 165 | ($letk ((ktest ($kif kt kf))) |
| 166 | ($continue ktest src |
| 167 | ($primcall 'eq? (sym unbound)))))))) |
| 168 | |
| 169 | (define (init-default-value name sym subst init body) |
| 170 | (match (assq-ref subst sym) |
| 171 | ((subst-sym box?) |
| 172 | (let ((src (tree-il-src init))) |
| 173 | (define (maybe-box k make-body) |
| 174 | (if box? |
| 175 | (let-gensyms (kbox phi) |
| 176 | (build-cps-term |
| 177 | ($letk ((kbox ($kargs (name) (phi) |
| 178 | ($continue k src ($primcall 'box (phi)))))) |
| 179 | ,(make-body kbox)))) |
| 180 | (make-body k))) |
| 181 | (let-gensyms (knext kbound kunbound) |
| 182 | (build-cps-term |
| 183 | ($letk ((knext ($kargs (name) (subst-sym) ,body))) |
| 184 | ,(maybe-box |
| 185 | knext |
| 186 | (lambda (k) |
| 187 | (build-cps-term |
| 188 | ($letk ((kbound ($kargs () () ($continue k src ($var sym)))) |
| 189 | (kunbound ($kargs () () ,(convert init k subst)))) |
| 190 | ,(unbound? src sym kunbound kbound)))))))))))) |
| 191 | |
| 192 | ;; exp k-name alist -> term |
| 193 | (define (convert exp k subst) |
| 194 | ;; exp (v-name -> term) -> term |
| 195 | (define (convert-arg exp k) |
| 196 | (match exp |
| 197 | (($ <lexical-ref> src name sym) |
| 198 | (match (assq-ref subst sym) |
| 199 | ((box #t) |
| 200 | (let-gensyms (kunboxed unboxed) |
| 201 | (build-cps-term |
| 202 | ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed)))) |
| 203 | ($continue kunboxed src ($primcall 'box-ref (box))))))) |
| 204 | ((subst #f) (k subst)) |
| 205 | (#f (k sym)))) |
| 206 | (else |
| 207 | (let-gensyms (karg arg) |
| 208 | (build-cps-term |
| 209 | ($letk ((karg ($kargs ('arg) (arg) ,(k arg)))) |
| 210 | ,(convert exp karg subst))))))) |
| 211 | ;; (exp ...) ((v-name ...) -> term) -> term |
| 212 | (define (convert-args exps k) |
| 213 | (match exps |
| 214 | (() (k '())) |
| 215 | ((exp . exps) |
| 216 | (convert-arg exp |
| 217 | (lambda (name) |
| 218 | (convert-args exps |
| 219 | (lambda (names) |
| 220 | (k (cons name names))))))))) |
| 221 | (define (box-bound-var name sym body) |
| 222 | (match (assq-ref subst sym) |
| 223 | ((box #t) |
| 224 | (let-gensyms (k) |
| 225 | (build-cps-term |
| 226 | ($letk ((k ($kargs (name) (box) ,body))) |
| 227 | ($continue k #f ($primcall 'box (sym))))))) |
| 228 | (else body))) |
| 229 | |
| 230 | (match exp |
| 231 | (($ <lexical-ref> src name sym) |
| 232 | (match (assq-ref subst sym) |
| 233 | ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box))))) |
| 234 | ((subst #f) (build-cps-term ($continue k src ($var subst)))) |
| 235 | (#f (build-cps-term ($continue k src ($var sym)))))) |
| 236 | |
| 237 | (($ <void> src) |
| 238 | (build-cps-term ($continue k src ($void)))) |
| 239 | |
| 240 | (($ <const> src exp) |
| 241 | (build-cps-term ($continue k src ($const exp)))) |
| 242 | |
| 243 | (($ <primitive-ref> src name) |
| 244 | (build-cps-term ($continue k src ($prim name)))) |
| 245 | |
| 246 | (($ <lambda> fun-src meta body) |
| 247 | (let () |
| 248 | (define (convert-clauses body ktail) |
| 249 | (match body |
| 250 | (#f '()) |
| 251 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) |
| 252 | (let* ((arity (make-$arity req (or opt '()) rest |
| 253 | (if kw (cdr kw) '()) (and kw (car kw)))) |
| 254 | (names (fold-formals (lambda (name sym init names) |
| 255 | (cons name names)) |
| 256 | '() |
| 257 | arity gensyms inits))) |
| 258 | (cons |
| 259 | (let-gensyms (kclause kargs) |
| 260 | (build-cps-cont |
| 261 | (kclause |
| 262 | ($kclause ,arity |
| 263 | (kargs |
| 264 | ($kargs names gensyms |
| 265 | ,(fold-formals |
| 266 | (lambda (name sym init body) |
| 267 | (if init |
| 268 | (init-default-value name sym subst init body) |
| 269 | (box-bound-var name sym body))) |
| 270 | (convert body ktail subst) |
| 271 | arity gensyms inits))))))) |
| 272 | (convert-clauses alternate ktail)))))) |
| 273 | (if (current-topbox-scope) |
| 274 | (let-gensyms (kentry self ktail) |
| 275 | (build-cps-term |
| 276 | ($continue k fun-src |
| 277 | ($fun fun-src meta '() |
| 278 | (kentry ($kentry self (ktail ($ktail)) |
| 279 | ,(convert-clauses body ktail))))))) |
| 280 | (let-gensyms (scope kscope) |
| 281 | (build-cps-term |
| 282 | ($letk ((kscope ($kargs () () |
| 283 | ,(parameterize ((current-topbox-scope scope)) |
| 284 | (convert exp k subst))))) |
| 285 | ,(capture-toplevel-scope fun-src scope kscope))))))) |
| 286 | |
| 287 | (($ <module-ref> src mod name public?) |
| 288 | (module-box |
| 289 | src mod name public? #t |
| 290 | (lambda (box) |
| 291 | (build-cps-term ($continue k src ($primcall 'box-ref (box))))))) |
| 292 | |
| 293 | (($ <module-set> src mod name public? exp) |
| 294 | (convert-arg exp |
| 295 | (lambda (val) |
| 296 | (module-box |
| 297 | src mod name public? #f |
| 298 | (lambda (box) |
| 299 | (build-cps-term |
| 300 | ($continue k src ($primcall 'box-set! (box val))))))))) |
| 301 | |
| 302 | (($ <toplevel-ref> src name) |
| 303 | (toplevel-box |
| 304 | src name #t |
| 305 | (lambda (box) |
| 306 | (build-cps-term ($continue k src ($primcall 'box-ref (box))))))) |
| 307 | |
| 308 | (($ <toplevel-set> src name exp) |
| 309 | (convert-arg exp |
| 310 | (lambda (val) |
| 311 | (toplevel-box |
| 312 | src name #f |
| 313 | (lambda (box) |
| 314 | (build-cps-term |
| 315 | ($continue k src ($primcall 'box-set! (box val))))))))) |
| 316 | |
| 317 | (($ <toplevel-define> src name exp) |
| 318 | (convert-arg exp |
| 319 | (lambda (val) |
| 320 | (let-gensyms (kname name-sym) |
| 321 | (build-cps-term |
| 322 | ($letconst (('name name-sym name)) |
| 323 | ($continue k src ($primcall 'define! (name-sym val))))))))) |
| 324 | |
| 325 | (($ <call> src proc args) |
| 326 | (convert-args (cons proc args) |
| 327 | (match-lambda |
| 328 | ((proc . args) |
| 329 | (build-cps-term ($continue k src ($call proc args))))))) |
| 330 | |
| 331 | (($ <primcall> src name args) |
| 332 | (cond |
| 333 | ((branching-primitive? name) |
| 334 | (convert (make-conditional src exp (make-const #f #t) |
| 335 | (make-const #f #f)) |
| 336 | k subst)) |
| 337 | ((and (eq? name 'vector) |
| 338 | (and-map (match-lambda |
| 339 | ((or ($ <const>) |
| 340 | ($ <void>) |
| 341 | ($ <lambda>) |
| 342 | ($ <lexical-ref>)) #t) |
| 343 | (_ #f)) |
| 344 | args)) |
| 345 | ;; Some macros generate calls to "vector" with like 300 |
| 346 | ;; arguments. Since we eventually compile to make-vector and |
| 347 | ;; vector-set!, it reduces live variable pressure to allocate the |
| 348 | ;; vector first, then set values as they are produced, if we can |
| 349 | ;; prove that no value can capture the continuation. (More on |
| 350 | ;; that caveat here: |
| 351 | ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time). |
| 352 | ;; |
| 353 | ;; Normally we would do this transformation in the compiler, but |
| 354 | ;; it's quite tricky there and quite easy here, so hold your nose |
| 355 | ;; while we drop some smelly code. |
| 356 | (convert (let ((len (length args))) |
| 357 | (let-gensyms (v) |
| 358 | (make-let src |
| 359 | (list 'v) |
| 360 | (list v) |
| 361 | (list (make-primcall src 'make-vector |
| 362 | (list (make-const #f len) |
| 363 | (make-const #f #f)))) |
| 364 | (fold (lambda (arg n tail) |
| 365 | (make-seq |
| 366 | src |
| 367 | (make-primcall |
| 368 | src 'vector-set! |
| 369 | (list (make-lexical-ref src 'v v) |
| 370 | (make-const #f n) |
| 371 | arg)) |
| 372 | tail)) |
| 373 | (make-lexical-ref src 'v v) |
| 374 | (reverse args) (reverse (iota len)))))) |
| 375 | k subst)) |
| 376 | ((and (eq? name 'list) |
| 377 | (and-map (match-lambda |
| 378 | ((or ($ <const>) |
| 379 | ($ <void>) |
| 380 | ($ <lambda>) |
| 381 | ($ <lexical-ref>)) #t) |
| 382 | (_ #f)) |
| 383 | args)) |
| 384 | ;; The same situation occurs with "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-gensyms (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 | (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody) |
| 425 | (build-cps-term |
| 426 | ;; FIXME: Attach hsrc to $ktrunc. |
| 427 | ($letk* ((khbody ($kargs hnames hsyms |
| 428 | ,(fold box-bound-var |
| 429 | (convert hbody k subst) |
| 430 | hnames hsyms))) |
| 431 | (khargs ($ktrunc hreq hrest khbody)) |
| 432 | (kpop ($kargs ('rest) (vals) |
| 433 | ($letk ((kret |
| 434 | ($kargs () () |
| 435 | ($letk ((kprim |
| 436 | ($kargs ('prim) (prim) |
| 437 | ($continue k src |
| 438 | ($primcall 'apply |
| 439 | (prim vals)))))) |
| 440 | ($continue kprim src |
| 441 | ($prim 'values)))))) |
| 442 | ($continue kret src |
| 443 | ($primcall 'unwind ()))))) |
| 444 | (krest ($ktrunc '() 'rest kpop))) |
| 445 | ,(if escape-only? |
| 446 | (build-cps-term |
| 447 | ($letk ((kbody ($kargs () () |
| 448 | ,(convert body krest subst)))) |
| 449 | ($continue kbody src ($prompt #t tag khargs kpop)))) |
| 450 | (convert-arg body |
| 451 | (lambda (thunk) |
| 452 | (build-cps-term |
| 453 | ($letk ((kbody ($kargs () () |
| 454 | ($continue krest (tree-il-src body) |
| 455 | ($primcall 'call-thunk/no-inline |
| 456 | (thunk)))))) |
| 457 | ($continue kbody (tree-il-src body) |
| 458 | ($prompt #f tag khargs kpop)))))))))))))) |
| 459 | |
| 460 | ;; Eta-convert prompts without inline handlers. |
| 461 | (($ <prompt> src escape-only? tag body handler) |
| 462 | (let-gensyms (h args) |
| 463 | (convert |
| 464 | (make-let |
| 465 | src (list 'h) (list h) (list handler) |
| 466 | (make-seq |
| 467 | src |
| 468 | (make-conditional |
| 469 | src |
| 470 | (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h))) |
| 471 | (make-void src) |
| 472 | (make-primcall |
| 473 | src 'scm-error |
| 474 | (list |
| 475 | (make-const #f 'wrong-type-arg) |
| 476 | (make-const #f "call-with-prompt") |
| 477 | (make-const #f "Wrong type (expecting procedure): ~S") |
| 478 | (make-primcall #f 'list (list (make-lexical-ref #f 'h h))) |
| 479 | (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))))) |
| 480 | (make-prompt |
| 481 | src escape-only? tag body |
| 482 | (make-lambda |
| 483 | src '() |
| 484 | (make-lambda-case |
| 485 | src '() #f 'args #f '() (list args) |
| 486 | (make-primcall |
| 487 | src 'apply |
| 488 | (list (make-lexical-ref #f 'h h) |
| 489 | (make-lexical-ref #f 'args args))) |
| 490 | #f))))) |
| 491 | k |
| 492 | subst))) |
| 493 | |
| 494 | (($ <abort> src tag args ($ <const> _ ())) |
| 495 | (convert-args (cons tag args) |
| 496 | (lambda (args*) |
| 497 | (build-cps-term |
| 498 | ($continue k src |
| 499 | ($primcall 'abort-to-prompt args*)))))) |
| 500 | |
| 501 | (($ <abort> src tag args tail) |
| 502 | (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt) |
| 503 | tag) |
| 504 | args |
| 505 | (list tail)) |
| 506 | (lambda (args*) |
| 507 | (build-cps-term |
| 508 | ($continue k src ($primcall 'apply args*)))))) |
| 509 | |
| 510 | (($ <conditional> src test consequent alternate) |
| 511 | (let-gensyms (kif kt kf) |
| 512 | (build-cps-term |
| 513 | ($letk* ((kt ($kargs () () ,(convert consequent k subst))) |
| 514 | (kf ($kargs () () ,(convert alternate k subst))) |
| 515 | (kif ($kif kt kf))) |
| 516 | ,(match test |
| 517 | (($ <primcall> src (? branching-primitive? name) args) |
| 518 | (convert-args args |
| 519 | (lambda (args) |
| 520 | (build-cps-term |
| 521 | ($continue kif src ($primcall name args)))))) |
| 522 | (_ (convert-arg test |
| 523 | (lambda (test) |
| 524 | (build-cps-term |
| 525 | ($continue kif src ($var test))))))))))) |
| 526 | |
| 527 | (($ <lexical-set> src name gensym exp) |
| 528 | (convert-arg exp |
| 529 | (lambda (exp) |
| 530 | (match (assq-ref subst gensym) |
| 531 | ((box #t) |
| 532 | (build-cps-term |
| 533 | ($continue k src ($primcall 'box-set! (box exp))))))))) |
| 534 | |
| 535 | (($ <seq> src head tail) |
| 536 | (let-gensyms (ktrunc kseq) |
| 537 | (build-cps-term |
| 538 | ($letk* ((kseq ($kargs () () |
| 539 | ,(convert tail k subst))) |
| 540 | (ktrunc ($ktrunc '() #f kseq))) |
| 541 | ,(convert head ktrunc subst))))) |
| 542 | |
| 543 | (($ <let> src names syms vals body) |
| 544 | (let lp ((names names) (syms syms) (vals vals)) |
| 545 | (match (list names syms vals) |
| 546 | ((() () ()) (convert body k subst)) |
| 547 | (((name . names) (sym . syms) (val . vals)) |
| 548 | (let-gensyms (klet) |
| 549 | (build-cps-term |
| 550 | ($letk ((klet ($kargs (name) (sym) |
| 551 | ,(box-bound-var name sym |
| 552 | (lp names syms vals))))) |
| 553 | ,(convert val klet subst)))))))) |
| 554 | |
| 555 | (($ <fix> src names gensyms funs body) |
| 556 | ;; Some letrecs can be contified; that happens later. |
| 557 | (if (current-topbox-scope) |
| 558 | (let-gensyms (self) |
| 559 | (build-cps-term |
| 560 | ($letrec names |
| 561 | gensyms |
| 562 | (map (lambda (fun) |
| 563 | (match (convert fun k subst) |
| 564 | (($ $continue _ _ (and fun ($ $fun))) |
| 565 | fun))) |
| 566 | funs) |
| 567 | ,(convert body k subst)))) |
| 568 | (let-gensyms (scope kscope) |
| 569 | (build-cps-term |
| 570 | ($letk ((kscope ($kargs () () |
| 571 | ,(parameterize ((current-topbox-scope scope)) |
| 572 | (convert exp k subst))))) |
| 573 | ,(capture-toplevel-scope src scope kscope)))))) |
| 574 | |
| 575 | (($ <let-values> src exp |
| 576 | ($ <lambda-case> lsrc req #f rest #f () syms body #f)) |
| 577 | (let ((names (append req (if rest (list rest) '())))) |
| 578 | (let-gensyms (ktrunc kargs) |
| 579 | (build-cps-term |
| 580 | ($letk* ((kargs ($kargs names syms |
| 581 | ,(fold box-bound-var |
| 582 | (convert body k subst) |
| 583 | names syms))) |
| 584 | (ktrunc ($ktrunc req rest kargs))) |
| 585 | ,(convert exp ktrunc subst)))))))) |
| 586 | |
| 587 | (define (build-subst exp) |
| 588 | "Compute a mapping from lexical gensyms to substituted gensyms. The |
| 589 | usual reason to replace one variable by another is assignment |
| 590 | conversion. Default argument values is the other reason. |
| 591 | |
| 592 | Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED? |
| 593 | indicates that the replacement variable is in a box." |
| 594 | (define (box-set-vars exp subst) |
| 595 | (match exp |
| 596 | (($ <lexical-set> src name sym exp) |
| 597 | (if (assq sym subst) |
| 598 | subst |
| 599 | (cons (list sym (gensym "b") #t) subst))) |
| 600 | (_ subst))) |
| 601 | (define (default-args exp subst) |
| 602 | (match exp |
| 603 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) |
| 604 | (fold-formals (lambda (name sym init subst) |
| 605 | (if init |
| 606 | (let ((box? (match (assq-ref subst sym) |
| 607 | ((box #t) #t) |
| 608 | (#f #f))) |
| 609 | (subst-sym (gensym (symbol->string name)))) |
| 610 | (cons (list sym subst-sym box?) subst)) |
| 611 | subst)) |
| 612 | subst |
| 613 | (make-$arity req (or opt '()) rest |
| 614 | (if kw (cdr kw) '()) (and kw (car kw))) |
| 615 | gensyms |
| 616 | inits)) |
| 617 | (_ subst))) |
| 618 | (tree-il-fold box-set-vars default-args '() exp)) |
| 619 | |
| 620 | (define (cps-convert/thunk exp) |
| 621 | (let ((src (tree-il-src exp))) |
| 622 | (let-gensyms (kinit init ktail kclause kbody) |
| 623 | (build-cps-exp |
| 624 | ($fun src '() '() |
| 625 | (kinit ($kentry init |
| 626 | (ktail ($ktail)) |
| 627 | ((kclause |
| 628 | ($kclause ('() '() #f '() #f) |
| 629 | (kbody ($kargs () () |
| 630 | ,(convert exp ktail |
| 631 | (build-subst exp)))))))))))))) |
| 632 | |
| 633 | (define *comp-module* (make-fluid)) |
| 634 | |
| 635 | (define %warning-passes |
| 636 | `((unused-variable . ,unused-variable-analysis) |
| 637 | (unused-toplevel . ,unused-toplevel-analysis) |
| 638 | (unbound-variable . ,unbound-variable-analysis) |
| 639 | (arity-mismatch . ,arity-analysis) |
| 640 | (format . ,format-analysis))) |
| 641 | |
| 642 | (define (optimize-tree-il x e opts) |
| 643 | (define warnings |
| 644 | (or (and=> (memq #:warnings opts) cadr) |
| 645 | '())) |
| 646 | |
| 647 | ;; Go through the warning passes. |
| 648 | (let ((analyses (filter-map (lambda (kind) |
| 649 | (assoc-ref %warning-passes kind)) |
| 650 | warnings))) |
| 651 | (analyze-tree analyses x e)) |
| 652 | |
| 653 | (optimize x e opts)) |
| 654 | |
| 655 | (define (compile-cps exp env opts) |
| 656 | (values (cps-convert/thunk (optimize-tree-il exp env opts)) |
| 657 | env |
| 658 | env)) |
| 659 | |
| 660 | ;;; Local Variables: |
| 661 | ;;; eval: (put 'convert-arg 'scheme-indent-function 1) |
| 662 | ;;; eval: (put 'convert-args 'scheme-indent-function 1) |
| 663 | ;;; End: |