mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 12:20:20 +02:00
tree-il -> glil compiler works now, at least in initial tests
* module/language/tree-il/analyze.scm: Break analyzer out into its own file. * module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler over to work on tree-il. Works, but still misses a number of important optimizations. * module/language/tree-il.scm: Add <void>. Not used quite yet. * module/language/glil.scm: Remove <glil-argument>, as it is the same as <glil-local> (minus an offset). * module/language/glil/compile-assembly.scm: * module/language/glil/decompile-assembly.scm: * module/language/ghil/compile-glil.scm: Adapt for <glil-argument> * removal. * module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add analyze.scm.
This commit is contained in:
Andy Wingo
parent
073bb617eb
commit
cf10678fe7
8 changed files with 456 additions and 517 deletions
|
|
@ -21,287 +21,123 @@
|
|||
|
||||
(define-module (language tree-il compile-glil)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (language glil)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il optimize)
|
||||
#:use-module (ice-9 common-list)
|
||||
#:use-module (language tree-il analyze)
|
||||
#:export (compile-glil))
|
||||
|
||||
;; parents: lambda -> parent
|
||||
;; useful when we see a closed-over var, so we can calculate its
|
||||
;; coordinates (depth and index).
|
||||
;; bindings: lambda -> (sym ...)
|
||||
;; useful for two reasons: one, so we know how much space to allocate
|
||||
;; when we go into a lambda; and two, so that we know when to stop,
|
||||
;; when looking for closed-over vars.
|
||||
;; heaps: sym -> lambda
|
||||
;; allows us to heapify vars in an O(1) fashion
|
||||
|
||||
;; allocation: the process of assigning a type and index to each var
|
||||
;; a var is external if it is heaps; assigning index is easy
|
||||
;; args are assigned in order
|
||||
;; locals are indexed as their linear position in the binding path
|
||||
;; (let (0 1)
|
||||
;; (let (2 3) ...)
|
||||
;; (let (2) ...))
|
||||
;; (let (2 3 4) ...))
|
||||
;; etc.
|
||||
|
||||
;; allocation:
|
||||
;; sym -> (local . index) | (heap level . index)
|
||||
|
||||
|
||||
(define (analyze-lexicals x)
|
||||
(define (find-diff parent this)
|
||||
(let lp ((parent parent) (n 0))
|
||||
(if (eq? parent this)
|
||||
n
|
||||
(lp (hashq-ref parents parent) (1+ n)))))
|
||||
|
||||
(define (find-heap sym parent)
|
||||
;; fixme: check displaced lexicals here?
|
||||
(if (memq sym (hashq-ref bindings parent))
|
||||
parent
|
||||
(find-binder sym (hashq-ref parents parent))))
|
||||
|
||||
(define (analyze! x parent level)
|
||||
(define (step y) (analyze! y parent level))
|
||||
(define (recur x parent) (analyze! x parent (1+ level)))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(step proc) (for-each step args))
|
||||
|
||||
((<conditional> test then else)
|
||||
(step test) (step then) (step else))
|
||||
|
||||
((<lexical-ref> name gensym)
|
||||
(if (and (not (memq gensym (hashq-ref bindings parent)))
|
||||
(not (hashq-ref heaps gensym)))
|
||||
(hashq-set! heaps gensym (find-heap gensym parent level))))
|
||||
|
||||
((<lexical-set> name gensym exp)
|
||||
(step exp)
|
||||
(if (not (hashq-ref heaps gensym))
|
||||
(hashq-set! heaps gensym (find-heap gensym parent level))))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(step exp))
|
||||
|
||||
((<toplevel-set> name exp)
|
||||
(step exp))
|
||||
|
||||
((<toplevel-define> name exp)
|
||||
(step exp))
|
||||
|
||||
((<sequence> exps)
|
||||
(for-each step exps))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
(hashq-set! parents x parent)
|
||||
(hashq-set! bindings x
|
||||
(let rev* ((vars vars) (out '()))
|
||||
(cond ((null? vars) out)
|
||||
((pair? vars) (rev* (cdr vars)
|
||||
(cons (car vars) out)))
|
||||
(else (cons vars out)))))
|
||||
(recur body x)
|
||||
(hashq-set! bindings x (reverse! (hashq-ref bindings x))))
|
||||
|
||||
((<let> vars vals exp)
|
||||
(for-each step vals)
|
||||
(hashq-set! bindings parent
|
||||
(append (reverse vars) (hashq-ref bindings parent)))
|
||||
(step exp))
|
||||
|
||||
((<letrec> vars vals exp)
|
||||
(hashq-set! bindings parent
|
||||
(append (reverse vars) (hashq-ref bindings parent)))
|
||||
(for-each step vals)
|
||||
(step exp))
|
||||
|
||||
(else #f)))
|
||||
|
||||
(define (allocate-heap! binder)
|
||||
(hashq-set! heap-indexes binder
|
||||
(1+ (hashq-ref heap-indexes binder -1))))
|
||||
|
||||
(define (allocate! x level n)
|
||||
(define (step y) (allocate! y level n))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(step proc) (for-each step args))
|
||||
|
||||
((<conditional> test then else)
|
||||
(step test) (step then) (step else))
|
||||
|
||||
((<lexical-set> name gensym exp)
|
||||
(step exp))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(step exp))
|
||||
|
||||
((<toplevel-set> name exp)
|
||||
(step exp))
|
||||
|
||||
((<toplevel-define> name exp)
|
||||
(step exp))
|
||||
|
||||
((<sequence> exps)
|
||||
(for-each step exps))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
(let lp ((vars vars) (n 0))
|
||||
(if (null? vars)
|
||||
(allocate! body (1+ level) n)
|
||||
(let ((v (if (pair? vars) (car vars) vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap (1+ level) (allocate-heap! binder))
|
||||
(cons 'stack n))))
|
||||
(lp (if (pair? vars) (cdr vars) '()) (1+ n))))))
|
||||
|
||||
((<let> vars vals exp)
|
||||
(for-each step vals)
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(allocate! exp level n)
|
||||
(let ((v (car vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap level (allocate-heap! binder))
|
||||
(cons 'stack n))))
|
||||
(lp (cdr vars) (1+ n))))))
|
||||
|
||||
((<letrec> vars vals exp)
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(begin
|
||||
(for-each (lambda (x) (allocate! x level n))
|
||||
vals)
|
||||
(allocate! exp level n))
|
||||
(let ((v (car vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap level (allocate-heap! binder))
|
||||
(cons 'stack n))))
|
||||
(lp (cdr vars) (1+ n))))))
|
||||
|
||||
(else #f)))
|
||||
|
||||
(define parents (make-hash-table))
|
||||
(define bindings (make-hash-table))
|
||||
(define heaps (make-hash-table))
|
||||
(define allocation (make-hash-table))
|
||||
(define heap-indexes (make-hash-table))
|
||||
|
||||
(hashq-set! bindings #f '())
|
||||
(analyze! x #f 0)
|
||||
(allocate! x 0 0)
|
||||
|
||||
allocation)
|
||||
;; lambda -> (nlocs . nexts)
|
||||
|
||||
(define (compile-glil x e opts)
|
||||
(let ((x (optimize! x e opts)))
|
||||
(let ((allocation (analyze-lexicals x)))
|
||||
(values (codegen (make-lambda (tree-il-src x) '() '() x)
|
||||
allocation)
|
||||
(and e (cons (car e) (cddr e)))
|
||||
e))))
|
||||
(let* ((x (make-lambda (tree-il-src x) '() '() x))
|
||||
(x (optimize! x e opts))
|
||||
(allocation (analyze-lexicals x)))
|
||||
(values (flatten-lambda x -1 allocation)
|
||||
(and e (cons (car e) (cddr e)))
|
||||
e)))
|
||||
|
||||
|
||||
|
||||
(define *ia-void* (make-glil-void))
|
||||
(define *ia-drop* (make-glil-call 'drop 1))
|
||||
(define *ia-return* (make-glil-call 'return 1))
|
||||
|
||||
(define (make-label) (gensym ":L"))
|
||||
|
||||
(define (make-glil-var op env var)
|
||||
(case (ghil-var-kind var)
|
||||
((argument)
|
||||
(make-glil-argument op (ghil-var-index var)))
|
||||
((local)
|
||||
(make-glil-local op (ghil-var-index var)))
|
||||
((external)
|
||||
(do ((depth 0 (1+ depth))
|
||||
(e env (ghil-env-parent e)))
|
||||
((eq? e (ghil-var-env var))
|
||||
(make-glil-external op depth (ghil-var-index var)))))
|
||||
((toplevel)
|
||||
(make-glil-toplevel op (ghil-var-name var)))
|
||||
((public private)
|
||||
(make-glil-module op (ghil-var-env var) (ghil-var-name var)
|
||||
(eq? (ghil-var-kind var) 'public)))
|
||||
(else (error "Unknown kind of variable:" var))))
|
||||
(define (vars->bind-list vars allocation)
|
||||
(map (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack) (list v 'local (cdr loc)))
|
||||
((heap) (list v 'external (cddr loc)))
|
||||
(else (error "badness" v loc)))))
|
||||
vars))
|
||||
|
||||
(define (emit-bindings src vars allocation emit-code)
|
||||
(if (pair? vars)
|
||||
(emit-code src (make-glil-bind (vars->bind-list vars allocation)))))
|
||||
|
||||
(define (codegen x)
|
||||
(define stack '())
|
||||
(define (push-code! src code)
|
||||
(set! stack (cons code stack))
|
||||
(if src (set! stack (cons (make-glil-source src) stack))))
|
||||
(define (var->binding var)
|
||||
(list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
|
||||
(define (push-bindings! src vars)
|
||||
(if (not (null? vars))
|
||||
(push-code! src (make-glil-bind (map var->binding vars)))))
|
||||
(define (comp tree tail drop)
|
||||
(define (push-label! label)
|
||||
(push-code! #f (make-glil-label label)))
|
||||
(define (push-branch! src inst label)
|
||||
(push-code! src (make-glil-branch inst label)))
|
||||
(define (push-call! src inst args)
|
||||
(for-each comp-push args)
|
||||
(push-code! src (make-glil-call inst (length args))))
|
||||
;; possible tail position
|
||||
(define (comp-tail tree) (comp tree tail drop))
|
||||
;; push the result
|
||||
(define (comp-push tree) (comp tree #f #f))
|
||||
;; drop the result
|
||||
(define (comp-drop tree) (comp tree #f #t))
|
||||
;; drop the result if unnecessary
|
||||
(define (maybe-drop)
|
||||
(if drop (push-code! #f *ia-drop*)))
|
||||
;; return here if necessary
|
||||
(define (maybe-return)
|
||||
(if tail (push-code! #f *ia-return*)))
|
||||
;; return this code if necessary
|
||||
(define (return-code! src code)
|
||||
(if (not drop) (push-code! src code))
|
||||
(maybe-return))
|
||||
;; return void if necessary
|
||||
(define (return-void!)
|
||||
(return-code! #f *ia-void*))
|
||||
;; return object if necessary
|
||||
(define (return-object! src obj)
|
||||
(return-code! src (make-glil-const obj)))
|
||||
;;
|
||||
;; dispatch
|
||||
(record-case tree
|
||||
((<ghil-void>)
|
||||
(return-void!))
|
||||
(define (with-output-to-code proc)
|
||||
(let ((out '()))
|
||||
(define (emit-code src x)
|
||||
(set! out (cons x out))
|
||||
(if src
|
||||
(set! out (cons (make-glil-source src) out))))
|
||||
(proc emit-code)
|
||||
(reverse out)))
|
||||
|
||||
((<ghil-quote> env src obj)
|
||||
(return-object! src obj))
|
||||
(define (flatten-lambda x level allocation)
|
||||
(receive (vars nargs nrest)
|
||||
(let lp ((vars (lambda-vars x)) (out '()) (n 0))
|
||||
(cond ((null? vars) (values (reverse out) n 0))
|
||||
((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n)))
|
||||
(else (values (reverse (cons vars out)) (1+ n) 1))))
|
||||
(let ((nlocs (car (hashq-ref allocation x)))
|
||||
(nexts (cdr (hashq-ref allocation x))))
|
||||
(make-glil-program
|
||||
nargs nrest nlocs nexts (lambda-meta x)
|
||||
(with-output-to-code
|
||||
(lambda (emit-code)
|
||||
;; write bindings and source debugging info
|
||||
(emit-bindings #f vars allocation emit-code)
|
||||
(if (lambda-src x)
|
||||
(emit-code (make-glil-src (lambda-src x))))
|
||||
|
||||
((<ghil-ref> env src var)
|
||||
(return-code! src (make-glil-var 'ref env var)))
|
||||
;; copy args to the heap if necessary
|
||||
(let lp ((in vars) (n 0))
|
||||
(if (not (null? in))
|
||||
(let ((loc (hashq-ref allocation (car vars))))
|
||||
(case (car loc)
|
||||
((heap)
|
||||
(emit-code (make-glil-argument 'ref n))
|
||||
(emit-code (make-glil-external 'set 0 (cddr loc)))))
|
||||
(lp (cdr in) (1+ n)))))
|
||||
|
||||
((<ghil-set> env src var val)
|
||||
(comp-push val)
|
||||
(push-code! src (make-glil-var 'set env var))
|
||||
(return-void!))
|
||||
;; and here, here, dear reader: we compile.
|
||||
(flatten (lambda-body x) (1+ level) allocation emit-code)))))))
|
||||
|
||||
((<toplevel-define> src name exp)
|
||||
(comp-push exp)
|
||||
(push-code! src (make-glil-var 'define env var))
|
||||
(return-void!))
|
||||
(define (flatten x level allocation emit-code)
|
||||
(define (emit-label label)
|
||||
(emit-code #f (make-glil-label label)))
|
||||
(define (emit-branch src inst label)
|
||||
(emit-code src (make-glil-branch inst label)))
|
||||
|
||||
(let comp ((x x) (context 'tail))
|
||||
(define (comp-tail tree) (comp tree context))
|
||||
(define (comp-push tree) (comp tree 'push))
|
||||
(define (comp-drop tree) (comp tree 'drop))
|
||||
|
||||
(record-case x
|
||||
((<void>)
|
||||
(case context
|
||||
((push) (emit-code #f (make-glil-void)))
|
||||
((tail)
|
||||
(emit-code #f (make-glil-void))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<const> src exp)
|
||||
(case context
|
||||
((push) (emit-code src (make-glil-const exp)))
|
||||
((tail)
|
||||
(emit-code src (make-glil-const exp))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
;; FIXME: should represent sequence as exps tail
|
||||
((<sequence> src exps)
|
||||
(let lp ((exps exps))
|
||||
(if (null? (cdr exps))
|
||||
(comp-tail (car exps))
|
||||
(begin
|
||||
(comp-drop (car exps))
|
||||
(lp (cdr exps))))))
|
||||
|
||||
((<application> src proc args)
|
||||
(comp-push proc)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call (case context
|
||||
((tail) 'goto/args)
|
||||
(else 'call))
|
||||
(length args))))
|
||||
|
||||
((<conditional> src test then else)
|
||||
;; TEST
|
||||
|
|
@ -312,228 +148,130 @@
|
|||
;; L2:
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(comp-push test)
|
||||
(push-branch! src 'br-if-not L1)
|
||||
(emit-branch src 'br-if-not L1)
|
||||
(comp-tail then)
|
||||
(if (not tail) (push-branch! #f 'br L2))
|
||||
(push-label! L1)
|
||||
(if (not (eq? context 'tail))
|
||||
(emit-branch #f 'br L2))
|
||||
(emit-label L1)
|
||||
(comp-tail else)
|
||||
(if (not tail) (push-label! L2))))
|
||||
(if (not (eq? context 'tail))
|
||||
(emit-label L2))))
|
||||
|
||||
((<sequence> src exps)
|
||||
;; EXPS...
|
||||
;; TAIL
|
||||
(if (null? exps)
|
||||
(return-void!)
|
||||
(do ((exps exps (cdr exps)))
|
||||
((null? (cdr exps))
|
||||
(comp-tail (car exps)))
|
||||
(comp-drop (car exps)))))
|
||||
((<primitive-ref> src name)
|
||||
(case context
|
||||
((push)
|
||||
(emit-code src (make-glil-module 'ref '(guile) name #f)))
|
||||
((tail)
|
||||
(emit-code src (make-glil-module 'ref '(guile) name #f))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<let> src vars vals body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
((<lexical-ref> src name gensym)
|
||||
(case context
|
||||
((push tail)
|
||||
(let ((loc (hashq-ref allocation gensym)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'ref (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external
|
||||
'ref (- level (cadr loc)) (cddr loc))))
|
||||
(else (error "badness" x loc)))
|
||||
(if (eq? context 'tail)
|
||||
(emit-code #f (make-glil-call 'return 1)))))))
|
||||
|
||||
((<lexical-set> src name gensym exp)
|
||||
(comp-push exp)
|
||||
(let ((loc (hashq-ref allocation gensym)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external
|
||||
'set (- level (cadr loc)) (cddr loc))))
|
||||
(else (error "badness" x loc))))
|
||||
(case context
|
||||
((push)
|
||||
(emit-code #f (make-glil-void)))
|
||||
((tail)
|
||||
(emit-code #f (make-glil-void))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<module-ref> src mod name public?)
|
||||
(emit-code src (make-glil-module 'ref mod name public?))
|
||||
(case context
|
||||
((drop) (emit-code #f (make-glil-call 'drop 1)))
|
||||
((tail) (emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<module-set> src mod name public? exp)
|
||||
(comp-push exp)
|
||||
(emit-code src (make-glil-module 'set mod name public?))
|
||||
(case context
|
||||
((push)
|
||||
(emit-code #f (make-glil-void)))
|
||||
((tail)
|
||||
(emit-code #f (make-glil-void))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<toplevel-ref> src name)
|
||||
(emit-code src (make-glil-toplevel 'ref name))
|
||||
(case context
|
||||
((drop) (emit-code #f (make-glil-call 'drop 1)))
|
||||
((tail) (emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<toplevel-set> src name exp)
|
||||
(comp-push exp)
|
||||
(emit-code src (make-glil-toplevel 'set name))
|
||||
(case context
|
||||
((push)
|
||||
(emit-code #f (make-glil-void)))
|
||||
((tail)
|
||||
(emit-code #f (make-glil-void))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<toplevel-define> src name exp)
|
||||
(comp-push exp)
|
||||
(emit-code src (make-glil-toplevel 'define name))
|
||||
(case context
|
||||
((push)
|
||||
(emit-code #f (make-glil-void)))
|
||||
((tail)
|
||||
(emit-code #f (make-glil-void))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<lambda>)
|
||||
(case context
|
||||
((push)
|
||||
(emit-code #f (flatten-lambda x level allocation)))
|
||||
((tail)
|
||||
(emit-code #f (flatten-lambda x level allocation))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<let> src vars vals exp)
|
||||
(for-each comp-push vals)
|
||||
(push-bindings! src vars)
|
||||
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
(emit-bindings src vars allocation emit-code)
|
||||
(for-each (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external 'set 0 (cddr loc))))
|
||||
(else (error "badness" x loc)))))
|
||||
(reverse vars))
|
||||
(comp-tail exp)
|
||||
(emit-code #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-mv-bind> env src producer vars rest body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
(let ((MV (make-label)))
|
||||
(comp-push producer)
|
||||
(push-code! src (make-glil-mv-call 0 MV))
|
||||
(push-code! #f (make-glil-const 1))
|
||||
(push-label! MV)
|
||||
(push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
|
||||
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
|
||||
(reverse vars)))
|
||||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-lambda> env src vars rest meta body)
|
||||
(return-code! src (codegen tree)))
|
||||
|
||||
((<ghil-inline> env src inline args)
|
||||
;; ARGS...
|
||||
;; (INST NARGS)
|
||||
(let ((tail-table '((call . goto/args)
|
||||
(apply . goto/apply)
|
||||
(call/cc . goto/cc))))
|
||||
(cond ((and tail (assq-ref tail-table inline))
|
||||
=> (lambda (tail-inst)
|
||||
(push-call! src tail-inst args)))
|
||||
(else
|
||||
(push-call! src inline args)
|
||||
(maybe-drop)
|
||||
(maybe-return)))))
|
||||
|
||||
((<ghil-values> env src values)
|
||||
(cond (tail ;; (lambda () (values 1 2))
|
||||
(push-call! src 'return/values values))
|
||||
(drop ;; (lambda () (values 1 2) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (values 10 12) 1))
|
||||
(push-code! #f (make-glil-const 'values))
|
||||
(push-code! #f (make-glil-call 'link-now 1))
|
||||
(push-code! #f (make-glil-call 'variable-ref 0))
|
||||
(push-call! src 'call values))))
|
||||
|
||||
((<ghil-values*> env src values)
|
||||
(cond (tail ;; (lambda () (apply values '(1 2)))
|
||||
(push-call! src 'return/values* values))
|
||||
(drop ;; (lambda () (apply values '(1 2)) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (apply values '(10 12)) 1))
|
||||
(push-code! #f (make-glil-const 'values))
|
||||
(push-code! #f (make-glil-call 'link-now 1))
|
||||
(push-code! #f (make-glil-call 'variable-ref 0))
|
||||
(push-call! src 'apply values))))
|
||||
|
||||
((<ghil-call> env src proc args)
|
||||
;; PROC
|
||||
;; ARGS...
|
||||
;; ([tail-]call NARGS)
|
||||
(comp-push proc)
|
||||
(let ((nargs (length args)))
|
||||
(cond ((< nargs 255)
|
||||
(push-call! src (if tail 'goto/args 'call) args))
|
||||
(else
|
||||
(push-call! src 'mark '())
|
||||
(for-each comp-push args)
|
||||
(push-call! src 'list-mark '())
|
||||
(push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2)))))
|
||||
(maybe-drop))
|
||||
|
||||
((<ghil-mv-call> env src producer consumer)
|
||||
;; CONSUMER
|
||||
;; PRODUCER
|
||||
;; (mv-call MV)
|
||||
;; ([tail]-call 1)
|
||||
;; goto POST
|
||||
;; MV: [tail-]call/nargs
|
||||
;; POST: (maybe-drop)
|
||||
(let ((MV (make-label)) (POST (make-label)))
|
||||
(comp-push consumer)
|
||||
(comp-push producer)
|
||||
(push-code! src (make-glil-mv-call 0 MV))
|
||||
(push-code! src (make-glil-call (if tail 'goto/args 'call) 1))
|
||||
(cond ((not tail)
|
||||
(push-branch! #f 'br POST)))
|
||||
(push-label! MV)
|
||||
(push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
|
||||
(cond ((not tail)
|
||||
(push-label! POST)
|
||||
(maybe-drop)))))
|
||||
|
||||
((<ghil-reified-env> env src)
|
||||
(return-object! src (ghil-env-reify env)))))
|
||||
|
||||
;;
|
||||
;; main
|
||||
;;
|
||||
|
||||
;; analyze vars: partition into args, locs, exts, and assign indices
|
||||
(record-case x
|
||||
((<ghil-lambda> env src vars rest meta body)
|
||||
(let* ((evars (ghil-env-variables env))
|
||||
(srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
|
||||
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
|
||||
(nargs (allocate-indices-linearly! vars))
|
||||
(nlocs (allocate-locals! locs body))
|
||||
(nexts (allocate-indices-linearly! exts)))
|
||||
;; meta bindings
|
||||
(push-bindings! #f vars)
|
||||
;; push on definition source location
|
||||
(if src (set! stack (cons (make-glil-source src) stack)))
|
||||
;; copy args to the heap if they're marked as external
|
||||
(do ((n 0 (1+ n))
|
||||
(l vars (cdr l)))
|
||||
((null? l))
|
||||
(let ((v (car l)))
|
||||
(case (ghil-var-kind v)
|
||||
((external)
|
||||
(push-code! #f (make-glil-argument 'ref n))
|
||||
(push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
|
||||
;; compile body
|
||||
(comp body #t #f)
|
||||
;; create GLIL
|
||||
(make-glil-program nargs (if rest 1 0) nlocs nexts meta
|
||||
(reverse! stack))))))
|
||||
|
||||
(define (allocate-indices-linearly! vars)
|
||||
(do ((n 0 (1+ n))
|
||||
(l vars (cdr l)))
|
||||
((null? l) n)
|
||||
(let ((v (car l))) (set! (ghil-var-index v) n))))
|
||||
|
||||
(define (allocate-locals! vars body)
|
||||
(let ((free '()) (nlocs 0))
|
||||
(define (allocate! var)
|
||||
(cond
|
||||
((pair? free)
|
||||
(set! (ghil-var-index var) (car free))
|
||||
(set! free (cdr free)))
|
||||
(else
|
||||
(set! (ghil-var-index var) nlocs)
|
||||
(set! nlocs (1+ nlocs)))))
|
||||
(define (deallocate! var)
|
||||
(set! free (cons (ghil-var-index var) free)))
|
||||
(let lp ((x body))
|
||||
(record-case x
|
||||
((<ghil-void>))
|
||||
((<ghil-quote>))
|
||||
((<ghil-quasiquote> exp)
|
||||
(let qlp ((x exp))
|
||||
(cond ((list? x) (for-each qlp x))
|
||||
((pair? x) (qlp (car x)) (qlp (cdr x)))
|
||||
((record? x)
|
||||
(record-case x
|
||||
((<ghil-unquote> exp) (lp exp))
|
||||
((<ghil-unquote-splicing> exp) (lp exp)))))))
|
||||
((<ghil-unquote> exp)
|
||||
(lp exp))
|
||||
((<ghil-unquote-splicing> exp)
|
||||
(lp exp))
|
||||
((<ghil-reified-env>))
|
||||
((<ghil-set> val)
|
||||
(lp val))
|
||||
((<ghil-ref>))
|
||||
((<ghil-define> val)
|
||||
(lp val))
|
||||
((<ghil-if> test then else)
|
||||
(lp test) (lp then) (lp else))
|
||||
((<ghil-and> exps)
|
||||
(for-each lp exps))
|
||||
((<ghil-or> exps)
|
||||
(for-each lp exps))
|
||||
((<ghil-begin> exps)
|
||||
(for-each lp exps))
|
||||
((<ghil-bind> vars vals body)
|
||||
(for-each allocate! vars)
|
||||
(for-each lp vals)
|
||||
(lp body)
|
||||
(for-each deallocate! vars))
|
||||
((<ghil-mv-bind> vars producer body)
|
||||
(lp producer)
|
||||
(for-each allocate! vars)
|
||||
(lp body)
|
||||
(for-each deallocate! vars))
|
||||
((<ghil-inline> args)
|
||||
(for-each lp args))
|
||||
((<ghil-call> proc args)
|
||||
(lp proc)
|
||||
(for-each lp args))
|
||||
((<ghil-lambda>))
|
||||
((<ghil-mv-call> producer consumer)
|
||||
(lp producer)
|
||||
(lp consumer))
|
||||
((<ghil-values> values)
|
||||
(for-each lp values))
|
||||
((<ghil-values*> values)
|
||||
(for-each lp values))))
|
||||
nlocs))
|
||||
((<letrec> src vars vals exp)
|
||||
(for-each comp-push vals)
|
||||
(emit-bindings src vars allocation emit-code)
|
||||
(for-each (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external 'set 0 (cddr loc))))
|
||||
(else (error "badness" x loc)))))
|
||||
(reverse vars))
|
||||
(comp-tail exp)
|
||||
(emit-code #f (make-glil-unbind))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue