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))
35 ;; call-with-values -> mv-bind
36 ;; basic degenerate-case reduction
39 ;; sym -> {lambda -> address}
40 ;; lambda -> (nlocs labels . free-locs)
42 ;; address := (local? boxed? . index)
43 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
44 ;; free variable addresses are relative to parent proc.
46 (define *comp-module* (make-fluid))
48 (define %warning-passes
49 `((unused-variable . ,report-unused-variables)))
51 (define (compile-glil x e opts)
53 (or (and=> (memq #:warnings opts) cadr)
56 ;; Go throught the warning passes.
57 (for-each (lambda (kind)
58 (let ((warn (assoc-ref %warning-passes kind)))
59 (and (procedure? warn)
63 (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
64 (x (optimize! x e opts))
65 (allocation (analyze-lexicals x)))
67 (with-fluid* *comp-module* (or (and e (car e)) (current-module))
69 (values (flatten-lambda x #f allocation)
70 (and e (cons (car e) (cddr e)))
75 (define *primcall-ops* (make-hash-table))
77 (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
80 ((equal? . 2) . equal?)
92 ((quotient . 2) . quo)
93 ((remainder . 2) . rem)
100 ((set-car! . 2) . set-car!)
101 ((set-cdr! . 2) . set-cdr!)
102 ((null? . 1) . null?)
103 ((list? . 1) . list?)
106 ((@slot-ref . 2) . slot-ref)
107 ((@slot-set! . 3) . slot-set)
108 ((vector-ref . 2) . vector-ref)
109 ((vector-set! . 3) . vector-set)
111 ((bytevector-u8-ref . 2) . bv-u8-ref)
112 ((bytevector-u8-set! . 3) . bv-u8-set)
113 ((bytevector-s8-ref . 2) . bv-s8-ref)
114 ((bytevector-s8-set! . 3) . bv-s8-set)
116 ((bytevector-u16-ref . 3) . bv-u16-ref)
117 ((bytevector-u16-set! . 4) . bv-u16-set)
118 ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
119 ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
120 ((bytevector-s16-ref . 3) . bv-s16-ref)
121 ((bytevector-s16-set! . 4) . bv-s16-set)
122 ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
123 ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
125 ((bytevector-u32-ref . 3) . bv-u32-ref)
126 ((bytevector-u32-set! . 4) . bv-u32-set)
127 ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
128 ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
129 ((bytevector-s32-ref . 3) . bv-s32-ref)
130 ((bytevector-s32-set! . 4) . bv-s32-set)
131 ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
132 ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
134 ((bytevector-u64-ref . 3) . bv-u64-ref)
135 ((bytevector-u64-set! . 4) . bv-u64-set)
136 ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
137 ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
138 ((bytevector-s64-ref . 3) . bv-s64-ref)
139 ((bytevector-s64-set! . 4) . bv-s64-set)
140 ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
141 ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
143 ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
144 ((bytevector-ieee-single-set! . 4) . bv-f32-set)
145 ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
146 ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
147 ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
148 ((bytevector-ieee-double-set! . 4) . bv-f64-set)
149 ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
150 ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
155 (define (make-label) (gensym ":L"))
157 (define (vars->bind-list ids vars allocation proc)
159 (pmatch (hashq-ref (hashq-ref allocation v) proc)
162 (,x (error "badness" x))))
166 ;; FIXME: always emit? otherwise it's hard to pair bind with unbind
167 (define (emit-bindings src ids vars allocation proc emit-code)
168 (emit-code src (make-glil-bind
169 (vars->bind-list ids vars allocation proc))))
171 (define (with-output-to-code proc)
173 (define (emit-code src x)
174 (set! out (cons x out))
176 (set! out (cons (make-glil-source src) out))))
180 (define (flatten-lambda x self-label allocation)
181 (receive (ids vars nargs nrest)
182 (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
183 (oids '()) (ovars '()) (n 0))
184 (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
185 ((pair? vars) (lp (cdr ids) (cdr vars)
186 (cons (car ids) oids) (cons (car vars) ovars)
188 (else (values (reverse (cons ids oids))
189 (reverse (cons vars ovars))
191 (let ((nlocs (car (hashq-ref allocation x)))
192 (labels (cadr (hashq-ref allocation x))))
194 nargs nrest nlocs (lambda-meta x)
197 ;; emit label for self tail calls
199 (emit-code #f (make-glil-label self-label)))
200 ;; write bindings and source debugging info
201 (if (not (null? ids))
202 (emit-bindings #f ids vars allocation x emit-code))
204 (emit-code #f (make-glil-source (lambda-src x))))
205 ;; box args if necessary
208 (pmatch (hashq-ref (hashq-ref allocation v) x)
210 (emit-code #f (make-glil-lexical #t #f 'ref n))
211 (emit-code #f (make-glil-lexical #t #t 'box n)))))
213 ;; and here, here, dear reader: we compile.
214 (flatten (lambda-body x) allocation x self-label
215 labels emit-code)))))))
217 (define (flatten x allocation self self-label fix-labels emit-code)
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 x) (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)))))
244 (emit-code #f (make-glil-void))))
250 (emit-code src (make-glil-const exp))))
253 ;; FIXME: should represent sequence as exps tail
254 ((<sequence> src exps)
255 (let lp ((exps exps))
256 (if (null? (cdr exps))
257 (comp-tail (car exps))
259 (comp-drop (car exps))
262 ((<application> src proc args)
263 ;; FIXME: need a better pattern-matcher here
265 ((and (primitive-ref? proc)
266 (eq? (primitive-ref-name proc) '@apply)
267 (>= (length args) 1))
268 (let ((proc (car args))
271 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
272 (not (eq? context 'push)) (not (eq? context 'vals)))
273 ;; tail: (lambda () (apply values '(1 2)))
274 ;; drop: (lambda () (apply values '(1 2)) 3)
275 ;; push: (lambda () (list (apply values '(10 12)) 1))
277 ((drop) (for-each comp-drop args) (maybe-emit-return))
279 (for-each comp-push args)
280 (emit-code src (make-glil-call 'return/values* (length args))))))
286 (for-each comp-push args)
287 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
289 (emit-code src (make-glil-call 'new-frame 0))
291 (for-each comp-push args)
292 (emit-code src (make-glil-call 'apply (1+ (length args))))
296 (make-application src (make-primitive-ref #f 'apply)
301 ;; Well, shit. The proc might return any number of
302 ;; values (including 0), since it's in a drop context,
303 ;; yet apply does not create a MV continuation. So we
304 ;; mv-call out to our trampoline instead.
306 (make-application src (make-primitive-ref #f 'apply)
308 (maybe-emit-return)))))))
310 ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
311 (not (eq? context 'push)))
312 ;; tail: (lambda () (values '(1 2)))
313 ;; drop: (lambda () (values '(1 2)) 3)
314 ;; push: (lambda () (list (values '(10 12)) 1))
315 ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
317 ((drop) (for-each comp-drop args) (maybe-emit-return))
319 (for-each comp-push args)
320 (emit-code #f (make-glil-const (length args)))
321 (emit-branch src 'br MVRA))
323 (for-each comp-push args)
324 (emit-code src (make-glil-call 'return/values (length args))))))
326 ((and (primitive-ref? proc)
327 (eq? (primitive-ref-name proc) '@call-with-values)
334 ;; MV: [tail-]call/nargs
335 ;; POST: (maybe-drop)
340 (make-application src (make-primitive-ref #f 'call-with-values)
345 (let ((MV (make-label)) (POST (make-label))
346 (producer (car args)) (consumer (cadr args)))
347 (if (not (eq? context 'tail))
348 (emit-code src (make-glil-call 'new-frame 0)))
350 (emit-code src (make-glil-call 'new-frame 0))
352 (emit-code src (make-glil-mv-call 0 MV))
354 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
355 (else (emit-code src (make-glil-call 'call 1))
356 (emit-branch #f 'br POST)))
359 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
360 (else (emit-code src (make-glil-call 'call/nargs 0))
362 (if (eq? context 'drop)
363 (emit-code #f (make-glil-call 'drop 1)))
364 (maybe-emit-return)))))))
366 ((and (primitive-ref? proc)
367 (eq? (primitive-ref-name proc) '@call-with-current-continuation)
371 (comp-push (car args))
372 (emit-code src (make-glil-call 'goto/cc 1)))
376 src (make-primitive-ref #f 'call-with-current-continuation)
381 (comp-push (car args))
382 (emit-code src (make-glil-call 'call/cc 1))
385 ;; Crap. Just like `apply' in drop context.
388 src (make-primitive-ref #f 'call-with-current-continuation)
390 (maybe-emit-return))))
392 ((and (primitive-ref? proc)
393 (or (hash-ref *primcall-ops*
394 (cons (primitive-ref-name proc) (length args)))
395 (hash-ref *primcall-ops* (primitive-ref-name proc))))
397 (for-each comp-push args)
398 (emit-code src (make-glil-call op (length args)))
399 (case (instruction-pushes op)
402 ((tail push vals) (emit-code #f (make-glil-void))))
406 ((drop) (emit-code #f (make-glil-call 'drop 1))))
409 (error "bad primitive op: too many pushes"
410 op (instruction-pushes op))))))
413 ((and (lexical-ref? proc)
414 self-label (eq? (lexical-ref-gensym proc) self-label)
415 ;; self-call in tail position is a goto
417 ;; make sure the arity is right
418 (list? (lambda-vars self))
419 (= (length args) (length (lambda-vars self))))
420 ;; evaluate new values
421 (for-each comp-push args)
423 (for-each (lambda (sym)
424 (pmatch (hashq-ref (hashq-ref allocation sym) self)
425 ((#t ,boxed? . ,index)
426 ;; set unboxed, as the proc prelude will box if needed
427 (emit-code #f (make-glil-lexical #t #f 'set index)))
428 (,x (error "what" x))))
429 (reverse (lambda-vars self)))
430 (emit-branch src 'br self-label))
432 ;; lambda, the ultimate goto
433 ((and (lexical-ref? proc)
434 (assq (lexical-ref-gensym proc) fix-labels))
435 ;; evaluate new values, assuming that analyze-lexicals did its
436 ;; job, and that the arity was right
437 (for-each comp-push args)
439 (for-each (lambda (sym)
440 (pmatch (hashq-ref (hashq-ref allocation sym) self)
442 (emit-code #f (make-glil-lexical #t #f 'set index)))
444 (emit-code #f (make-glil-lexical #t #t 'box index)))
445 (,x (error "what" x))))
446 (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
448 (emit-branch src 'br (lexical-ref-gensym proc)))
451 (if (not (eq? context 'tail))
452 (emit-code src (make-glil-call 'new-frame 0)))
454 (for-each comp-push args)
455 (let ((len (length args)))
457 ((tail) (emit-code src (make-glil-call 'goto/args len)))
458 ((push) (emit-code src (make-glil-call 'call len))
460 ((vals) (emit-code src (make-glil-mv-call len MVRA))
462 ((drop) (let ((MV (make-label)) (POST (make-label)))
463 (emit-code src (make-glil-mv-call len MV))
464 (emit-code #f (make-glil-call 'drop 1))
465 (emit-branch #f 'br (or RA POST))
467 (emit-code #f (make-glil-mv-bind '() #f))
468 (emit-code #f (make-glil-unbind))
470 (emit-branch #f 'br RA)
471 (emit-label POST)))))))))
473 ((<conditional> src test then else)
480 (let ((L1 (make-label)) (L2 (make-label)))
482 (emit-branch src 'br-if-not L1)
484 ;; if there is an RA, comp-tail will cause a jump to it -- just
485 ;; have to clean up here if there is no RA.
486 (if (and (not RA) (not (eq? context 'tail)))
487 (emit-branch #f 'br L2))
490 (if (and (not RA) (not (eq? context 'tail)))
493 ((<primitive-ref> src name)
495 ((eq? (module-variable (fluid-ref *comp-module*) name)
496 (module-variable the-root-module name))
499 (emit-code src (make-glil-toplevel 'ref name))))
501 ((module-variable the-root-module name)
504 (emit-code src (make-glil-module 'ref '(guile) name #f))))
509 (emit-code src (make-glil-module
510 'ref (module-name (fluid-ref *comp-module*)) name #f))))
511 (maybe-emit-return))))
513 ((<lexical-ref> src name gensym)
516 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
517 ((,local? ,boxed? . ,index)
518 (emit-code src (make-glil-lexical local? boxed? 'ref index)))
520 (error "badness" x loc)))))
523 ((<lexical-set> src name gensym exp)
525 (pmatch (hashq-ref (hashq-ref allocation gensym) self)
526 ((,local? ,boxed? . ,index)
527 (emit-code src (make-glil-lexical local? boxed? 'set index)))
529 (error "badness" x loc)))
532 (emit-code #f (make-glil-void))))
535 ((<module-ref> src mod name public?)
536 (emit-code src (make-glil-module 'ref mod name public?))
538 ((drop) (emit-code #f (make-glil-call 'drop 1))))
541 ((<module-set> src mod name public? exp)
543 (emit-code src (make-glil-module 'set mod name public?))
546 (emit-code #f (make-glil-void))))
549 ((<toplevel-ref> src name)
550 (emit-code src (make-glil-toplevel 'ref name))
552 ((drop) (emit-code #f (make-glil-call 'drop 1))))
555 ((<toplevel-set> src name exp)
557 (emit-code src (make-glil-toplevel 'set name))
560 (emit-code #f (make-glil-void))))
563 ((<toplevel-define> src name exp)
565 (emit-code src (make-glil-toplevel 'define name))
568 (emit-code #f (make-glil-void))))
572 (let ((free-locs (cddr (hashq-ref allocation x))))
575 (emit-code #f (flatten-lambda x #f allocation))
576 (if (not (null? free-locs))
581 ((,local? ,boxed? . ,n)
582 (emit-code #f (make-glil-lexical local? #f 'ref n)))
583 (else (error "what" x loc))))
585 (emit-code #f (make-glil-call 'vector (length free-locs)))
586 (emit-code #f (make-glil-call 'make-closure 2)))))))
589 ((<let> src names vars vals body)
590 (for-each comp-push vals)
591 (emit-bindings src names vars allocation self emit-code)
592 (for-each (lambda (v)
593 (pmatch (hashq-ref (hashq-ref allocation v) self)
595 (emit-code src (make-glil-lexical #t #f 'set n)))
597 (emit-code src (make-glil-lexical #t #t 'box n)))
598 (,loc (error "badness" x loc))))
601 (emit-code #f (make-glil-unbind)))
603 ((<letrec> src names vars vals body)
604 (for-each (lambda (v)
605 (pmatch (hashq-ref (hashq-ref allocation v) self)
607 (emit-code src (make-glil-lexical #t #t 'empty-box n)))
608 (,loc (error "badness" x loc))))
610 (for-each comp-push vals)
611 (emit-bindings src names vars allocation self emit-code)
612 (for-each (lambda (v)
613 (pmatch (hashq-ref (hashq-ref allocation v) self)
615 (emit-code src (make-glil-lexical #t #t 'set n)))
616 (,loc (error "badness" x loc))))
619 (emit-code #f (make-glil-unbind)))
621 ((<fix> src names vars vals body)
622 ;; The ideal here is to just render the lambda bodies inline, and
623 ;; wire the code together with gotos. We can do that if
624 ;; analyze-lexicals has determined that a given var has "label"
625 ;; allocation -- which is the case if it is in `fix-labels'.
627 ;; But even for closures that we can't inline, we can do some
628 ;; tricks to avoid heap-allocation for the binding itself. Since
629 ;; we know the vals are lambdas, we can set them to their local
630 ;; var slots first, then capture their bindings, mutating them in
632 (let ((RA (if (eq? context 'tail) #f (make-label))))
636 ((hashq-ref allocation x)
637 ;; allocating a closure
638 (emit-code #f (flatten-lambda x v allocation))
639 (if (not (null? (cddr (hashq-ref allocation x))))
640 ;; Need to make-closure first, but with a temporary #f
641 ;; free-variables vector, so we are mutating fresh
642 ;; closures on the heap.
644 (emit-code #f (make-glil-const #f))
645 (emit-code #f (make-glil-call 'make-closure 2))))
646 (pmatch (hashq-ref (hashq-ref allocation v) self)
648 (emit-code src (make-glil-lexical #t #f 'set n)))
649 (,loc (error "badness" x loc))))
651 ;; labels allocation: emit label & body, but jump over it
652 (let ((POST (make-label)))
653 (emit-branch #f 'br POST)
655 ;; we know the lambda vars are a list
656 (emit-bindings #f (lambda-names x) (lambda-vars x)
657 allocation self emit-code)
659 (emit-code #f (make-glil-source (lambda-src x))))
660 (comp-fix (lambda-body x) RA)
661 (emit-code #f (make-glil-unbind))
662 (emit-label POST)))))
665 ;; Emit bindings metadata for closures
666 (let ((binds (let lp ((out '()) (vars vars) (names names))
667 (cond ((null? vars) (reverse! out))
668 ((assq (car vars) fix-labels)
669 (lp out (cdr vars) (cdr names)))
671 (lp (acons (car vars) (car names) out)
672 (cdr vars) (cdr names)))))))
673 (emit-bindings src (map cdr binds) (map car binds)
674 allocation self emit-code))
675 ;; Now go back and fix up the bindings for closures.
678 (let ((free-locs (if (hashq-ref allocation x)
679 (cddr (hashq-ref allocation x))
680 ;; can hit this latter case for labels allocation
682 (if (not (null? free-locs))
687 ((,local? ,boxed? . ,n)
688 (emit-code #f (make-glil-lexical local? #f 'ref n)))
689 (else (error "what" x loc))))
691 (emit-code #f (make-glil-call 'vector (length free-locs)))
692 (pmatch (hashq-ref (hashq-ref allocation v) self)
694 (emit-code #f (make-glil-lexical #t #f 'fix n)))
695 (,loc (error "badness" x loc)))))))
700 (emit-code #f (make-glil-unbind))))
702 ((<let-values> src names vars exp body)
703 (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
706 (lp (cons (car inames) names) (cons (car ivars) vars)
707 (cdr inames) (cdr ivars) #f))
708 ((not (null? inames))
709 (lp (cons inames names) (cons ivars vars) '() '() #t))
711 (let ((names (reverse! names))
712 (vars (reverse! vars))
715 (emit-code #f (make-glil-const 1))
717 (emit-code src (make-glil-mv-bind
718 (vars->bind-list names vars allocation self)
720 (for-each (lambda (v)
721 (pmatch (hashq-ref (hashq-ref allocation v) self)
723 (emit-code src (make-glil-lexical #t #f 'set n)))
725 (emit-code src (make-glil-lexical #t #t 'box n)))
726 (,loc (error "badness" x loc))))
729 (emit-code #f (make-glil-unbind))))))))))