mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

add lexical analyzer and allocator

Browse source 
* module/language/tree-il/optimize.scm: Rework to just export the
  optimize! procedure.

* module/language/tree-il/compile-glil.scm (analyze-lexicals): New
  function, analyzes and allocates lexical variables. Almost ready to
  compile now.
  (codegen): Dedent.
This commit is contained in:
Andy Wingo 2009-05-14 00:11:25 +02:00
parent cb28c08537
commit 073bb617eb
2 changed files with 415 additions and 221 deletions
Download patch file Download diff file Expand all files Collapse all files

199
module/language/tree-il/compile-glil.scm
View file

@ -23,13 +23,196 @@
#:use-module (system base syntax)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
#:use-module (ice-9 common-list)
#: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)
(define (compile-glil x e opts)
(values (codegen x)
(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))
e))))
@ -57,8 +240,9 @@
(eq? (ghil-var-kind var) 'public)))
(else (error "Unknown kind of variable:" var))))
(define (codegen ghil)
(let ((stack '()))
(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))))
@ -251,7 +435,10 @@
;;
;; main
(record-case ghil
;;
;; 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))
@ -276,7 +463,7 @@
(comp body #t #f)
;; create GLIL
(make-glil-program nargs (if rest 1 0) nlocs nexts meta
(reverse! stack)))))))
(reverse! stack))))))
(define (allocate-indices-linearly! vars)
(do ((n 0 (1+ n))

9
module/language/tree-il/optimize.scm
View file

@ -22,7 +22,14 @@
(define-module (language tree-il optimize)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (resolve-primitives!))
#:use-module (language tree-il inline)
#:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts)
(expand-primitives! (resolve-primitives! x (env-module env))))
;; Possible optimizations:
;; * constant folding, propagation