1 ;;; TREE-IL -> GLIL compiler
3 ;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (language tree-il compile-glil)
22 #:use-module (system base syntax)
23 #:use-module (system base pmatch)
24 #:use-module (system base message)
25 #:use-module (ice-9 receive)
26 #:use-module (language glil)
27 #:use-module (system vm instruction)
28 #:use-module (language tree-il)
29 #:use-module (language tree-il optimize)
30 #:use-module (language tree-il canonicalize)
31 #:use-module (language tree-il analyze)
32 #:use-module ((srfi srfi-1) #:select (filter-map))
33 #:export (compile-glil))
36 ;; sym -> {lambda -> address}
37 ;; lambda -> (labels . free-locs)
38 ;; lambda-case -> (gensym . nlocs)
40 ;; address ::= (local? boxed? . index)
41 ;; labels ::= ((sym . lambda) ...)
42 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
43 ;; free variable addresses are relative to parent proc.
45 (define *comp-module* (make-fluid))
47 (define %warning-passes
48 `((unused-variable . ,unused-variable-analysis)
49 (unused-toplevel . ,unused-toplevel-analysis)
50 (unbound-variable . ,unbound-variable-analysis)
51 (arity-mismatch . ,arity-analysis)
52 (format . ,format-analysis)))
54 (define (compile-glil x e opts)
56 (or (and=> (memq #:warnings opts) cadr)
59 ;; Go through the warning passes.
60 (let ((analyses (filter-map (lambda (kind)
61 (assoc-ref %warning-passes kind))
63 (analyze-tree analyses x e))
65 (let* ((x (make-lambda (tree-il-src x) '()
66 (make-lambda-case #f '() #f #f #f '() '() x #f)))
67 (x (optimize! x e opts))
69 (allocation (analyze-lexicals x)))
71 (with-fluids ((*comp-module* e))
72 (values (flatten-lambda x #f allocation)
78 (define *primcall-ops* (make-hash-table))
80 (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
83 ((equal? . 2) . equal?)
95 ((quotient . 2) . quo)
96 ((remainder . 2) . rem)
99 ((logand . 2) . logand)
100 ((logior . 2) . logior)
101 ((logxor . 2) . logxor)
103 ((pair? . 1) . pair?)
107 ((set-car! . 2) . set-car!)
108 ((set-cdr! . 2) . set-cdr!)
109 ((null? . 1) . null?)
110 ((list? . 1) . list?)
111 ((symbol? . 1) . symbol?)
112 ((vector? . 1) . vector?)
115 ((class-of . 1) . class-of)
116 ((@slot-ref . 2) . slot-ref)
117 ((@slot-set! . 3) . slot-set)
118 ((vector-ref . 2) . vector-ref)
119 ((vector-set! . 3) . vector-set)
120 ((variable-ref . 1) . variable-ref)
121 ;; nb, *not* variable-set! -- the args are switched
122 ((variable-bound? . 1) . variable-bound?)
123 ((struct? . 1) . struct?)
124 ((struct-vtable . 1) . struct-vtable)
125 ((struct-ref . 2) . struct-ref)
126 ((struct-set! . 3) . struct-set)
127 (make-struct/no-tail . make-struct)
129 ;; hack for javascript
130 ((return . 1) . return)
132 (return/values . return/values)
134 ((bytevector-u8-ref . 2) . bv-u8-ref)
135 ((bytevector-u8-set! . 3) . bv-u8-set)
136 ((bytevector-s8-ref . 2) . bv-s8-ref)
137 ((bytevector-s8-set! . 3) . bv-s8-set)
139 ((bytevector-u16-ref . 3) . bv-u16-ref)
140 ((bytevector-u16-set! . 4) . bv-u16-set)
141 ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
142 ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
143 ((bytevector-s16-ref . 3) . bv-s16-ref)
144 ((bytevector-s16-set! . 4) . bv-s16-set)
145 ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
146 ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
148 ((bytevector-u32-ref . 3) . bv-u32-ref)
149 ((bytevector-u32-set! . 4) . bv-u32-set)
150 ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
151 ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
152 ((bytevector-s32-ref . 3) . bv-s32-ref)
153 ((bytevector-s32-set! . 4) . bv-s32-set)
154 ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
155 ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
157 ((bytevector-u64-ref . 3) . bv-u64-ref)
158 ((bytevector-u64-set! . 4) . bv-u64-set)
159 ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
160 ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
161 ((bytevector-s64-ref . 3) . bv-s64-ref)
162 ((bytevector-s64-set! . 4) . bv-s64-set)
163 ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
164 ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
166 ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
167 ((bytevector-ieee-single-set! . 4) . bv-f32-set)
168 ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
169 ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
170 ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
171 ((bytevector-ieee-double-set! . 4) . bv-f64-set)
172 ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
173 ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
178 (define (make-label) (gensym ":L"))
180 (define (vars->bind-list ids vars allocation proc)
182 (pmatch (hashq-ref (hashq-ref allocation v) proc)
185 (,x (error "bad var list element" id v x))))
189 (define (emit-bindings src ids vars allocation proc emit-code)
190 (emit-code src (make-glil-bind
191 (vars->bind-list ids vars allocation proc))))
193 (define (with-output-to-code proc)
195 (define (emit-code src x)
196 (set! out (cons x out))
198 (set! out (cons (make-glil-source src) out))))
202 (define (flatten-lambda x self-label allocation)
204 ((<lambda> src meta body)
209 ;; write source info for proc
210 (if src (emit-code #f (make-glil-source src)))
211 ;; compile the body, yo
212 (flatten-lambda-case body allocation x self-label
213 (car (hashq-ref allocation x))
216 (define (flatten-lambda-case lcase allocation self self-label fix-labels
218 (define (emit-label label)
219 (emit-code #f (make-glil-label label)))
220 (define (emit-branch src inst label)
221 (emit-code src (make-glil-branch inst label)))
223 ;; RA: "return address"; #f unless we're in a non-tail fix with labels
224 ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
225 (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
226 (define (comp-tail tree) (comp tree context RA MVRA))
227 (define (comp-push tree) (comp tree 'push #f #f))
228 (define (comp-drop tree) (comp tree 'drop #f #f))
229 (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
230 (define (comp-fix tree RA) (comp tree context RA MVRA))
232 ;; A couple of helpers. Note that if we are in tail context, we
234 (define (maybe-emit-return)
236 (emit-branch #f 'br RA)
237 (if (eq? context 'tail)
238 (emit-code #f (make-glil-call 'return 1)))))
240 ;; After lexical binding forms in non-tail context, call this
241 ;; function to clear stack slots, allowing their previous values to
243 (define (clear-stack-slots context syms)
246 (for-each (lambda (v)
248 ;; Can be #f if the var is labels-allocated.
249 (hashq-ref allocation v)
251 (pmatch (hashq-ref h self)
253 (emit-code #f (make-glil-void))
254 (emit-code #f (make-glil-lexical #t #f 'set n)))
255 (,loc (error "bad let var allocation" x loc))))))
262 (emit-code #f (make-glil-void))))
268 (emit-code src (make-glil-const exp))))
271 ;; FIXME: should represent sequence as exps tail
273 (let lp ((exps exps))
274 (if (null? (cdr exps))
275 (comp-tail (car exps))
277 (comp-drop (car exps))
280 ((<application> src proc args)
281 ;; FIXME: need a better pattern-matcher here
283 ((and (primitive-ref? proc)
284 (eq? (primitive-ref-name proc) '@apply)
285 (>= (length args) 1))
286 (let ((proc (car args))
289 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
290 (not (eq? context 'push)) (not (eq? context 'vals)))
291 ;; tail: (lambda () (apply values '(1 2)))
292 ;; drop: (lambda () (apply values '(1 2)) 3)
293 ;; push: (lambda () (list (apply values '(10 12)) 1))
295 ((drop) (for-each comp-drop args) (maybe-emit-return))
297 (for-each comp-push args)
298 (emit-code src (make-glil-call 'return/values* (length args))))))
304 (for-each comp-push args)
305 (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
307 (emit-code src (make-glil-call 'new-frame 0))
309 (for-each comp-push args)
310 (emit-code src (make-glil-call 'apply (1+ (length args))))
314 (make-application src (make-primitive-ref #f 'apply)
319 ;; Well, shit. The proc might return any number of
320 ;; values (including 0), since it's in a drop context,
321 ;; yet apply does not create a MV continuation. So we
322 ;; mv-call out to our trampoline instead.
324 (make-application src (make-primitive-ref #f 'apply)
326 (maybe-emit-return)))))))
328 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
329 ;; tail: (lambda () (values '(1 2)))
330 ;; drop: (lambda () (values '(1 2)) 3)
331 ;; push: (lambda () (list (values '(10 12)) 1))
332 ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
334 ((drop) (for-each comp-drop args) (maybe-emit-return))
338 ;; FIXME: This is surely an error. We need to add a
339 ;; values-mismatch warning pass.
340 (emit-code src (make-glil-call 'new-frame 0))
342 (emit-code src (make-glil-call 'call 0))
345 ;; Taking advantage of unspecified order of evaluation of
347 (for-each comp-drop (cdr args))
348 (comp-push (car args))
349 (maybe-emit-return))))
351 (for-each comp-push args)
352 (emit-code #f (make-glil-const (length args)))
353 (emit-branch src 'br MVRA))
355 (for-each comp-push args)
356 (emit-code src (let ((len (length args)))
358 (make-glil-call 'return 1)
359 (make-glil-call 'return/values len)))))))
361 ((and (primitive-ref? proc)
362 (eq? (primitive-ref-name proc) '@call-with-values)
369 ;; MV: [tail-]call/nargs
370 ;; POST: (maybe-drop)
375 (make-application src (make-primitive-ref #f 'call-with-values)
380 (let ((MV (make-label)) (POST (make-label))
381 (producer (car args)) (consumer (cadr args)))
382 (if (not (eq? context 'tail))
383 (emit-code src (make-glil-call 'new-frame 0)))
385 (emit-code src (make-glil-call 'new-frame 0))
387 (emit-code src (make-glil-mv-call 0 MV))
389 ((tail) (emit-code src (make-glil-call 'tail-call 1)))
390 (else (emit-code src (make-glil-call 'call 1))
391 (emit-branch #f 'br POST)))
394 ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
395 (else (emit-code src (make-glil-call 'call/nargs 0))
397 (if (eq? context 'drop)
398 (emit-code #f (make-glil-call 'drop 1)))
399 (maybe-emit-return)))))))
401 ((and (primitive-ref? proc)
402 (eq? (primitive-ref-name proc) '@call-with-current-continuation)
406 (comp-push (car args))
407 (emit-code src (make-glil-call 'tail-call/cc 1)))
411 src (make-primitive-ref #f 'call-with-current-continuation)
416 (comp-push (car args))
417 (emit-code src (make-glil-call 'call/cc 1))
420 ;; Crap. Just like `apply' in drop context.
423 src (make-primitive-ref #f 'call-with-current-continuation)
425 (maybe-emit-return))))
427 ;; A hack for variable-set, the opcode for which takes its args
428 ;; reversed, relative to the variable-set! function
429 ((and (primitive-ref? proc)
430 (eq? (primitive-ref-name proc) 'variable-set!)
432 (comp-push (cadr args))
433 (comp-push (car args))
434 (emit-code src (make-glil-call 'variable-set 2))
436 ((tail push vals) (emit-code #f (make-glil-void))))
439 ((and (primitive-ref? proc)
440 (or (hash-ref *primcall-ops*
441 (cons (primitive-ref-name proc) (length args)))
442 (hash-ref *primcall-ops* (primitive-ref-name proc))))
444 (for-each comp-push args)
445 (emit-code src (make-glil-call op (length args)))
446 (case (instruction-pushes op)
449 ((tail push vals) (emit-code #f (make-glil-void))))
453 ((drop) (emit-code #f (make-glil-call 'drop 1))))
456 ;; A control instruction, like return/values. Here we
457 ;; just have to hope that the author of the tree-il
458 ;; knew what they were doing.
461 (error "bad primitive op: too many pushes"
462 op (instruction-pushes op))))))
464 ;; call to the same lambda-case in tail position
465 ((and (lexical-ref? proc)
466 self-label (eq? (lexical-ref-gensym proc) self-label)
468 (not (lambda-case-kw lcase))
469 (not (lambda-case-rest lcase))
471 (+ (length (lambda-case-req lcase))
472 (or (and=> (lambda-case-opt lcase) length) 0))))
473 (for-each comp-push args)
474 (for-each (lambda (sym)
475 (pmatch (hashq-ref (hashq-ref allocation sym) self)
476 ((#t #f . ,index) ; unboxed
477 (emit-code #f (make-glil-lexical #t #f 'set index)))
478 ((#t #t . ,index) ; boxed
480 (emit-code #f (make-glil-lexical #t #t 'box index)))
481 (,x (error "bad lambda-case arg allocation" x))))
482 (reverse (lambda-case-gensyms lcase)))
483 (emit-branch src 'br (car (hashq-ref allocation lcase))))
485 ;; lambda, the ultimate goto
486 ((and (lexical-ref? proc)
487 (assq (lexical-ref-gensym proc) fix-labels))
488 ;; like the self-tail-call case, though we can handle "drop"
489 ;; contexts too. first, evaluate new values, pushing them on
491 (for-each comp-push args)
492 ;; find the specific case, rename args, and goto the case label
493 (let lp ((lcase (lambda-body
494 (assq-ref fix-labels (lexical-ref-gensym proc)))))
496 ((and (lambda-case? lcase)
497 (not (lambda-case-kw lcase))
498 (not (lambda-case-opt lcase))
499 (not (lambda-case-rest lcase))
500 (= (length args) (length (lambda-case-req lcase))))
501 ;; we have a case that matches the args; rename variables
502 ;; and goto the case label
503 (for-each (lambda (sym)
504 (pmatch (hashq-ref (hashq-ref allocation sym) self)
505 ((#t #f . ,index) ; unboxed
506 (emit-code #f (make-glil-lexical #t #f 'set index)))
507 ((#t #t . ,index) ; boxed
508 (emit-code #f (make-glil-lexical #t #t 'box index)))
509 (,x (error "bad lambda-case arg allocation" x))))
510 (reverse (lambda-case-gensyms lcase)))
511 (emit-branch src 'br (car (hashq-ref allocation lcase))))
512 ((lambda-case? lcase)
513 ;; no match, try next case
514 (lp (lambda-case-alternate lcase)))
516 ;; no cases left. we can't really handle this currently.
517 ;; ideally we would push on a new frame, then do a "local
518 ;; call" -- which doesn't require consing up a program
519 ;; object. but for now error, as this sort of case should
520 ;; preclude label allocation.
521 (error "couldn't find matching case for label call" x)))))
524 (if (not (eq? context 'tail))
525 (emit-code src (make-glil-call 'new-frame 0)))
527 (for-each comp-push args)
528 (let ((len (length args)))
530 ((tail) (if (<= len #xff)
531 (emit-code src (make-glil-call 'tail-call len))
533 (comp-push (make-const #f len))
534 (emit-code src (make-glil-call 'tail-call/nargs 0)))))
535 ((push) (if (<= len #xff)
536 (emit-code src (make-glil-call 'call len))
538 (comp-push (make-const #f len))
539 (emit-code src (make-glil-call 'call/nargs 0))))
541 ;; FIXME: mv-call doesn't have a /nargs variant, so it is
542 ;; limited to 255 args. Can work around it with a
543 ;; trampoline and tail-call/nargs, but it's not so nice.
544 ((vals) (emit-code src (make-glil-mv-call len MVRA))
546 ((drop) (let ((MV (make-label)) (POST (make-label)))
547 (emit-code src (make-glil-mv-call len MV))
548 (emit-code #f (make-glil-call 'drop 1))
549 (emit-branch #f 'br (or RA POST))
551 (emit-code #f (make-glil-mv-bind 0 #f))
553 (emit-branch #f 'br RA)
554 (emit-label POST)))))))))
556 ((<conditional> src test consequent alternate)
563 (let ((L1 (make-label)) (L2 (make-label)))
564 ;; need a pattern matcher
566 ((<application> proc args)
568 ((<primitive-ref> name)
569 (let ((len (length args)))
572 ((and (eq? name 'eq?) (= len 2))
573 (comp-push (car args))
574 (comp-push (cadr args))
575 (emit-branch src 'br-if-not-eq L1))
577 ((and (eq? name 'null?) (= len 1))
578 (comp-push (car args))
579 (emit-branch src 'br-if-not-null L1))
581 ((and (eq? name 'not) (= len 1))
582 (let ((app (car args)))
584 ((<application> proc args)
585 (let ((len (length args)))
587 ((<primitive-ref> name)
590 ((and (eq? name 'eq?) (= len 2))
591 (comp-push (car args))
592 (comp-push (cadr args))
593 (emit-branch src 'br-if-eq L1))
595 ((and (eq? name 'null?) (= len 1))
596 (comp-push (car args))
597 (emit-branch src 'br-if-null L1))
601 (emit-branch src 'br-if L1))))
604 (emit-branch src 'br-if L1)))))
607 (emit-branch src 'br-if L1)))))
611 (emit-branch src 'br-if-not L1)))))
614 (emit-branch src 'br-if-not L1))))
617 (emit-branch src 'br-if-not L1)))
619 (comp-tail consequent)
620 ;; if there is an RA, comp-tail will cause a jump to it -- just
621 ;; have to clean up here if there is no RA.
622 (if (and (not RA) (not (eq? context 'tail)))
623 (emit-branch #f 'br L2))
625 (comp-tail alternate)
626 (if (and (not RA) (not (eq? context 'tail)))
629 ((<primitive-ref> src name)
631 ((eq? (module-variable (fluid-ref *comp-module*) name)
632 (module-variable the-root-module name))
635 (emit-code src (make-glil-toplevel 'ref name))))
637 ((module-variable the-root-module name)
640 (emit-code src (make-glil-module 'ref '(guile) name #f))))
645 (emit-code src (make-glil-module
646 'ref (module-name (fluid-ref *comp-module*)) name #f))))
647 (maybe-emit-return))))
649 ((<lexical-ref> src gensym)
652 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
653 ((,local? ,boxed? . ,index)
654 (emit-code src (make-glil-lexical local? boxed? 'ref index)))
656 (error "bad lexical allocation" x loc)))))
659 ((<lexical-set> src gensym exp)
661 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
662 ((,local? ,boxed? . ,index)
663 (emit-code src (make-glil-lexical local? boxed? 'set index)))
665 (error "bad lexical allocation" x loc)))
668 (emit-code #f (make-glil-void))))
671 ((<module-ref> src mod name public?)
672 (emit-code src (make-glil-module 'ref mod name public?))
674 ((drop) (emit-code #f (make-glil-call 'drop 1))))
677 ((<module-set> src mod name public? exp)
679 (emit-code src (make-glil-module 'set mod name public?))
682 (emit-code #f (make-glil-void))))
685 ((<toplevel-ref> src name)
686 (emit-code src (make-glil-toplevel 'ref name))
688 ((drop) (emit-code #f (make-glil-call 'drop 1))))
691 ((<toplevel-set> src name exp)
693 (emit-code src (make-glil-toplevel 'set name))
696 (emit-code #f (make-glil-void))))
699 ((<toplevel-define> src name exp)
701 (emit-code src (make-glil-toplevel 'define name))
704 (emit-code #f (make-glil-void))))
708 (let ((free-locs (cdr (hashq-ref allocation x))))
711 (emit-code #f (flatten-lambda x #f allocation))
712 (if (not (null? free-locs))
717 ((,local? ,boxed? . ,n)
718 (emit-code #f (make-glil-lexical local? #f 'ref n)))
719 (else (error "bad lambda free var allocation" x loc))))
721 (emit-code #f (make-glil-call 'make-closure
722 (length free-locs))))))))
725 ((<lambda-case> src req opt rest kw inits gensyms alternate body)
726 ;; o/~ feature on top of feature o/~
728 ;; opt := (name ...) | #f
730 ;; kw: (allow-other-keys? (keyword name var) ...) | #f
731 ;; gensyms: (sym ...)
732 ;; init: tree-il in context of gensyms
733 ;; gensyms map to named arguments in the following order:
734 ;; required, optional (positional), rest, keyword.
735 (let* ((nreq (length req))
736 (nopt (if opt (length opt) 0))
737 (rest-idx (and rest (+ nreq nopt)))
738 (opt-names (or opt '()))
739 (allow-other-keys? (if kw (car kw) #f))
740 (kw-indices (map (lambda (x)
743 (cons key (list-index gensyms var)))
744 (else (error "bad kwarg" x))))
745 (if kw (cdr kw) '())))
746 (nargs (apply max (+ nreq nopt (if rest 1 0))
747 (map 1+ (map cdr kw-indices))))
748 (nlocs (cdr (hashq-ref allocation x)))
749 (alternate-label (and alternate (make-label))))
752 (+ nreq (length inits) (if rest 1 0)))
753 (error "lambda-case gensyms don't correspond to args"
754 req opt rest kw inits gensyms nreq nopt kw-indices nargs))
755 ;; the prelude, to check args & reset the stack pointer,
756 ;; allowing room for locals
761 (make-glil-kw-prelude nreq nopt rest-idx kw-indices
762 allow-other-keys? nlocs alternate-label))
764 (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
766 (make-glil-std-prelude nreq nlocs alternate-label))))
767 ;; box args if necessary
770 (pmatch (hashq-ref (hashq-ref allocation v) self)
772 (emit-code #f (make-glil-lexical #t #f 'ref n))
773 (emit-code #f (make-glil-lexical #t #t 'box n)))))
775 ;; write bindings info
776 (if (not (null? gensyms))
779 (let lp ((kw (if kw (cdr kw) '()))
780 (names (append (reverse opt-names) (reverse req)))
781 (gensyms (list-tail gensyms (+ nreq nopt
785 ;; fixme: check that gensyms is empty
786 (reverse (if rest (cons rest names) names)))
787 (((,key ,name ,var) . ,kw)
788 (if (memq var gensyms)
789 (lp kw (cons name names) (delq var gensyms))
790 (lp kw names gensyms)))
791 (,kw (error "bad keywords, yo" kw))))
792 gensyms allocation self emit-code))
793 ;; init optional/kw args
794 (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
796 ((null? inits)) ; done
797 ((and rest-idx (= n rest-idx))
798 (lp inits (1+ n) (cdr gensyms)))
800 (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
801 ((#t ,boxed? . ,n*) (guard (= n* n))
802 (let ((L (make-label)))
803 (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
804 (emit-code #f (make-glil-branch 'br-if L))
805 (comp-push (car inits))
806 (emit-code #f (make-glil-lexical #t boxed? 'set n))
808 (lp (cdr inits) (1+ n) (cdr gensyms))))
809 (#t (error "bad arg allocation" (car gensyms) inits))))))
810 ;; post-prelude case label for label calls
811 (emit-label (car (hashq-ref allocation x)))
813 (if (not (null? gensyms))
814 (emit-code #f (make-glil-unbind)))
817 (emit-label alternate-label)
818 (flatten-lambda-case alternate allocation self self-label
819 fix-labels emit-code)))))
821 ((<let> src names gensyms vals body)
822 (for-each comp-push vals)
823 (emit-bindings src names gensyms allocation self emit-code)
824 (for-each (lambda (v)
825 (pmatch (hashq-ref (hashq-ref allocation v) self)
827 (emit-code src (make-glil-lexical #t #f 'set n)))
829 (emit-code src (make-glil-lexical #t #t 'box n)))
830 (,loc (error "bad let var allocation" x loc))))
833 (clear-stack-slots context gensyms)
834 (emit-code #f (make-glil-unbind)))
836 ((<letrec> src in-order? names gensyms vals body)
837 ;; First prepare heap storage slots.
838 (for-each (lambda (v)
839 (pmatch (hashq-ref (hashq-ref allocation v) self)
841 (emit-code src (make-glil-lexical #t #t 'empty-box n)))
842 (,loc (error "bad letrec var allocation" x loc))))
844 ;; Even though the slots are empty, the bindings are valid.
845 (emit-bindings src names gensyms allocation self emit-code)
848 ;; For letrec*, bind values in order.
849 (for-each (lambda (name v val)
850 (pmatch (hashq-ref (hashq-ref allocation v) self)
853 (emit-code src (make-glil-lexical #t #t 'set n)))
854 (,loc (error "bad letrec var allocation" x loc))))
857 ;; But for letrec, eval all values, then bind.
858 (for-each comp-push vals)
859 (for-each (lambda (v)
860 (pmatch (hashq-ref (hashq-ref allocation v) self)
862 (emit-code src (make-glil-lexical #t #t 'set n)))
863 (,loc (error "bad letrec var allocation" x loc))))
866 (clear-stack-slots context gensyms)
867 (emit-code #f (make-glil-unbind)))
869 ((<fix> src names gensyms vals body)
870 ;; The ideal here is to just render the lambda bodies inline, and
871 ;; wire the code together with gotos. We can do that if
872 ;; analyze-lexicals has determined that a given var has "label"
873 ;; allocation -- which is the case if it is in `fix-labels'.
875 ;; But even for closures that we can't inline, we can do some
876 ;; tricks to avoid heap-allocation for the binding itself. Since
877 ;; we know the vals are lambdas, we can set them to their local
878 ;; var slots first, then capture their bindings, mutating them in
880 (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
884 ((hashq-ref allocation x)
885 ;; allocating a closure
886 (emit-code #f (flatten-lambda x v allocation))
887 (let ((free-locs (cdr (hashq-ref allocation x))))
888 (if (not (null? free-locs))
889 ;; Need to make-closure first, so we have a fresh closure on
890 ;; the heap, but with a temporary free values.
892 (for-each (lambda (loc)
893 (emit-code #f (make-glil-const #f)))
895 (emit-code #f (make-glil-call 'make-closure
896 (length free-locs))))))
897 (pmatch (hashq-ref (hashq-ref allocation v) self)
899 (emit-code src (make-glil-lexical #t #f 'set n)))
900 (,loc (error "bad fix var allocation" x loc))))
902 ;; labels allocation: emit label & body, but jump over it
903 (let ((POST (make-label)))
904 (emit-branch #f 'br POST)
905 (let lp ((lcase (lambda-body x)))
908 ((<lambda-case> src req gensyms body alternate)
909 (emit-label (car (hashq-ref allocation lcase)))
910 ;; FIXME: opt & kw args in the bindings
911 (emit-bindings #f req gensyms allocation self emit-code)
913 (emit-code #f (make-glil-source src)))
914 (comp-fix body (or RA new-RA))
915 (emit-code #f (make-glil-unbind))
917 (emit-label POST)))))))
920 ;; Emit bindings metadata for closures
921 (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
922 (cond ((null? gensyms) (reverse! out))
923 ((assq (car gensyms) fix-labels)
924 (lp out (cdr gensyms) (cdr names)))
926 (lp (acons (car gensyms) (car names) out)
927 (cdr gensyms) (cdr names)))))))
928 (emit-bindings src (map cdr binds) (map car binds)
929 allocation self emit-code))
930 ;; Now go back and fix up the bindings for closures.
933 (let ((free-locs (if (hashq-ref allocation x)
934 (cdr (hashq-ref allocation x))
935 ;; can hit this latter case for labels allocation
937 (if (not (null? free-locs))
942 ((,local? ,boxed? . ,n)
943 (emit-code #f (make-glil-lexical local? #f 'ref n)))
944 (else (error "bad free var allocation" x loc))))
946 (pmatch (hashq-ref (hashq-ref allocation v) self)
948 (emit-code #f (make-glil-lexical #t #f 'fix n)))
949 (,loc (error "bad fix var allocation" x loc)))))))
955 (clear-stack-slots context gensyms)
956 (emit-code #f (make-glil-unbind))))
958 ((<let-values> src exp body)
960 ((<lambda-case> req opt kw rest gensyms body alternate)
961 (if (or opt kw alternate)
962 (error "unexpected lambda-case in let-values" x))
963 (let ((MV (make-label)))
965 (emit-code #f (make-glil-const 1))
967 (emit-code src (make-glil-mv-bind
969 (append req (if rest (list rest) '()))
970 gensyms allocation self)
972 (for-each (lambda (v)
973 (pmatch (hashq-ref (hashq-ref allocation v) self)
975 (emit-code src (make-glil-lexical #t #f 'set n)))
977 (emit-code src (make-glil-lexical #t #t 'box n)))
978 (,loc (error "bad let-values var allocation" x loc))))
981 (clear-stack-slots context gensyms)
982 (emit-code #f (make-glil-unbind))))))
984 ;; much trickier than i thought this would be, at first, due to the need
985 ;; to have body's return value(s) on the stack while the unwinder runs,
986 ;; then proceed with returning or dropping or what-have-you, interacting
987 ;; with RA and MVRA. What have you, I say.
988 ((<dynwind> src body winder unwinder)
991 (comp-drop (make-application src winder '()))
992 (emit-code #f (make-glil-call 'wind 2))
996 (let ((MV (make-label)))
998 ;; one value: unwind...
999 (emit-code #f (make-glil-call 'unwind 0))
1000 (comp-drop (make-application src unwinder '()))
1001 ;; ...and return the val
1002 (emit-code #f (make-glil-call 'return 1))
1005 ;; multiple values: unwind...
1006 (emit-code #f (make-glil-call 'unwind 0))
1007 (comp-drop (make-application src unwinder '()))
1008 ;; and return the values.
1009 (emit-code #f (make-glil-call 'return/nvalues 1))))
1012 ;; we only want one value. so ask for one value
1014 ;; and unwind, leaving the val on the stack
1015 (emit-code #f (make-glil-call 'unwind 0))
1016 (comp-drop (make-application src unwinder '())))
1019 (let ((MV (make-label)))
1021 ;; one value: push 1 and fall through to MV case
1022 (emit-code #f (make-glil-const 1))
1025 ;; multiple values: unwind...
1026 (emit-code #f (make-glil-call 'unwind 0))
1027 (comp-drop (make-application src unwinder '()))
1028 ;; and goto the MVRA.
1029 (emit-branch #f 'br MVRA)))
1032 ;; compile body, discarding values. then unwind...
1034 (emit-code #f (make-glil-call 'unwind 0))
1035 (comp-drop (make-application src unwinder '()))
1036 ;; and fall through, or goto RA if there is one.
1038 (emit-branch #f 'br RA)))))
1040 ((<dynlet> src fluids vals body)
1041 (for-each comp-push fluids)
1042 (for-each comp-push vals)
1043 (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
1047 (let ((MV (make-label)))
1048 ;; NB: in tail case, it is possible to preserve asymptotic tail
1049 ;; recursion, via merging unwind-fluids structures -- but we'd need
1050 ;; to compile in the body twice (once in tail context, assuming the
1051 ;; caller unwinds, and once with this trampoline thing, unwinding
1054 ;; one value: unwind and return
1055 (emit-code #f (make-glil-call 'unwind-fluids 0))
1056 (emit-code #f (make-glil-call 'return 1))
1059 ;; multiple values: unwind and return values
1060 (emit-code #f (make-glil-call 'unwind-fluids 0))
1061 (emit-code #f (make-glil-call 'return/nvalues 1))))
1065 (emit-code #f (make-glil-call 'unwind-fluids 0)))
1068 (let ((MV (make-label)))
1070 ;; one value: push 1 and fall through to MV case
1071 (emit-code #f (make-glil-const 1))
1074 ;; multiple values: unwind and goto MVRA
1075 (emit-code #f (make-glil-call 'unwind-fluids 0))
1076 (emit-branch #f 'br MVRA)))
1079 ;; compile body, discarding values. then unwind...
1081 (emit-code #f (make-glil-call 'unwind-fluids 0))
1082 ;; and fall through, or goto RA if there is one.
1084 (emit-branch #f 'br RA)))))
1086 ((<dynref> src fluid)
1092 (emit-code #f (make-glil-call 'fluid-ref 1))))
1093 (maybe-emit-return))
1095 ((<dynset> src fluid exp)
1098 (emit-code #f (make-glil-call 'fluid-set 2))
1101 (emit-code #f (make-glil-void))))
1102 (maybe-emit-return))
1104 ;; What's the deal here? The deal is that we are compiling the start of a
1105 ;; delimited continuation. We try to avoid heap allocation in the normal
1106 ;; case; so the body is an expression, not a thunk, and we try to render
1107 ;; the handler inline. Also we did some analysis, in analyze.scm, so that
1108 ;; if the continuation isn't referenced, we don't reify it. This makes it
1109 ;; possible to implement catch and throw with delimited continuations,
1110 ;; without any overhead.
1111 ((<prompt> src tag body handler)
1112 (let ((H (make-label))
1114 (escape-only? (hashq-ref allocation x)))
1115 ;; First, set up the prompt.
1117 (emit-code src (make-glil-prompt H escape-only?))
1119 ;; Then we compile the body, with its normal return path, unwinding
1120 ;; before proceeding.
1123 (let ((MV (make-label)))
1125 ;; one value: unwind and return
1126 (emit-code #f (make-glil-call 'unwind 0))
1127 (emit-code #f (make-glil-call 'return 1))
1128 ;; multiple values: unwind and return
1130 (emit-code #f (make-glil-call 'unwind 0))
1131 (emit-code #f (make-glil-call 'return/nvalues 1))))
1134 ;; we only want one value. so ask for one value, unwind, and jump to
1137 (emit-code #f (make-glil-call 'unwind 0))
1138 (emit-branch #f 'br (or RA POST)))
1141 (let ((MV (make-label)))
1143 ;; one value: push 1 and fall through to MV case
1144 (emit-code #f (make-glil-const 1))
1145 ;; multiple values: unwind and goto MVRA
1147 (emit-code #f (make-glil-call 'unwind 0))
1148 (emit-branch #f 'br MVRA)))
1151 ;; compile body, discarding values, then unwind & fall through.
1153 (emit-code #f (make-glil-call 'unwind 0))
1154 (emit-branch #f 'br (or RA POST))))
1157 ;; Now the handler. The stack is now made up of the continuation, and
1158 ;; then the args to the continuation (pushed separately), and then the
1159 ;; number of args, including the continuation.
1160 (record-case handler
1161 ((<lambda-case> req opt kw rest gensyms body alternate)
1162 (if (or opt kw alternate)
1163 (error "unexpected lambda-case in prompt" x))
1164 (emit-code src (make-glil-mv-bind
1166 (append req (if rest (list rest) '()))
1167 gensyms allocation self)
1169 (for-each (lambda (v)
1170 (pmatch (hashq-ref (hashq-ref allocation v) self)
1172 (emit-code src (make-glil-lexical #t #f 'set n)))
1174 (emit-code src (make-glil-lexical #t #t 'box n)))
1176 (error "bad prompt handler arg allocation" x loc))))
1179 (emit-code #f (make-glil-unbind))))
1182 (or (eq? context 'push) (eq? context 'drop)))
1183 (emit-label POST))))
1185 ((<abort> src tag args tail)
1187 (for-each comp-push args)
1189 (emit-code src (make-glil-call 'abort (length args)))
1190 ;; so, the abort can actually return. if it does, the values will be on
1191 ;; the stack, then the MV marker, just as in an MV context.
1195 (emit-code #f (make-glil-call 'return/nvalues 1)))
1197 ;; Drop all values and goto RA, or otherwise fall through.
1198 (emit-code #f (make-glil-mv-bind 0 #f))
1199 (if RA (emit-branch #f 'br RA)))
1201 ;; Truncate to one value.
1202 (emit-code #f (make-glil-mv-bind 1 #f)))
1205 (emit-branch #f 'br MVRA)))))))