1 ;;; TREE-IL -> GLIL compiler
3 ;; Copyright (C) 2001,2008,2009 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 analyze)
31 #:export (compile-glil))
34 ;; sym -> {lambda -> address}
35 ;; lambda -> (labels . free-locs)
36 ;; lambda-case -> (gensym . nlocs)
38 ;; address ::= (local? boxed? . index)
39 ;; labels ::= ((sym . lambda) ...)
40 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
41 ;; free variable addresses are relative to parent proc.
43 (define *comp-module* (make-fluid))
45 (define %warning-passes
46 `((unused-variable . ,report-unused-variables)
47 (unbound-variable . ,report-possibly-unbound-variables)))
49 (define (compile-glil x e opts)
51 (or (and=> (memq #:warnings opts) cadr)
54 ;; Go through the warning passes.
55 (for-each (lambda (kind)
56 (let ((warn (assoc-ref %warning-passes kind)))
57 (and (procedure? warn)
61 (let* ((x (make-lambda (tree-il-src x) '()
62 (make-lambda-case #f '() #f #f #f '() '() #f x #f)))
63 (x (optimize! x e opts))
64 (allocation (analyze-lexicals x)))
66 (with-fluid* *comp-module* e
68 (values (flatten-lambda x #f allocation)
74 (define *primcall-ops* (make-hash-table))
76 (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
79 ((equal? . 2) . equal?)
91 ((quotient . 2) . quo)
92 ((remainder . 2) . rem)
99 ((set-car! . 2) . set-car!)
100 ((set-cdr! . 2) . set-cdr!)
101 ((null? . 1) . null?)
102 ((list? . 1) . list?)
105 ((@slot-ref . 2) . slot-ref)
106 ((@slot-set! . 3) . slot-set)
107 ((vector-ref . 2) . vector-ref)
108 ((vector-set! . 3) . vector-set)
110 ((bytevector-u8-ref . 2) . bv-u8-ref)
111 ((bytevector-u8-set! . 3) . bv-u8-set)
112 ((bytevector-s8-ref . 2) . bv-s8-ref)
113 ((bytevector-s8-set! . 3) . bv-s8-set)
115 ((bytevector-u16-ref . 3) . bv-u16-ref)
116 ((bytevector-u16-set! . 4) . bv-u16-set)
117 ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
118 ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
119 ((bytevector-s16-ref . 3) . bv-s16-ref)
120 ((bytevector-s16-set! . 4) . bv-s16-set)
121 ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
122 ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
124 ((bytevector-u32-ref . 3) . bv-u32-ref)
125 ((bytevector-u32-set! . 4) . bv-u32-set)
126 ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
127 ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
128 ((bytevector-s32-ref . 3) . bv-s32-ref)
129 ((bytevector-s32-set! . 4) . bv-s32-set)
130 ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
131 ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
133 ((bytevector-u64-ref . 3) . bv-u64-ref)
134 ((bytevector-u64-set! . 4) . bv-u64-set)
135 ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
136 ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
137 ((bytevector-s64-ref . 3) . bv-s64-ref)
138 ((bytevector-s64-set! . 4) . bv-s64-set)
139 ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
140 ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
142 ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
143 ((bytevector-ieee-single-set! . 4) . bv-f32-set)
144 ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
145 ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
146 ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
147 ((bytevector-ieee-double-set! . 4) . bv-f64-set)
148 ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
149 ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
154 (define (make-label) (gensym ":L"))
156 (define (vars->bind-list ids vars allocation proc)
158 (pmatch (hashq-ref (hashq-ref allocation v) proc)
161 (,x (error "badness" x))))
165 (define (emit-bindings src ids vars allocation proc emit-code)
166 (emit-code src (make-glil-bind
167 (vars->bind-list ids vars allocation proc))))
169 (define (with-output-to-code proc)
171 (define (emit-code src x)
172 (set! out (cons x out))
174 (set! out (cons (make-glil-source src) out))))
178 (define (flatten-lambda x self-label allocation)
180 ((<lambda> src meta body)
185 ;; write source info for proc
186 (if src (emit-code #f (make-glil-source src)))
187 ;; emit pre-prelude label for self tail calls in which the
188 ;; number of arguments doesn't check out at compile time
190 (emit-code #f (make-glil-label self-label)))
191 ;; compile the body, yo
192 (flatten body allocation x self-label (car (hashq-ref allocation x))
195 (define (flatten x allocation self self-label fix-labels emit-code)
196 (define (emit-label label)
197 (emit-code #f (make-glil-label label)))
198 (define (emit-branch src inst label)
199 (emit-code src (make-glil-branch inst label)))
201 ;; RA: "return address"; #f unless we're in a non-tail fix with labels
202 ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
203 (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
204 (define (comp-tail tree) (comp tree context RA MVRA))
205 (define (comp-push tree) (comp tree 'push #f #f))
206 (define (comp-drop tree) (comp tree 'drop #f #f))
207 (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
208 (define (comp-fix tree RA) (comp tree context RA MVRA))
210 ;; A couple of helpers. Note that if we are in tail context, we
212 (define (maybe-emit-return)
214 (emit-branch #f 'br RA)
215 (if (eq? context 'tail)
216 (emit-code #f (make-glil-call 'return 1)))))
222 (emit-code #f (make-glil-void))))
228 (emit-code src (make-glil-const exp))))
231 ;; FIXME: should represent sequence as exps tail
233 (let lp ((exps exps))
234 (if (null? (cdr exps))
235 (comp-tail (car exps))
237 (comp-drop (car exps))
240 ((<application> src proc args)
241 ;; FIXME: need a better pattern-matcher here
243 ((and (primitive-ref? proc)
244 (eq? (primitive-ref-name proc) '@apply)
245 (>= (length args) 1))
246 (let ((proc (car args))
249 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
250 (not (eq? context 'push)) (not (eq? context 'vals)))
251 ;; tail: (lambda () (apply values '(1 2)))
252 ;; drop: (lambda () (apply values '(1 2)) 3)
253 ;; push: (lambda () (list (apply values '(10 12)) 1))
255 ((drop) (for-each comp-drop args) (maybe-emit-return))
257 (for-each comp-push args)
258 (emit-code src (make-glil-call 'return/values* (length args))))))
264 (for-each comp-push args)
265 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
267 (emit-code src (make-glil-call 'new-frame 0))
269 (for-each comp-push args)
270 (emit-code src (make-glil-call 'apply (1+ (length args))))
274 (make-application src (make-primitive-ref #f 'apply)
279 ;; Well, shit. The proc might return any number of
280 ;; values (including 0), since it's in a drop context,
281 ;; yet apply does not create a MV continuation. So we
282 ;; mv-call out to our trampoline instead.
284 (make-application src (make-primitive-ref #f 'apply)
286 (maybe-emit-return)))))))
288 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
289 (not (eq? context 'push)))
290 ;; tail: (lambda () (values '(1 2)))
291 ;; drop: (lambda () (values '(1 2)) 3)
292 ;; push: (lambda () (list (values '(10 12)) 1))
293 ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
295 ((drop) (for-each comp-drop args) (maybe-emit-return))
297 (for-each comp-push args)
298 (emit-code #f (make-glil-const (length args)))
299 (emit-branch src 'br MVRA))
301 (for-each comp-push args)
302 (emit-code src (make-glil-call 'return/values (length args))))))
304 ((and (primitive-ref? proc)
305 (eq? (primitive-ref-name proc) '@call-with-values)
312 ;; MV: [tail-]call/nargs
313 ;; POST: (maybe-drop)
318 (make-application src (make-primitive-ref #f 'call-with-values)
323 (let ((MV (make-label)) (POST (make-label))
324 (producer (car args)) (consumer (cadr args)))
325 (if (not (eq? context 'tail))
326 (emit-code src (make-glil-call 'new-frame 0)))
328 (emit-code src (make-glil-call 'new-frame 0))
330 (emit-code src (make-glil-mv-call 0 MV))
332 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
333 (else (emit-code src (make-glil-call 'call 1))
334 (emit-branch #f 'br POST)))
337 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
338 (else (emit-code src (make-glil-call 'call/nargs 0))
340 (if (eq? context 'drop)
341 (emit-code #f (make-glil-call 'drop 1)))
342 (maybe-emit-return)))))))
344 ((and (primitive-ref? proc)
345 (eq? (primitive-ref-name proc) '@call-with-current-continuation)
349 (comp-push (car args))
350 (emit-code src (make-glil-call 'goto/cc 1)))
354 src (make-primitive-ref #f 'call-with-current-continuation)
359 (comp-push (car args))
360 (emit-code src (make-glil-call 'call/cc 1))
363 ;; Crap. Just like `apply' in drop context.
366 src (make-primitive-ref #f 'call-with-current-continuation)
368 (maybe-emit-return))))
370 ((and (primitive-ref? proc)
371 (or (hash-ref *primcall-ops*
372 (cons (primitive-ref-name proc) (length args)))
373 (hash-ref *primcall-ops* (primitive-ref-name proc))))
375 (for-each comp-push args)
376 (emit-code src (make-glil-call op (length args)))
377 (case (instruction-pushes op)
380 ((tail push vals) (emit-code #f (make-glil-void))))
384 ((drop) (emit-code #f (make-glil-call 'drop 1))))
387 (error "bad primitive op: too many pushes"
388 op (instruction-pushes op))))))
390 ;; self-call in tail position
391 ((and (lexical-ref? proc)
392 self-label (eq? (lexical-ref-gensym proc) self-label)
394 ;; first, evaluate new values, pushing them on the stack
395 (for-each comp-push args)
396 (let lp ((lcase (lambda-body self)))
398 ((and (lambda-case? lcase)
399 (not (lambda-case-kw lcase))
400 (not (lambda-case-opt lcase))
401 (not (lambda-case-rest lcase))
402 (= (length args) (length (lambda-case-req lcase))))
403 ;; we have a case that matches the args; rename variables
404 ;; and goto the case label
405 (for-each (lambda (sym)
406 (pmatch (hashq-ref (hashq-ref allocation sym) self)
407 ((#t #f . ,index) ; unboxed
408 (emit-code #f (make-glil-lexical #t #f 'set index)))
409 ((#t #t . ,index) ; boxed
411 (emit-code #f (make-glil-lexical #t #t 'box index)))
412 (,x (error "what" x))))
413 (reverse (lambda-case-vars lcase)))
414 (emit-branch src 'br (car (hashq-ref allocation lcase))))
415 ((lambda-case? lcase)
416 ;; no match, try next case
417 (lp (lambda-case-else lcase)))
419 ;; no cases left; shuffle args down and jump before the prelude.
420 (for-each (lambda (i)
421 (emit-code #f (make-glil-lexical #t #f 'set i)))
422 (reverse (iota (length args))))
423 (emit-branch src 'br self-label)))))
425 ;; lambda, the ultimate goto
426 ((and (lexical-ref? proc)
427 (assq (lexical-ref-gensym proc) fix-labels))
428 ;; like the self-tail-call case, though we can handle "drop"
429 ;; contexts too. first, evaluate new values, pushing them on
431 (for-each comp-push args)
432 ;; find the specific case, rename args, and goto the case label
433 (let lp ((lcase (lambda-body
434 (assq-ref fix-labels (lexical-ref-gensym proc)))))
436 ((and (lambda-case? lcase)
437 (not (lambda-case-kw lcase))
438 (not (lambda-case-opt lcase))
439 (not (lambda-case-rest lcase))
440 (= (length args) (length (lambda-case-req lcase))))
441 ;; we have a case that matches the args; rename variables
442 ;; and goto the case label
443 (for-each (lambda (sym)
444 (pmatch (hashq-ref (hashq-ref allocation sym) self)
445 ((#t #f . ,index) ; unboxed
446 (emit-code #f (make-glil-lexical #t #f 'set index)))
447 ((#t #t . ,index) ; boxed
448 (emit-code #f (make-glil-lexical #t #t 'box index)))
449 (,x (error "what" x))))
450 (reverse (lambda-case-vars lcase)))
451 (emit-branch src 'br (car (hashq-ref allocation lcase))))
452 ((lambda-case? lcase)
453 ;; no match, try next case
454 (lp (lambda-case-else lcase)))
456 ;; no cases left. we can't really handle this currently.
457 ;; ideally we would push on a new frame, then do a "local
458 ;; call" -- which doesn't require consing up a program
459 ;; object. but for now error, as this sort of case should
460 ;; preclude label allocation.
461 (error "couldn't find matching case for label call" x)))))
464 (if (not (eq? context 'tail))
465 (emit-code src (make-glil-call 'new-frame 0)))
467 (for-each comp-push args)
468 (let ((len (length args)))
470 ((tail) (emit-code src (make-glil-call 'goto/args len)))
471 ((push) (emit-code src (make-glil-call 'call len))
473 ((vals) (emit-code src (make-glil-mv-call len MVRA))
475 ((drop) (let ((MV (make-label)) (POST (make-label)))
476 (emit-code src (make-glil-mv-call len MV))
477 (emit-code #f (make-glil-call 'drop 1))
478 (emit-branch #f 'br (or RA POST))
480 (emit-code #f (make-glil-mv-bind '() #f))
481 (emit-code #f (make-glil-unbind))
483 (emit-branch #f 'br RA)
484 (emit-label POST)))))))))
486 ((<conditional> src test then else)
493 (let ((L1 (make-label)) (L2 (make-label)))
495 (emit-branch src 'br-if-not L1)
497 ;; if there is an RA, comp-tail will cause a jump to it -- just
498 ;; have to clean up here if there is no RA.
499 (if (and (not RA) (not (eq? context 'tail)))
500 (emit-branch #f 'br L2))
503 (if (and (not RA) (not (eq? context 'tail)))
506 ((<primitive-ref> src name)
508 ((eq? (module-variable (fluid-ref *comp-module*) name)
509 (module-variable the-root-module name))
512 (emit-code src (make-glil-toplevel 'ref name))))
514 ((module-variable the-root-module name)
517 (emit-code src (make-glil-module 'ref '(guile) name #f))))
522 (emit-code src (make-glil-module
523 'ref (module-name (fluid-ref *comp-module*)) name #f))))
524 (maybe-emit-return))))
526 ((<lexical-ref> src gensym)
529 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
530 ((,local? ,boxed? . ,index)
531 (emit-code src (make-glil-lexical local? boxed? 'ref index)))
533 (error "badness" x loc)))))
536 ((<lexical-set> src gensym exp)
538 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
539 ((,local? ,boxed? . ,index)
540 (emit-code src (make-glil-lexical local? boxed? 'set index)))
542 (error "badness" x loc)))
545 (emit-code #f (make-glil-void))))
548 ((<module-ref> src mod name public?)
549 (emit-code src (make-glil-module 'ref mod name public?))
551 ((drop) (emit-code #f (make-glil-call 'drop 1))))
554 ((<module-set> src mod name public? exp)
556 (emit-code src (make-glil-module 'set mod name public?))
559 (emit-code #f (make-glil-void))))
562 ((<toplevel-ref> src name)
563 (emit-code src (make-glil-toplevel 'ref name))
565 ((drop) (emit-code #f (make-glil-call 'drop 1))))
568 ((<toplevel-set> src name exp)
570 (emit-code src (make-glil-toplevel 'set name))
573 (emit-code #f (make-glil-void))))
576 ((<toplevel-define> src name exp)
578 (emit-code src (make-glil-toplevel 'define name))
581 (emit-code #f (make-glil-void))))
585 (let ((free-locs (cdr (hashq-ref allocation x))))
588 (emit-code #f (flatten-lambda x #f allocation))
589 (if (not (null? free-locs))
594 ((,local? ,boxed? . ,n)
595 (emit-code #f (make-glil-lexical local? #f 'ref n)))
596 (else (error "what" x loc))))
598 (emit-code #f (make-glil-call 'vector (length free-locs)))
599 (emit-code #f (make-glil-call 'make-closure 2)))))))
602 ((<lambda-case> src req opt rest kw inits vars predicate else body)
603 ;; o/~ feature on top of feature o/~
605 ;; opt := (name ...) | #f
607 ;; kw: (allow-other-keys? (keyword name var) ...) | #f
609 ;; predicate: tree-il in context of vars
610 ;; init: tree-il in context of vars
611 ;; vars map to named arguments in the following order:
612 ;; required, optional (positional), rest, keyword.
613 (let* ((nreq (length req))
614 (nopt (if opt (length opt) 0))
615 (rest-idx (and rest (+ nreq nopt)))
616 (opt-names (or opt '()))
617 (allow-other-keys? (if kw (car kw) #f))
618 (kw-indices (map (lambda (x)
621 (cons key (list-index vars var)))
622 (else (error "bad kwarg" x))))
623 (if kw (cdr kw) '())))
624 (nargs (apply max (+ nreq nopt (if rest 1 0))
625 (map 1+ (map cdr kw-indices))))
626 (nlocs (cdr (hashq-ref allocation x)))
627 (else-label (and else (make-label))))
630 (+ nreq (length inits) (if rest 1 0)))
631 (error "something went wrong"
632 req opt rest kw inits vars nreq nopt kw-indices nargs))
633 ;; the prelude, to check args & reset the stack pointer,
634 ;; allowing room for locals
639 (make-glil-kw-prelude nreq nopt rest-idx kw-indices
640 allow-other-keys? nlocs else-label))
642 (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
644 (make-glil-std-prelude nreq nlocs else-label))))
645 ;; box args if necessary
648 (pmatch (hashq-ref (hashq-ref allocation v) self)
650 (emit-code #f (make-glil-lexical #t #f 'ref n))
651 (emit-code #f (make-glil-lexical #t #t 'box n)))))
653 ;; write bindings info
654 (if (not (null? vars))
657 (let lp ((kw (if kw (cdr kw) '()))
658 (names (append (reverse opt-names) (reverse req)))
659 (vars (list-tail vars (+ nreq nopt
663 ;; fixme: check that vars is empty
664 (reverse (if rest (cons rest names) names)))
665 (((,key ,name ,var) . ,kw)
667 (lp kw (cons name names) (delq var vars))
669 (,kw (error "bad keywords, yo" kw))))
670 vars allocation self emit-code))
671 ;; init optional/kw args
672 (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
674 ((null? inits)) ; done
675 ((and rest-idx (= n rest-idx))
676 (lp inits (1+ n) (cdr vars)))
678 (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
679 ((#t ,boxed? . ,n*) (guard (= n* n))
680 (let ((L (make-label)))
681 (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
682 (emit-code #f (make-glil-branch 'br-if L))
683 (comp-push (car inits))
684 (emit-code #f (make-glil-lexical #t boxed? 'set n))
686 (lp (cdr inits) (1+ n) (cdr vars))))
687 (#t (error "what" inits))))))
688 ;; post-prelude case label for label calls
689 (emit-label (car (hashq-ref allocation x)))
692 (comp-push predicate)
694 ;; fixme: debox if necessary
695 (emit-branch src 'br-if-not else-label)
696 (comp-push (make-application
697 src (make-primitive-ref #f 'error)
698 (list (make-const #f "precondition not met")))))))
700 (if (not (null? vars))
701 (emit-code #f (make-glil-unbind)))
704 (emit-label else-label)
707 ((<let> src names vars vals body)
708 (for-each comp-push vals)
709 (emit-bindings src names vars allocation self emit-code)
710 (for-each (lambda (v)
711 (pmatch (hashq-ref (hashq-ref allocation v) self)
713 (emit-code src (make-glil-lexical #t #f 'set n)))
715 (emit-code src (make-glil-lexical #t #t 'box n)))
716 (,loc (error "badness" x loc))))
719 (emit-code #f (make-glil-unbind)))
721 ((<letrec> src names vars vals body)
722 (for-each (lambda (v)
723 (pmatch (hashq-ref (hashq-ref allocation v) self)
725 (emit-code src (make-glil-lexical #t #t 'empty-box n)))
726 (,loc (error "badness" x loc))))
728 (for-each comp-push vals)
729 (emit-bindings src names vars allocation self emit-code)
730 (for-each (lambda (v)
731 (pmatch (hashq-ref (hashq-ref allocation v) self)
733 (emit-code src (make-glil-lexical #t #t 'set n)))
734 (,loc (error "badness" x loc))))
737 (emit-code #f (make-glil-unbind)))
739 ((<fix> src names vars vals body)
740 ;; The ideal here is to just render the lambda bodies inline, and
741 ;; wire the code together with gotos. We can do that if
742 ;; analyze-lexicals has determined that a given var has "label"
743 ;; allocation -- which is the case if it is in `fix-labels'.
745 ;; But even for closures that we can't inline, we can do some
746 ;; tricks to avoid heap-allocation for the binding itself. Since
747 ;; we know the vals are lambdas, we can set them to their local
748 ;; var slots first, then capture their bindings, mutating them in
750 (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
754 ((hashq-ref allocation x)
755 ;; allocating a closure
756 (emit-code #f (flatten-lambda x v allocation))
757 (if (not (null? (cdr (hashq-ref allocation x))))
758 ;; Need to make-closure first, but with a temporary #f
759 ;; free-variables vector, so we are mutating fresh
760 ;; closures on the heap.
762 (emit-code #f (make-glil-const #f))
763 (emit-code #f (make-glil-call 'make-closure 2))))
764 (pmatch (hashq-ref (hashq-ref allocation v) self)
766 (emit-code src (make-glil-lexical #t #f 'set n)))
767 (,loc (error "badness" x loc))))
769 ;; labels allocation: emit label & body, but jump over it
770 (let ((POST (make-label)))
771 (emit-branch #f 'br POST)
772 (let lp ((lcase (lambda-body x)))
775 ((<lambda-case> src req vars body else)
776 (emit-label (car (hashq-ref allocation lcase)))
777 ;; FIXME: opt & kw args in the bindings
778 (emit-bindings #f req vars allocation self emit-code)
780 (emit-code #f (make-glil-source src)))
781 (comp-fix body (or RA new-RA))
782 (emit-code #f (make-glil-unbind))
784 (emit-label POST)))))))
787 ;; Emit bindings metadata for closures
788 (let ((binds (let lp ((out '()) (vars vars) (names names))
789 (cond ((null? vars) (reverse! out))
790 ((assq (car vars) fix-labels)
791 (lp out (cdr vars) (cdr names)))
793 (lp (acons (car vars) (car names) out)
794 (cdr vars) (cdr names)))))))
795 (emit-bindings src (map cdr binds) (map car binds)
796 allocation self emit-code))
797 ;; Now go back and fix up the bindings for closures.
800 (let ((free-locs (if (hashq-ref allocation x)
801 (cdr (hashq-ref allocation x))
802 ;; can hit this latter case for labels allocation
804 (if (not (null? free-locs))
809 ((,local? ,boxed? . ,n)
810 (emit-code #f (make-glil-lexical local? #f 'ref n)))
811 (else (error "what" x loc))))
813 (emit-code #f (make-glil-call 'vector (length free-locs)))
814 (pmatch (hashq-ref (hashq-ref allocation v) self)
816 (emit-code #f (make-glil-lexical #t #f 'fix n)))
817 (,loc (error "badness" x loc)))))))
823 (emit-code #f (make-glil-unbind))))
825 ((<let-values> src exp body)
827 ((<lambda-case> req opt kw rest vars predicate body else)
828 (if (or opt kw predicate else)
829 (error "unexpected lambda-case in let-values" x))
830 (let ((MV (make-label)))
832 (emit-code #f (make-glil-const 1))
834 (emit-code src (make-glil-mv-bind
836 (append req (if rest (list rest) '()))
837 vars allocation self)
839 (for-each (lambda (v)
840 (pmatch (hashq-ref (hashq-ref allocation v) self)
842 (emit-code src (make-glil-lexical #t #f 'set n)))
844 (emit-code src (make-glil-lexical #t #t 'box n)))
845 (,loc (error "badness" x loc))))
848 (emit-code #f (make-glil-unbind)))))))))