summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-21 19:25:35 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-21 20:28:29 +0100
commit594d9d4c482d91ccfbc474ec193baadde6ab11f7 (patch)
tree8bb3150b9029055b2dc01cdf39391fe741bc8e1d /module
parent81d677eb121834945bf0f9ebec28480e6e945cd0 (diff)
downloadguile-594d9d4c482d91ccfbc474ec193baadde6ab11f7.tar.gz
be smarter about allocating local variables, reusing slots if possible
* module/language/Makefile.am: OK, we can compile compile-ghil.scm now, thankfully. * module/language/ecmascript/compile-ghil.scm (ormatch): New macro, a wrapper around pmatch to avoid some of the more egregious non-tail recursiveness. (comp): Use ormatch. * module/language/ghil.scm (unparse-ghil): The body of bind and mv-bind is a single expression, not a list of expressions. * module/language/ghil/compile-glil.scm (codegen): Be more clever when allocating "local" variables -- if a variable goes out of scope, its index can be re-used later. * module/language/glil.scm (parse-glil, unparse-ghil): The "rest" of a mv-bind is a flag, not a list. The "ra" of an mv-call is a label, not a GLIL expression. * module/language/objcode/spec.scm (collapse-locals, decompile-value): When decompiling a value, process the bindings list differently. Comments in the code. * module/language/scheme/compile-ghil.scm (define-scheme-translator): Fix the generated error procedure. (let): Re-indent. (letrec): Re-indent. * module/system/base/syntax.scm (record-case): If the body of a clause is null, fill it with the unspecified value.
Diffstat (limited to 'module')
-rw-r--r--module/language/Makefile.am10
-rw-r--r--module/language/assembly/disassemble.scm11
-rw-r--r--module/language/ecmascript/compile-ghil.scm13
-rw-r--r--module/language/ghil.scm4
-rw-r--r--module/language/ghil/compile-glil.scm89
-rw-r--r--module/language/glil.scm6
-rw-r--r--module/language/objcode/spec.scm26
-rw-r--r--module/language/scheme/compile-ghil.scm18
-rw-r--r--module/system/base/syntax.scm2
9 files changed, 138 insertions, 41 deletions
diff --git a/module/language/Makefile.am b/module/language/Makefile.am
index c2db20a86..797f8a2bb 100644
--- a/module/language/Makefile.am
+++ b/module/language/Makefile.am
@@ -6,11 +6,11 @@ SOURCES=ghil.scm glil.scm assembly.scm \
ecmascript/impl.scm \
ecmascript/base.scm \
ecmascript/function.scm \
- ecmascript/array.scm
-# unfortunately, the ones that we want to compile can't yet be compiled
-# -- too many local vars in the first case, and some non-tail-recursion
-# in pmatch in the second.
-NOCOMP_SOURCES = ecmascript/parse.scm \
+ ecmascript/array.scm \
ecmascript/compile-ghil.scm
+# unfortunately, the one that we want to compile can't yet be compiled
+# -- too many external vars, or something. seems like we need to do
+# closure elimination or something.
+NOCOMP_SOURCES = ecmascript/parse.scm
modpath = language
include $(top_srcdir)/am/guilec
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index d83fd3e09..efb0f8be7 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -135,9 +135,14 @@
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-set)
(and blocs
- (let ((b (list-ref blocs (car args))))
- (list "`~a'~@[ (arg)~]"
- (binding:name b) (< (binding:index b) nargs)))))
+ (let lp ((bindings (list-ref blocs (car args))))
+ (and (pair? bindings)
+ (let ((b (car bindings)))
+ (if (and (< (binding:start (car bindings)) end-addr)
+ (>= (binding:end (car bindings)) end-addr))
+ (list "`~a'~@[ (arg)~]"
+ (binding:name b) (< (binding:index b) nargs))
+ (lp (cdr bindings))))))))
((external-ref external-set)
(and bexts
(if (< (car args) (length bexts))
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
index 3826f79e3..e6c590096 100644
--- a/module/language/ecmascript/compile-ghil.scm
+++ b/module/language/ecmascript/compile-ghil.scm
@@ -25,8 +25,6 @@
#:use-module (system base pmatch)
#:export (compile-ghil))
-(eval-case ((load-toplevel) (debug-set! stack 0)))
-
(define (compile-ghil exp env opts)
(values
(call-with-ghil-environment (make-ghil-toplevel-env) '()
@@ -48,6 +46,15 @@
(@implv ,e ,l ,sym)
,args))
+(define-macro (ormatch x . clauses)
+ (let ((X (gensym)))
+ `(let ((,X ,x))
+ (or ,@(map (lambda (c)
+ (if (eq? (car c) 'else)
+ `(begin . ,(cdr c))
+ `(pmatch ,X ,c (else #f))))
+ clauses)))))
+
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
@@ -62,7 +69,7 @@
(make-ghil-begin
e l (list (proc (car vars))
(make-ghil-ref e l (car vars))))))))
- (pmatch x
+ (ormatch x
(null
;; FIXME, null doesn't have much relation to EOL...
(make-ghil-quote e l '()))
diff --git a/module/language/ghil.scm b/module/language/ghil.scm
index 505e0075c..714f508bf 100644
--- a/module/language/ghil.scm
+++ b/module/language/ghil.scm
@@ -452,10 +452,10 @@
`(begin ,@(map unparse-ghil exps)))
((<ghil-bind> env loc vars vals body)
`(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
- ,@(map unparse-ghil body)))
+ ,(unparse-ghil body)))
((<ghil-mv-bind> env loc producer vars rest body)
`(mv-bind ,(map ghil-var-name vars) ,rest
- ,(unparse-ghil producer) ,@(map unparse-ghil body)))
+ ,(unparse-ghil producer) ,(unparse-ghil body)))
((<ghil-lambda> env loc vars rest meta body)
`(lambda ,(map ghil-var-name vars) ,rest ,meta
,(unparse-ghil body)))
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index 3e589bad4..8cb3d2593 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -415,14 +415,13 @@
((<ghil-lambda> env loc vars rest meta body)
(let* ((evars (ghil-env-variables env))
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
- (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
- ;; initialize variable indexes
- (finalize-index! vars)
- (finalize-index! locs)
- (finalize-index! exts)
+ (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)
- ;; export arguments
+ ;; copy args to the heap if they're marked as external
(do ((n 0 (1+ n))
(l vars (cdr l)))
((null? l))
@@ -436,12 +435,78 @@
;; compile body
(comp body #t #f)
;; create GLIL
- (make-glil-program
- (length vars) (if rest 1 0) (length locs) (length exts)
- meta (reverse! stack)))))))
+ (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+ (reverse! stack)))))))
-(define (finalize-index! list)
+(define (allocate-indices-linearly! vars)
(do ((n 0 (1+ n))
- (l list (cdr l)))
- ((null? l))
+ (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))
diff --git a/module/language/glil.scm b/module/language/glil.scm
index b222779a1..01b680194 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -120,7 +120,7 @@
((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
(make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
- ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
+ ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((source ,props) (make-glil-source props))
((void) (make-glil-void))
@@ -143,7 +143,7 @@
((<glil-program> nargs nrest nlocs nexts meta body)
`(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
- ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
+ ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
((<glil-source> props) `(source ,props))
;; constants
@@ -164,4 +164,4 @@
((<glil-label> label) `(label ,label))
((<glil-branch> inst label) `(branch ,inst ,label))
((<glil-call> inst nargs) `(call ,inst ,nargs))
- ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))
+ ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index d4212be48..9ce8bf5e5 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -43,6 +43,25 @@
(values (thunk) #f)))
(values (thunk) #f))))
+;; since locals are allocated on the stack and can have limited scope,
+;; in many cases we use one local for more than one lexical variable. so
+;; the returned locals set is a list, where element N of the list is
+;; itself a list of bindings for local variable N.
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
(define (decompile-value x env opts)
(cond
((program? x)
@@ -53,9 +72,10 @@
(srcs (program-sources x))
(nargs (arity:nargs (program-arity x))))
(let ((blocs (and binds
- (append (list-head binds nargs)
- (filter (lambda (x) (not (binding:extp x)))
- (list-tail binds nargs)))))
+ (collapse-locals
+ (append (list-head binds nargs)
+ (filter (lambda (x) (not (binding:extp x)))
+ (list-tail binds nargs))))))
(bexts (and binds
(filter binding:extp binds))))
(values (program-objcode x)
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 2821c1e70..475d50423 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -175,7 +175,7 @@
(pmatch (cdr exp)
,@clauses
,@(if (assq 'else clauses) '()
- '((else
+ `((else
(syntax-error l (format #f "bad ~A" ',sym) exp))))))))
(define-scheme-translator quote
@@ -261,8 +261,8 @@
(maybe-name-value! (retrans (cadr b)) (car b)))
bindings)))
(call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (make-ghil-bind e l vars vals (trans-body e l body)))))))
+ (lambda (vars)
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
(define-scheme-translator let*
;; (let* ((SYM VAL) ...) BODY...)
@@ -275,12 +275,12 @@
;; (letrec ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings))
(call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (let ((vals (map (lambda (b)
- (maybe-name-value!
- (retrans (cadr b)) (car b)))
- bindings)))
- (make-ghil-bind e l vars vals (trans-body e l body)))))))
+ (lambda (vars)
+ (let ((vals (map (lambda (b)
+ (maybe-name-value!
+ (retrans (cadr b)) (car b)))
+ bindings)))
+ (make-ghil-bind e l vars vals (trans-body e l body)))))))
(define-scheme-translator cond
;; (cond (CLAUSE BODY...) ...)
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 0fe8a4ddf..bc8db0388 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -180,7 +180,7 @@
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
`(,slot (,(symbol-append stem '- slot) ,r))))
slots)
- ,@body))))))
+ ,@(if (pair? body) body '((if #f #f)))))))))
`(let* ((,r ,record)
(,rtd (struct-vtable ,r)))
(cond ,@(let ((clauses (map process-clause clauses)))