mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

tree-il -> glil compiler works now, at least in initial tests

Browse source 
* 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 2009-05-15 23:44:14 +02:00
parent 073bb617eb
commit cf10678fe7
8 changed files with 456 additions and 517 deletions
Download patch file Download diff file Expand all files Collapse all files

24
module/language/glil/compile-assembly.scm
View file

@ -83,16 +83,15 @@
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
(define (open-binding bindings vars nargs start)
(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
((,name argument ,i) (make-open-binding name #f i))
((,name local ,i) (make-open-binding name #f (+ nargs i)))
((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
(else (error "unknown binding type" name type))))
(else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@ -129,13 +128,13 @@
(define (compile-assembly glil)
(receive (code . _)
(glil->assembly glil 0 '() '(()) '() '() #f -1)
(glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
(define (glil->assembly glil nargs nexts-stack bindings
(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
@ -159,7 +158,7 @@
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
(glil->assembly (car body) nargs nexts-stack bindings
(glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
@ -196,14 +195,14 @@
((<glil-bind> vars)
(values '()
(open-binding bindings vars nargs addr)
(open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars nargs addr)
(open-binding bindings vars addr)
source-alist
label-alist
object-alist))
@ -238,16 +237,11 @@
(emit-code/object `((object-ref ,i))
object-alist)))))
((<glil-argument> op index)
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,(+ nargs index)))
`((local-set ,(+ nargs index))))))
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)

8
module/language/glil/decompile-assembly.scm
View file

@ -175,15 +175,11 @@
(1+ pos)))
((local-ref ,n)
(lp (cdr in) (cons *placeholder* stack)
(cons (if (< n nargs)
(make-glil-argument 'ref n)
(make-glil-local 'ref (- n nargs)))
(cons (make-glil-local 'ref n)
out) (+ pos 2)))
((local-set ,n)
(lp (cdr in) (cdr stack)
(cons (if (< n nargs)
(make-glil-argument 'set n)
(make-glil-local 'set (- n nargs)))
(cons (make-glil-local 'set n)
(emit-constants (list-head stack 1) out))
(+ pos 2)))
((br-if-not ,l)