[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. cf10678fe7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. cf10678fe7014a67020c45ee02f2aabb44598adc |
|
Date: |
Fri, 15 May 2009 21:44:02 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cf10678fe7014a67020c45ee02f2aabb44598adc
The branch, syncase-in-boot-9 has been updated
via cf10678fe7014a67020c45ee02f2aabb44598adc (commit)
from 073bb617eb7e5f76269ca6dba0fe498baff6f058 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cf10678fe7014a67020c45ee02f2aabb44598adc
Author: Andy Wingo <address@hidden>
Date: Fri May 15 23:44:14 2009 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 7 +-
module/language/ghil/compile-glil.scm | 14 +-
module/language/glil.scm | 7 -
module/language/glil/compile-assembly.scm | 24 +-
module/language/glil/decompile-assembly.scm | 8 +-
module/language/tree-il.scm | 14 +
module/language/tree-il/analyze.scm | 201 ++++++++
module/language/tree-il/compile-glil.scm | 714 +++++++++------------------
8 files changed, 464 insertions(+), 525 deletions(-)
create mode 100644 module/language/tree-il/analyze.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 36d6700..22a9562 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -72,10 +72,11 @@ SCHEME_LANG_SOURCES =
\
language/scheme/inline.scm
TREE_IL_LANG_SOURCES = \
- language/tree-il/spec.scm \
- language/tree-il/compile-glil.scm \
language/tree-il/inline.scm \
- language/tree-il/optimize.scm
+ language/tree-il/optimize.scm \
+ language/tree-il/analyze.scm \
+ language/tree-il/compile-glil.scm \
+ language/tree-il/spec.scm
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
diff --git a/module/language/ghil/compile-glil.scm
b/module/language/ghil/compile-glil.scm
index c813319..02187be 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -187,7 +187,7 @@
(define (make-glil-var op env var)
(case (ghil-var-kind var)
((argument)
- (make-glil-argument op (ghil-var-index var)))
+ (make-glil-local op (ghil-var-index var)))
((local)
(make-glil-local op (ghil-var-index var)))
((external)
@@ -217,7 +217,9 @@
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
(define (var->binding var)
- (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
+ (case kind ((argument) 'local) (else kind)))
+ (ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
(push-code! loc (make-glil-bind (map var->binding vars)))))
@@ -496,7 +498,7 @@
(locs (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))
+ (nlocs (allocate-locals! locs body nargs))
(nexts (allocate-indices-linearly! exts)))
;; meta bindings
(push-bindings! #f vars)
@@ -509,7 +511,7 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
- (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-local 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index
v)))))))
;; compile body
(comp body #t #f)
@@ -523,8 +525,8 @@
((null? l) n)
(let ((v (car l))) (set! (ghil-var-index v) n))))
-(define (allocate-locals! vars body)
- (let ((free '()) (nlocs 0))
+(define (allocate-locals! vars body nargs)
+ (let ((free '()) (nlocs nargs))
(define (allocate! var)
(cond
((pair? free)
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 51e7efa..625760e 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
- <glil-argument> make-glil-argument glil-argument?
- glil-argument-op glil-argument-index
-
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
@@ -125,7 +121,6 @@
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
@@ -150,8 +145,6 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-argument> op index)
- `(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index ffac9db..73b2cd1 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -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)
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index a98c399..a47bd80 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -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)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 774ca2c..c9857ac 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -24,6 +24,7 @@
<lexical> make-lexical
lexical-name lexical-gensym
+ <void> void? make-void void-src
<application> application? make-application application-src
application-proc application-args
<conditional> conditional? make-conditional conditional-src
conditional-test conditional-then conditional-else
<primitive-ref> primitive-ref? make-primitive-ref
primitive-ref-src primitive-ref-name
@@ -48,6 +49,7 @@
pre-order!))
(define-type (<tree-il> #:common-slots (src))
+ (<void>)
(<application> proc args)
(<conditional> test then else)
(<primitive-ref> name)
@@ -85,6 +87,9 @@
(let ((loc (location exp))
(retrans (lambda (x) (parse-ghil env x))))
(pmatch exp
+ ((void)
+ (make-void loc))
+
((apply ,proc ,args)
(make-application loc (retrans proc) (retrans args)))
@@ -147,6 +152,9 @@
(define (unparse-tree-il tree-il)
(record-case tree-il
+ ((<void>)
+ '(void))
+
((<application> proc args)
`(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
@@ -200,6 +208,9 @@
(tree-il->scheme (cdr e))))
((record? e)
(record-case e
+ ((<void>)
+ '(if #f #f))
+
((<application> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
@@ -253,6 +264,9 @@
(define (post-order! f x)
(let lp ((x x))
(record-case x
+ ((<void>)
+ (or (f x) x))
+
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
new file mode 100644
index 0000000..fdcd190
--- /dev/null
+++ b/module/language/tree-il/analyze.scm
@@ -0,0 +1,201 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals))
+
+;; 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)
+;; lambda -> (nlocs . nexts)
+
+(define (analyze-lexicals x)
+ ;; 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
+
+ (define (find-heap sym parent)
+ ;; fixme: check displaced lexicals here?
+ (if (memq sym (hashq-ref bindings parent))
+ parent
+ (find-heap 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))))
+
+ ((<lexical-set> name gensym exp)
+ (step exp)
+ (if (not (hashq-ref heaps gensym))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<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 (recur y) (allocate! y level n))
+ (record-case x
+ ((<application> proc args)
+ (apply max (recur proc) (map recur args)))
+
+ ((<conditional> test then else)
+ (max (recur test) (recur then) (recur else)))
+
+ ((<lexical-set> name gensym exp)
+ (recur exp))
+
+ ((<module-set> mod name public? exp)
+ (recur exp))
+
+ ((<toplevel-set> name exp)
+ (recur exp))
+
+ ((<toplevel-define> name exp)
+ (recur exp))
+
+ ((<sequence> exps)
+ (apply max (map recur exps)))
+
+ ((<lambda> vars meta body)
+ (let lp ((vars vars) (n 0))
+ (if (null? vars)
+ (hashq-set! allocation x
+ (let ((nlocs (allocate! body (1+ level) n)))
+ (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
+ (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)))))
+ n)
+
+ ((<let> vars vals exp)
+ (let ((nmax (apply max (map recur vals))))
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (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)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x level n))
+ vals))))
+ (max nmax (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 n)))
+
+ (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))
+
+ (analyze! x #f -1)
+ (allocate! x -1 0)
+
+ allocation)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index f54da31..2b24100 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -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 (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!))
-
- ((<ghil-quote> env src obj)
- (return-object! src obj))
+(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 (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)))
+
+(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))))
+
+ ;; 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)))))
+
+ ;; and here, here, dear reader: we compile.
+ (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+
+(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))
- ((<ghil-ref> env src var)
- (return-code! src (make-glil-var 'ref env var)))
-
- ((<ghil-set> env src var val)
- (comp-push val)
- (push-code! src (make-glil-var 'set env var))
- (return-void!))
-
- ((<toplevel-define> src name exp)
- (comp-push exp)
- (push-code! src (make-glil-var 'define env var))
- (return-void!))
+ (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))))
-
- ((<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)))))
-
- ((<let> src vars vals body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
+ (if (not (eq? context 'tail))
+ (emit-label L2))))
+
+ ((<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)))))
+
+ ((<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)))
-
- ((<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))
+ (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)))
+
+ ((<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))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. cf10678fe7014a67020c45ee02f2aabb44598adc,
Andy Wingo <=