diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-21 19:25:35 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-21 20:28:29 +0100 |
commit | 594d9d4c482d91ccfbc474ec193baadde6ab11f7 (patch) | |
tree | 8bb3150b9029055b2dc01cdf39391fe741bc8e1d /module | |
parent | 81d677eb121834945bf0f9ebec28480e6e945cd0 (diff) | |
download | guile-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.am | 10 | ||||
-rw-r--r-- | module/language/assembly/disassemble.scm | 11 | ||||
-rw-r--r-- | module/language/ecmascript/compile-ghil.scm | 13 | ||||
-rw-r--r-- | module/language/ghil.scm | 4 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 89 | ||||
-rw-r--r-- | module/language/glil.scm | 6 | ||||
-rw-r--r-- | module/language/objcode/spec.scm | 26 | ||||
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 18 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 2 |
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))) |