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 -> (nlocs labels . free-locs)
37 ;; address := (local? boxed? . index)
38 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
39 ;; free variable addresses are relative to parent proc.
41 (define *comp-module* (make-fluid))
43 (define %warning-passes
44 `((unused-variable . ,report-unused-variables)
45 (unbound-variable . ,report-possibly-unbound-variables)))
47 (define (compile-glil x e opts)
49 (or (and=> (memq #:warnings opts) cadr)
52 ;; Go through the warning passes.
53 (for-each (lambda (kind)
54 (let ((warn (assoc-ref %warning-passes kind)))
55 (and (procedure? warn)
59 (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
60 (x (optimize! x e opts))
61 (allocation (analyze-lexicals x)))
63 (with-fluid* *comp-module* e
65 (values (flatten-lambda x #f allocation)
71 (define *primcall-ops* (make-hash-table))
73 (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
76 ((equal? . 2) . equal?)
88 ((quotient . 2) . quo)
89 ((remainder . 2) . rem)
96 ((set-car! . 2) . set-car!)
97 ((set-cdr! . 2) . set-cdr!)
102 ((@slot-ref . 2) . slot-ref)
103 ((@slot-set! . 3) . slot-set)
104 ((vector-ref . 2) . vector-ref)
105 ((vector-set! . 3) . vector-set)
107 ((bytevector-u8-ref . 2) . bv-u8-ref)
108 ((bytevector-u8-set! . 3) . bv-u8-set)
109 ((bytevector-s8-ref . 2) . bv-s8-ref)
110 ((bytevector-s8-set! . 3) . bv-s8-set)
112 ((bytevector-u16-ref . 3) . bv-u16-ref)
113 ((bytevector-u16-set! . 4) . bv-u16-set)
114 ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
115 ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
116 ((bytevector-s16-ref . 3) . bv-s16-ref)
117 ((bytevector-s16-set! . 4) . bv-s16-set)
118 ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
119 ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
121 ((bytevector-u32-ref . 3) . bv-u32-ref)
122 ((bytevector-u32-set! . 4) . bv-u32-set)
123 ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
124 ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
125 ((bytevector-s32-ref . 3) . bv-s32-ref)
126 ((bytevector-s32-set! . 4) . bv-s32-set)
127 ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
128 ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
130 ((bytevector-u64-ref . 3) . bv-u64-ref)
131 ((bytevector-u64-set! . 4) . bv-u64-set)
132 ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
133 ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
134 ((bytevector-s64-ref . 3) . bv-s64-ref)
135 ((bytevector-s64-set! . 4) . bv-s64-set)
136 ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
137 ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
139 ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
140 ((bytevector-ieee-single-set! . 4) . bv-f32-set)
141 ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
142 ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
143 ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
144 ((bytevector-ieee-double-set! . 4) . bv-f64-set)
145 ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
146 ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
151 (define (make-label) (gensym ":L"))
153 (define (vars->bind-list ids vars allocation proc)
155 (pmatch (hashq-ref (hashq-ref allocation v) proc)
158 (,x (error "badness" x))))
162 (define (emit-bindings src ids vars allocation proc emit-code)
163 (emit-code src (make-glil-bind
164 (vars->bind-list ids vars allocation proc))))
166 (define (with-output-to-code proc)
168 (define (emit-code src x)
169 (set! out (cons x out))
171 (set! out (cons (make-glil-source src) out))))
175 (define (flatten-lambda x self-label allocation)
176 (receive (ids vars nargs nrest)
177 (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
178 (oids '()) (ovars '()) (n 0))
179 (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
180 ((pair? vars) (lp (cdr ids) (cdr vars)
181 (cons (car ids) oids) (cons (car vars) ovars)
183 (else (values (reverse (cons ids oids))
184 (reverse (cons vars ovars))
186 (let ((nlocs (car (hashq-ref allocation x)))
187 (labels (cadr (hashq-ref allocation x))))
192 ;; write source info for proc
194 (emit-code #f (make-glil-source (lambda-src x))))
195 ;; the prelude, to check args & reset the stack pointer,
196 ;; allowing room for locals
198 (emit-code #f (make-glil-std-prelude nargs nlocs #f))
199 (emit-code #f (make-glil-opt-prelude (1- nargs) 0 #t nlocs #f)))
200 ;; write bindings info
201 (if (not (null? ids))
202 (emit-bindings #f ids vars allocation x emit-code))
203 ;; post-prelude label for self tail calls
205 (emit-code #f (make-glil-label self-label)))
206 ;; box args if necessary
209 (pmatch (hashq-ref (hashq-ref allocation v) x)
211 (emit-code #f (make-glil-lexical #t #f 'ref n))
212 (emit-code #f (make-glil-lexical #t #t 'box n)))))
214 ;; and here, here, dear reader: we compile.
215 (flatten (lambda-body x) allocation x self-label
216 labels emit-code)))))))
218 (define (flatten x allocation self self-label fix-labels emit-code)
219 (define (emit-label label)
220 (emit-code #f (make-glil-label label)))
221 (define (emit-branch src inst label)
222 (emit-code src (make-glil-branch inst label)))
224 ;; RA: "return address"; #f unless we're in a non-tail fix with labels
225 ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
226 (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
227 (define (comp-tail tree) (comp tree context RA MVRA))
228 (define (comp-push tree) (comp tree 'push #f #f))
229 (define (comp-drop tree) (comp tree 'drop #f #f))
230 (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
231 (define (comp-fix tree RA) (comp tree context RA MVRA))
233 ;; A couple of helpers. Note that if we are in tail context, we
235 (define (maybe-emit-return)
237 (emit-branch #f 'br RA)
238 (if (eq? context 'tail)
239 (emit-code #f (make-glil-call 'return 1)))))
245 (emit-code #f (make-glil-void))))
251 (emit-code src (make-glil-const exp))))
254 ;; FIXME: should represent sequence as exps tail
256 (let lp ((exps exps))
257 (if (null? (cdr exps))
258 (comp-tail (car exps))
260 (comp-drop (car exps))
263 ((<application> src proc args)
264 ;; FIXME: need a better pattern-matcher here
266 ((and (primitive-ref? proc)
267 (eq? (primitive-ref-name proc) '@apply)
268 (>= (length args) 1))
269 (let ((proc (car args))
272 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
273 (not (eq? context 'push)) (not (eq? context 'vals)))
274 ;; tail: (lambda () (apply values '(1 2)))
275 ;; drop: (lambda () (apply values '(1 2)) 3)
276 ;; push: (lambda () (list (apply values '(10 12)) 1))
278 ((drop) (for-each comp-drop args) (maybe-emit-return))
280 (for-each comp-push args)
281 (emit-code src (make-glil-call 'return/values* (length args))))))
287 (for-each comp-push args)
288 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
290 (emit-code src (make-glil-call 'new-frame 0))
292 (for-each comp-push args)
293 (emit-code src (make-glil-call 'apply (1+ (length args))))
297 (make-application src (make-primitive-ref #f 'apply)
302 ;; Well, shit. The proc might return any number of
303 ;; values (including 0), since it's in a drop context,
304 ;; yet apply does not create a MV continuation. So we
305 ;; mv-call out to our trampoline instead.
307 (make-application src (make-primitive-ref #f 'apply)
309 (maybe-emit-return)))))))
311 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
312 (not (eq? context 'push)))
313 ;; tail: (lambda () (values '(1 2)))
314 ;; drop: (lambda () (values '(1 2)) 3)
315 ;; push: (lambda () (list (values '(10 12)) 1))
316 ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
318 ((drop) (for-each comp-drop args) (maybe-emit-return))
320 (for-each comp-push args)
321 (emit-code #f (make-glil-const (length args)))
322 (emit-branch src 'br MVRA))
324 (for-each comp-push args)
325 (emit-code src (make-glil-call 'return/values (length args))))))
327 ((and (primitive-ref? proc)
328 (eq? (primitive-ref-name proc) '@call-with-values)
335 ;; MV: [tail-]call/nargs
336 ;; POST: (maybe-drop)
341 (make-application src (make-primitive-ref #f 'call-with-values)
346 (let ((MV (make-label)) (POST (make-label))
347 (producer (car args)) (consumer (cadr args)))
348 (if (not (eq? context 'tail))
349 (emit-code src (make-glil-call 'new-frame 0)))
351 (emit-code src (make-glil-call 'new-frame 0))
353 (emit-code src (make-glil-mv-call 0 MV))
355 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
356 (else (emit-code src (make-glil-call 'call 1))
357 (emit-branch #f 'br POST)))
360 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
361 (else (emit-code src (make-glil-call 'call/nargs 0))
363 (if (eq? context 'drop)
364 (emit-code #f (make-glil-call 'drop 1)))
365 (maybe-emit-return)))))))
367 ((and (primitive-ref? proc)
368 (eq? (primitive-ref-name proc) '@call-with-current-continuation)
372 (comp-push (car args))
373 (emit-code src (make-glil-call 'goto/cc 1)))
377 src (make-primitive-ref #f 'call-with-current-continuation)
382 (comp-push (car args))
383 (emit-code src (make-glil-call 'call/cc 1))
386 ;; Crap. Just like `apply' in drop context.
389 src (make-primitive-ref #f 'call-with-current-continuation)
391 (maybe-emit-return))))
393 ((and (primitive-ref? proc)
394 (or (hash-ref *primcall-ops*
395 (cons (primitive-ref-name proc) (length args)))
396 (hash-ref *primcall-ops* (primitive-ref-name proc))))
398 (for-each comp-push args)
399 (emit-code src (make-glil-call op (length args)))
400 (case (instruction-pushes op)
403 ((tail push vals) (emit-code #f (make-glil-void))))
407 ((drop) (emit-code #f (make-glil-call 'drop 1))))
410 (error "bad primitive op: too many pushes"
411 op (instruction-pushes op))))))
414 ((and (lexical-ref? proc)
415 self-label (eq? (lexical-ref-gensym proc) self-label)
416 ;; self-call in tail position is a goto
418 ;; make sure the arity is right
419 (list? (lambda-vars self))
420 (= (length args) (length (lambda-vars self))))
421 ;; evaluate new values
422 (for-each comp-push args)
424 (for-each (lambda (sym)
425 (pmatch (hashq-ref (hashq-ref allocation sym) self)
426 ((#t ,boxed? . ,index)
427 ;; set unboxed, as the proc prelude will box if needed
428 (emit-code #f (make-glil-lexical #t #f 'set index)))
429 (,x (error "what" x))))
430 (reverse (lambda-vars self)))
431 (emit-branch src 'br self-label))
433 ;; lambda, the ultimate goto
434 ((and (lexical-ref? proc)
435 (assq (lexical-ref-gensym proc) fix-labels))
436 ;; evaluate new values, assuming that analyze-lexicals did its
437 ;; job, and that the arity was right
438 (for-each comp-push args)
440 (for-each (lambda (sym)
441 (pmatch (hashq-ref (hashq-ref allocation sym) self)
443 (emit-code #f (make-glil-lexical #t #f 'set index)))
445 (emit-code #f (make-glil-lexical #t #t 'box index)))
446 (,x (error "what" x))))
447 (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
449 (emit-branch src 'br (lexical-ref-gensym proc)))
452 (if (not (eq? context 'tail))
453 (emit-code src (make-glil-call 'new-frame 0)))
455 (for-each comp-push args)
456 (let ((len (length args)))
458 ((tail) (emit-code src (make-glil-call 'goto/args len)))
459 ((push) (emit-code src (make-glil-call 'call len))
461 ((vals) (emit-code src (make-glil-mv-call len MVRA))
463 ((drop) (let ((MV (make-label)) (POST (make-label)))
464 (emit-code src (make-glil-mv-call len MV))
465 (emit-code #f (make-glil-call 'drop 1))
466 (emit-branch #f 'br (or RA POST))
468 (emit-code #f (make-glil-mv-bind '() #f))
469 (emit-code #f (make-glil-unbind))
471 (emit-branch #f 'br RA)
472 (emit-label POST)))))))))
474 ((<conditional> src test then else)
481 (let ((L1 (make-label)) (L2 (make-label)))
483 (emit-branch src 'br-if-not L1)
485 ;; if there is an RA, comp-tail will cause a jump to it -- just
486 ;; have to clean up here if there is no RA.
487 (if (and (not RA) (not (eq? context 'tail)))
488 (emit-branch #f 'br L2))
491 (if (and (not RA) (not (eq? context 'tail)))
494 ((<primitive-ref> src name)
496 ((eq? (module-variable (fluid-ref *comp-module*) name)
497 (module-variable the-root-module name))
500 (emit-code src (make-glil-toplevel 'ref name))))
502 ((module-variable the-root-module name)
505 (emit-code src (make-glil-module 'ref '(guile) name #f))))
510 (emit-code src (make-glil-module
511 'ref (module-name (fluid-ref *comp-module*)) name #f))))
512 (maybe-emit-return))))
514 ((<lexical-ref> src gensym)
517 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
518 ((,local? ,boxed? . ,index)
519 (emit-code src (make-glil-lexical local? boxed? 'ref index)))
521 (error "badness" x loc)))))
524 ((<lexical-set> src gensym exp)
526 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
527 ((,local? ,boxed? . ,index)
528 (emit-code src (make-glil-lexical local? boxed? 'set index)))
530 (error "badness" x loc)))
533 (emit-code #f (make-glil-void))))
536 ((<module-ref> src mod name public?)
537 (emit-code src (make-glil-module 'ref mod name public?))
539 ((drop) (emit-code #f (make-glil-call 'drop 1))))
542 ((<module-set> src mod name public? exp)
544 (emit-code src (make-glil-module 'set mod name public?))
547 (emit-code #f (make-glil-void))))
550 ((<toplevel-ref> src name)
551 (emit-code src (make-glil-toplevel 'ref name))
553 ((drop) (emit-code #f (make-glil-call 'drop 1))))
556 ((<toplevel-set> src name exp)
558 (emit-code src (make-glil-toplevel 'set name))
561 (emit-code #f (make-glil-void))))
564 ((<toplevel-define> src name exp)
566 (emit-code src (make-glil-toplevel 'define name))
569 (emit-code #f (make-glil-void))))
573 (let ((free-locs (cddr (hashq-ref allocation x))))
576 (emit-code #f (flatten-lambda x #f allocation))
577 (if (not (null? free-locs))
582 ((,local? ,boxed? . ,n)
583 (emit-code #f (make-glil-lexical local? #f 'ref n)))
584 (else (error "what" x loc))))
586 (emit-code #f (make-glil-call 'vector (length free-locs)))
587 (emit-code #f (make-glil-call 'make-closure 2)))))))
590 ((<let> src names vars vals body)
591 (for-each comp-push vals)
592 (emit-bindings src names vars allocation self emit-code)
593 (for-each (lambda (v)
594 (pmatch (hashq-ref (hashq-ref allocation v) self)
596 (emit-code src (make-glil-lexical #t #f 'set n)))
598 (emit-code src (make-glil-lexical #t #t 'box n)))
599 (,loc (error "badness" x loc))))
602 (emit-code #f (make-glil-unbind)))
604 ((<letrec> src names vars vals body)
605 (for-each (lambda (v)
606 (pmatch (hashq-ref (hashq-ref allocation v) self)
608 (emit-code src (make-glil-lexical #t #t 'empty-box n)))
609 (,loc (error "badness" x loc))))
611 (for-each comp-push vals)
612 (emit-bindings src names vars allocation self emit-code)
613 (for-each (lambda (v)
614 (pmatch (hashq-ref (hashq-ref allocation v) self)
616 (emit-code src (make-glil-lexical #t #t 'set n)))
617 (,loc (error "badness" x loc))))
620 (emit-code #f (make-glil-unbind)))
622 ((<fix> src names vars vals body)
623 ;; The ideal here is to just render the lambda bodies inline, and
624 ;; wire the code together with gotos. We can do that if
625 ;; analyze-lexicals has determined that a given var has "label"
626 ;; allocation -- which is the case if it is in `fix-labels'.
628 ;; But even for closures that we can't inline, we can do some
629 ;; tricks to avoid heap-allocation for the binding itself. Since
630 ;; we know the vals are lambdas, we can set them to their local
631 ;; var slots first, then capture their bindings, mutating them in
633 (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
637 ((hashq-ref allocation x)
638 ;; allocating a closure
639 (emit-code #f (flatten-lambda x v allocation))
640 (if (not (null? (cddr (hashq-ref allocation x))))
641 ;; Need to make-closure first, but with a temporary #f
642 ;; free-variables vector, so we are mutating fresh
643 ;; closures on the heap.
645 (emit-code #f (make-glil-const #f))
646 (emit-code #f (make-glil-call 'make-closure 2))))
647 (pmatch (hashq-ref (hashq-ref allocation v) self)
649 (emit-code src (make-glil-lexical #t #f 'set n)))
650 (,loc (error "badness" x loc))))
652 ;; labels allocation: emit label & body, but jump over it
653 (let ((POST (make-label)))
654 (emit-branch #f 'br POST)
656 ;; we know the lambda vars are a list
657 (emit-bindings #f (lambda-names x) (lambda-vars x)
658 allocation self emit-code)
660 (emit-code #f (make-glil-source (lambda-src x))))
661 (comp-fix (lambda-body x) (or RA new-RA))
662 (emit-code #f (make-glil-unbind))
663 (emit-label POST)))))
666 ;; Emit bindings metadata for closures
667 (let ((binds (let lp ((out '()) (vars vars) (names names))
668 (cond ((null? vars) (reverse! out))
669 ((assq (car vars) fix-labels)
670 (lp out (cdr vars) (cdr names)))
672 (lp (acons (car vars) (car names) out)
673 (cdr vars) (cdr names)))))))
674 (emit-bindings src (map cdr binds) (map car binds)
675 allocation self emit-code))
676 ;; Now go back and fix up the bindings for closures.
679 (let ((free-locs (if (hashq-ref allocation x)
680 (cddr (hashq-ref allocation x))
681 ;; can hit this latter case for labels allocation
683 (if (not (null? free-locs))
688 ((,local? ,boxed? . ,n)
689 (emit-code #f (make-glil-lexical local? #f 'ref n)))
690 (else (error "what" x loc))))
692 (emit-code #f (make-glil-call 'vector (length free-locs)))
693 (pmatch (hashq-ref (hashq-ref allocation v) self)
695 (emit-code #f (make-glil-lexical #t #f 'fix n)))
696 (,loc (error "badness" x loc)))))))
702 (emit-code #f (make-glil-unbind))))
704 ((<let-values> src names vars exp body)
705 (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
708 (lp (cons (car inames) names) (cons (car ivars) vars)
709 (cdr inames) (cdr ivars) #f))
710 ((not (null? inames))
711 (lp (cons inames names) (cons ivars vars) '() '() #t))
713 (let ((names (reverse! names))
714 (vars (reverse! vars))
717 (emit-code #f (make-glil-const 1))
719 (emit-code src (make-glil-mv-bind
720 (vars->bind-list names vars allocation self)
722 (for-each (lambda (v)
723 (pmatch (hashq-ref (hashq-ref allocation v) self)
725 (emit-code src (make-glil-lexical #t #f 'set n)))
727 (emit-code src (make-glil-lexical #t #t 'box n)))
728 (,loc (error "badness" x loc))))
731 (emit-code #f (make-glil-unbind))))))))))