[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. 9efc833d65
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 9efc833d65adef11e76410fee7ea548143131417 |
Date: |
Mon, 11 May 2009 21:24:55 +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=9efc833d65adef11e76410fee7ea548143131417
The branch, syncase-in-boot-9 has been updated
via 9efc833d65adef11e76410fee7ea548143131417 (commit)
via b81d329e449420b6abaa2b689d7107b862111cbf (commit)
from 06656e06d454f16694d0b550fb339efb0c36123a (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 9efc833d65adef11e76410fee7ea548143131417
Author: Andy Wingo <address@hidden>
Date: Mon May 11 23:23:34 2009 +0200
add tree-il optimizer
* module/language/tree-il/optimize.scm: New module, for optimizations.
Currently all we have is resolving some toplevel refs to primitive
refs.
* module/Makefile.am: Add new module.
* module/language/tree-il.scm: Fix exports for accessors for `src'.
* module/language/tree-il/compile-glil.scm: Tweaks, things still aren't
working yet.
commit b81d329e449420b6abaa2b689d7107b862111cbf
Author: Andy Wingo <address@hidden>
Date: Fri May 8 12:56:18 2009 +0200
more work on tree-il compilation
* module/language/scheme/amatch.scm: Remove, this approach won't be used.
* module/Makefile.am: Adjust for additions and removals.
* module/language/scheme/compile-ghil.scm: Remove an vestigial debugging
statement.
* module/language/scheme/spec.scm:
* module/language/scheme/compile-tree-il.scm:
* module/language/scheme/decompile-tree-il.scm: Add tree-il compiler and
decompiler.
* module/language/tree-il/compile-glil.scm: Add some notes.
* module/language/tree-il/spec.scm: No need to wrap expressions in
lambdas -- GHIL needs somewhere to put its variables, we don't.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 12 +-
module/language/scheme/amatch.scm | 35 --
module/language/scheme/compile-ghil.scm | 2 -
module/language/scheme/compile-tree-il.scm | 64 ++++
.../{r5rs/null.il => scheme/decompile-tree-il.scm} | 11 +-
module/language/scheme/spec.scm | 6 +-
module/language/tree-il.scm | 42 ++--
module/language/tree-il/compile-glil.scm | 347 +++-----------------
module/language/tree-il/optimize.scm | 143 ++++++++
module/language/tree-il/spec.scm | 13 +-
10 files changed, 306 insertions(+), 369 deletions(-)
delete mode 100644 module/language/scheme/amatch.scm
create mode 100644 module/language/scheme/compile-tree-il.scm
copy module/language/{r5rs/null.il => scheme/decompile-tree-il.scm} (72%)
create mode 100644 module/language/tree-il/optimize.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 761b186..3f607f2 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -65,12 +65,16 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/amatch.scm \
- language/scheme/compile-ghil.scm language/scheme/spec.scm \
+ language/scheme/compile-ghil.scm \
+ language/scheme/spec.scm \
+ language/scheme/compile-tree-il.scm \
+ language/scheme/decompile-tree-il.scm \
language/scheme/inline.scm
-TREE_IL_LANG_SOURCES = \
- language/tree-il/spec.scm language/tree-il/compile-glil.scm
+TREE_IL_LANG_SOURCES = \
+ language/tree-il/spec.scm \
+ language/tree-il/compile-glil.scm \
+ language/tree-il/optimize.scm
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
diff --git a/module/language/scheme/amatch.scm
b/module/language/scheme/amatch.scm
deleted file mode 100644
index 190b37f..0000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-(define-module (language scheme amatch)
- #:export (amatch))
-
-;; This is exactly the same as pmatch except that it unpacks annotations
-;; as needed.
-
-(define-syntax amatch
- (syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (amatch v cs ...)))
- ((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
- ((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat
- (if (and g ...) (begin e0 e ...) (fk))
- (fk))))
- ((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat (begin e0 e ...) (fk))))))
-
-(define-syntax apat
- (syntax-rules (_ quote unquote)
- ((_ v _ kt kf) kt)
- ((_ v () kt kf) (if (null? v) kt kf))
- ((_ v (quote lit) kt kf)
- (if (equal? v (quote lit)) kt kf))
- ((_ v (unquote var) kt kf) (let ((var v)) kt))
- ((_ v (x . y) kt kf)
- (if (apair? v)
- (let ((vx (acar v)) (vy (acdr v)))
- (apat vx x (apat vy y kt kf) kf))
- kf))
- ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
diff --git a/module/language/scheme/compile-ghil.scm
b/module/language/scheme/compile-ghil.scm
index 3d5b015..370488c 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -32,8 +32,6 @@
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-(module-ref (current-module) 'receive)
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
diff --git a/module/language/scheme/compile-tree-il.scm
b/module/language/scheme/compile-tree-il.scm
new file mode 100644
index 0000000..553a3fd
--- /dev/null
+++ b/module/language/scheme/compile-tree-il.scm
@@ -0,0 +1,64 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 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 scheme compile-tree-il)
+ #:use-module (language tree-il)
+ #:export (compile-tree-il))
+
+;;; environment := #f
+;;; | MODULE
+;;; | COMPILE-ENV
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+ (cond ((not env) #f)
+ ((module? env) env)
+ ((and (pair? env) (module? (car env))) (car env))
+ (else (error "bad environment" env))))
+
+(define (cenv-lexicals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cadr env))
+ (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cddr env))
+ (else (error "bad environment" env))))
+
+(define (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+(define (compile-tree-il x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (let ((x (sc-expand x 'c '(compile load eval)))
+ (cenv (make-cenv (current-module)
+ (cenv-lexicals e) (cenv-externals e))))
+ (values x cenv cenv)))))
diff --git a/module/language/r5rs/null.il
b/module/language/scheme/decompile-tree-il.scm
similarity index 72%
copy from module/language/r5rs/null.il
copy to module/language/scheme/decompile-tree-il.scm
index efdc5f3..c4903d8 100644
--- a/module/language/r5rs/null.il
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
-;;; R5RS null environment
+;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001,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
@@ -18,3 +18,10 @@
;; Boston, MA 02111-1307, USA.
;;; Code:
+
+(define-module (language scheme decompile-tree-il)
+ #:use-module (language tree-il)
+ #:export (decompile-tree-il))
+
+(define (decompile-tree-il x env opts)
+ (values (tree-il->scheme x) env))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb..70085e8 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -22,6 +22,8 @@
(define-module (language scheme spec)
#:use-module (system base language)
#:use-module (language scheme compile-ghil)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
#:export (scheme))
;;;
@@ -45,7 +47,9 @@
#:version "0.5"
#:reader read
#:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((ghil . ,compile-ghil)
+ (tree-il . ,compile-tree-il))
+ #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index fa655d8..3de73b9 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -19,30 +19,30 @@
(define-module (language tree-il)
#:use-module (system base pmatch)
#:use-module (system base syntax)
- :export (tree-il-loc
-
- <lexical> make-lexical
- lexical-name lexical-gensym
-
- <application> make-application application-loc application-proc
application-args
- <conditional> make-conditional conditional-loc conditional-test
conditional-then conditional-else
- <primitive-ref> make-primitive-ref primitive-ref-loc
primitive-ref-name
- <lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name
lexical-ref-gensym
- <lexical-set> make-lexical-set lexical-set-loc lexical-set-name
lexical-set-gensym lexical-set-exp
- <module-ref> make-module-ref module-ref-loc module-ref-mod
module-ref-name module-ref-public?
- <module-set> make-module-set module-set-loc module-set-mod
module-set-name module-set-public? module-set-exp
- <toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name
- <toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name
toplevel-set-exp
- <toplevel-define> make-toplevel-define toplevel-define-loc
toplevel-define-name toplevel-define-exp
- <lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body
- <const> make-const const-loc const-exp
- <sequence> make-sequence sequence-loc sequence-exps
- <let> make-let let-loc let-vars let-vals let-exp
- <letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp
-
- parse-tree-il
- unparse-tree-il
- tree-il->scheme))
+ #:export (tree-il-src
+
+ <lexical> make-lexical
+ lexical-name lexical-gensym
+
+ <application> make-application application-src application-proc
application-args
+ <conditional> make-conditional conditional-src conditional-test
conditional-then conditional-else
+ <primitive-ref> make-primitive-ref primitive-ref-src
primitive-ref-name
+ <lexical-ref> make-lexical-ref lexical-ref-src lexical-ref-name
lexical-ref-gensym
+ <lexical-set> make-lexical-set lexical-set-src lexical-set-name
lexical-set-gensym lexical-set-exp
+ <module-ref> make-module-ref module-ref-src module-ref-mod
module-ref-name module-ref-public?
+ <module-set> make-module-set module-set-src module-set-mod
module-set-name module-set-public? module-set-exp
+ <toplevel-ref> make-toplevel-ref toplevel-ref-src toplevel-ref-name
+ <toplevel-set> make-toplevel-set toplevel-set-src
toplevel-set-name toplevel-set-exp
+ <toplevel-define> make-toplevel-define toplevel-define-src
toplevel-define-name toplevel-define-exp
+ <lambda> make-lambda lambda-src lambda-vars lambda-meta lambda-body
+ <const> make-const const-src const-exp
+ <sequence> make-sequence sequence-src sequence-exps
+ <let> make-let let-src let-vars let-vals let-exp
+ <letrec> make-letrec letrec-src letrec-vars letrec-vals letrec-exp
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme))
(define-type (<tree-il> #:common-slots (src))
(<application> proc args)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 3a02255..d75ae7a 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -27,156 +27,11 @@
#:export (compile-glil))
(define (compile-glil x e opts)
- (if (memq #:O opts) (set! x (optimize x)))
(values (codegen x)
(and e (cons (car e) (cddr e)))
e))
-;;;
-;;; Stage 2: Optimization
-;;;
-
-(define (lift-variables! env)
- (let ((parent-env (ghil-env-parent env)))
- (for-each (lambda (v)
- (case (ghil-var-kind v)
- ((argument) (set! (ghil-var-kind v) 'local)))
- (set! (ghil-var-env v) parent-env)
- (ghil-env-add! parent-env v))
- (ghil-env-variables env))))
-
-;; The premise of this, unused, approach to optimization is that you can
-;; determine the environment of a variable lexically, because they have
-;; been alpha-renamed. It makes the transformations *much* easier.
-;; Unfortunately it doesn't work yet.
-(define (optimize* x)
- (transform-record (<ghil> env loc) x
- ((quasiquote exp)
- (define (optimize-qq x)
- (cond ((list? x) (map optimize-qq x))
- ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
- ((record? x) (optimize x))
- (else x)))
- (-> (quasiquote (optimize-qq x))))
-
- ((unquote exp)
- (-> (unquote (optimize exp))))
-
- ((unquote-splicing exp)
- (-> (unquote-splicing (optimize exp))))
-
- ((set var val)
- (-> (set var (optimize val))))
-
- ((define var val)
- (-> (define var (optimize val))))
-
- ((if test then else)
- (-> (if (optimize test) (optimize then) (optimize else))))
-
- ((and exps)
- (-> (and (map optimize exps))))
-
- ((or exps)
- (-> (or (map optimize exps))))
-
- ((begin exps)
- (-> (begin (map optimize exps))))
-
- ((bind vars vals body)
- (-> (bind vars (map optimize vals) (optimize body))))
-
- ((mv-bind producer vars rest body)
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((inline inst args)
- (-> (inline inst (map optimize args))))
-
- ((call (proc (lambda vars (rest #f) meta body)) args)
- (-> (bind vars (optimize args) (optimize body))))
-
- ((call proc args)
- (-> (call (optimize proc) (map optimize args))))
-
- ((lambda vars rest meta body)
- (-> (lambda vars rest meta (optimize body))))
-
- ((mv-call producer (consumer (lambda vars rest meta body)))
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((mv-call producer consumer)
- (-> (mv-call (optimize producer) (optimize consumer))))
-
- ((values values)
- (-> (values (map optimize values))))
-
- ((values* values)
- (-> (values* (map optimize values))))
-
- (else
- (error "unrecognized GHIL" x))))
-
-(define (optimize x)
- (record-case x
- ((<ghil-set> env loc var val)
- (make-ghil-set env var (optimize val)))
-
- ((<ghil-define> env loc var val)
- (make-ghil-define env var (optimize val)))
-
- ((<ghil-if> env loc test then else)
- (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
-
- ((<ghil-and> env loc exps)
- (make-ghil-and env loc (map optimize exps)))
-
- ((<ghil-or> env loc exps)
- (make-ghil-or env loc (map optimize exps)))
-
- ((<ghil-begin> env loc exps)
- (make-ghil-begin env loc (map optimize exps)))
-
- ((<ghil-bind> env loc vars vals body)
- (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (make-ghil-lambda env loc vars rest meta (optimize body)))
-
- ((<ghil-inline> env loc instruction args)
- (make-ghil-inline env loc instruction (map optimize args)))
-
- ((<ghil-call> env loc proc args)
- (let ((parent-env env))
- (record-case proc
- ;; ((@lambda (VAR...) BODY...) ARG...) =>
- ;; (@let ((VAR ARG) ...) BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (cond
- ((not rest)
- (lift-variables! env)
- (make-ghil-bind parent-env loc (map optimize args)))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize
args)))))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize
args))))))
-
- ((<ghil-mv-call> env loc producer consumer)
- (record-case consumer
- ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
- ;; (mv-let PRODUCER ARGS BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (lift-variables! env)
- (make-ghil-mv-bind producer vars rest body))
- (else
- (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
-
- (else x)))
-
-
-;;;
-;;; Stage 3: Code generation
-;;;
(define *ia-void* (make-glil-void))
(define *ia-drop* (make-glil-call 'drop 1))
@@ -202,33 +57,24 @@
(eq? (ghil-var-kind var) 'public)))
(else (error "Unknown kind of variable:" var))))
-(define (constant? x)
- (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
- ((pair? x) (and (constant? (car x))
- (constant? (cdr x))))
- ((vector? x) (let lp ((i (vector-length x)))
- (or (zero? i)
- (and (constant? (vector-ref x (1- i)))
- (lp (1- i))))))))
-
(define (codegen ghil)
(let ((stack '()))
- (define (push-code! loc code)
+ (define (push-code! src code)
(set! stack (cons code stack))
- (if loc (set! stack (cons (make-glil-source loc) 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! loc vars)
+ (define (push-bindings! src vars)
(if (not (null? vars))
- (push-code! loc (make-glil-bind (map var->binding 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! loc inst label)
- (push-code! loc (make-glil-branch inst label)))
- (define (push-call! loc inst args)
+ (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! loc (make-glil-call inst (length args))))
+ (push-code! src (make-glil-call inst (length args))))
;; possible tail position
(define (comp-tail tree) (comp tree tail drop))
;; push the result
@@ -242,72 +88,38 @@
(define (maybe-return)
(if tail (push-code! #f *ia-return*)))
;; return this code if necessary
- (define (return-code! loc code)
- (if (not drop) (push-code! loc code))
+ (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! loc obj)
- (return-code! loc (make-glil-const obj)))
+ (define (return-object! src obj)
+ (return-code! src (make-glil-const obj)))
;;
;; dispatch
(record-case tree
((<ghil-void>)
(return-void!))
- ((<ghil-quote> env loc obj)
- (return-object! loc obj))
-
- ((<ghil-quasiquote> env loc exp)
- (let loop ((x exp) (in-car? #f))
- (cond
- ((list? x)
- (push-call! #f 'mark '())
- (for-each (lambda (x) (loop x #t)) x)
- (push-call! #f 'list-mark '()))
- ((pair? x)
- (push-call! #f 'mark '())
- (loop (car x) #t)
- (loop (cdr x) #f)
- (push-call! #f 'cons-mark '()))
- ((record? x)
- (record-case x
- ((<ghil-unquote> env loc exp)
- (comp-push exp))
- ((<ghil-unquote-splicing> env loc exp)
- (if (not in-car?)
- (error "unquote-splicing in the cdr of a pair" exp))
- (comp-push exp)
- (push-call! #f 'list-break '()))))
- ((constant? x)
- (push-code! #f (make-glil-const x)))
- (else
- (error "element of quasiquote can't be compiled" x))))
- (maybe-drop)
- (maybe-return))
+ ((<ghil-quote> env src obj)
+ (return-object! src obj))
- ((<ghil-unquote> env loc exp)
- (error "unquote outside of quasiquote" exp))
+ ((<ghil-ref> env src var)
+ (return-code! src (make-glil-var 'ref env var)))
- ((<ghil-unquote-splicing> env loc exp)
- (error "unquote-splicing outside of quasiquote" exp))
-
- ((<ghil-ref> env loc var)
- (return-code! loc (make-glil-var 'ref env var)))
-
- ((<ghil-set> env loc var val)
+ ((<ghil-set> env src var val)
(comp-push val)
- (push-code! loc (make-glil-var 'set env var))
+ (push-code! src (make-glil-var 'set env var))
(return-void!))
- ((<ghil-define> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'define env var))
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (push-code! src (make-glil-var 'define env var))
(return-void!))
- ((<ghil-if> env loc test then else)
+ ((<conditional> src test then else)
;; TEST
;; (br-if-not L1)
;; THEN
@@ -316,65 +128,14 @@
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(comp-push test)
- (push-branch! loc 'br-if-not L1)
+ (push-branch! src 'br-if-not L1)
(comp-tail then)
(if (not tail) (push-branch! #f 'br L2))
(push-label! L1)
(comp-tail else)
(if (not tail) (push-label! L2))))
- ((<ghil-and> env loc exps)
- ;; EXP
- ;; (br-if-not L1)
- ;; ...
- ;; TAIL
- ;; (br L2)
- ;; L1: (const #f)
- ;; L2:
- (cond ((null? exps) (return-object! loc #t))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)) (L2 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-branch! #f 'br L2)
- (push-label! L1)
- (return-object! #f #f)
- (push-label! L2)
- (maybe-return))
- (else
- (comp-push (car exps))
- (push-branch! #f 'br-if-not L1)
- (lp (cdr exps)))))))))
-
- ((<ghil-or> env loc exps)
- ;; EXP
- ;; (dup)
- ;; (br-if L1)
- ;; (drop)
- ;; ...
- ;; TAIL
- ;; L1:
- (cond ((null? exps) (return-object! loc #f))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-label! L1)
- (maybe-return))
- (else
- (comp-push (car exps))
- (if (not drop)
- (push-call! #f 'dup '()))
- (push-branch! #f 'br-if L1)
- (if (not drop)
- (push-code! loc (make-glil-call 'drop 1)))
- (lp (cdr exps)))))))))
-
- ((<ghil-begin> env loc exps)
+ ((<sequence> src exps)
;; EXPS...
;; TAIL
(if (null? exps)
@@ -384,24 +145,24 @@
(comp-tail (car exps)))
(comp-drop (car exps)))))
- ((<ghil-bind> env loc vars vals body)
+ ((<let> src vars vals body)
;; VALS...
;; (set VARS)...
;; BODY
(for-each comp-push vals)
- (push-bindings! loc vars)
+ (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 loc producer vars rest body)
+ ((<ghil-mv-bind> env src producer vars rest body)
;; VALS...
;; (set VARS)...
;; BODY
(let ((MV (make-label)))
(comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
+ (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))
@@ -410,10 +171,10 @@
(comp-tail body)
(push-code! #f (make-glil-unbind)))
- ((<ghil-lambda> env loc vars rest meta body)
- (return-code! loc (codegen tree)))
+ ((<ghil-lambda> env src vars rest meta body)
+ (return-code! src (codegen tree)))
- ((<ghil-inline> env loc inline args)
+ ((<ghil-inline> env src inline args)
;; ARGS...
;; (INST NARGS)
(let ((tail-table '((call . goto/args)
@@ -421,50 +182,50 @@
(call/cc . goto/cc))))
(cond ((and tail (assq-ref tail-table inline))
=> (lambda (tail-inst)
- (push-call! loc tail-inst args)))
+ (push-call! src tail-inst args)))
(else
- (push-call! loc inline args)
+ (push-call! src inline args)
(maybe-drop)
(maybe-return)))))
- ((<ghil-values> env loc values)
+ ((<ghil-values> env src values)
(cond (tail ;; (lambda () (values 1 2))
- (push-call! loc 'return/values values))
+ (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! loc 'call values))))
+ (push-call! src 'call values))))
- ((<ghil-values*> env loc values)
+ ((<ghil-values*> env src values)
(cond (tail ;; (lambda () (apply values '(1 2)))
- (push-call! loc 'return/values* values))
+ (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! loc 'apply values))))
+ (push-call! src 'apply values))))
- ((<ghil-call> env loc proc args)
+ ((<ghil-call> env src proc args)
;; PROC
;; ARGS...
;; ([tail-]call NARGS)
(comp-push proc)
(let ((nargs (length args)))
(cond ((< nargs 255)
- (push-call! loc (if tail 'goto/args 'call) args))
+ (push-call! src (if tail 'goto/args 'call) args))
(else
- (push-call! loc 'mark '())
+ (push-call! src 'mark '())
(for-each comp-push args)
- (push-call! loc 'list-mark '())
- (push-code! loc (make-glil-call (if tail 'goto/apply 'apply)
2)))))
+ (push-call! src 'list-mark '())
+ (push-code! src (make-glil-call (if tail 'goto/apply 'apply)
2)))))
(maybe-drop))
- ((<ghil-mv-call> env loc producer consumer)
+ ((<ghil-mv-call> env src producer consumer)
;; CONSUMER
;; PRODUCER
;; (mv-call MV)
@@ -475,25 +236,25 @@
(let ((MV (make-label)) (POST (make-label)))
(comp-push consumer)
(comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
+ (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! loc (make-glil-call (if tail 'goto/nargs 'call/nargs)
0))
+ (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 loc)
- (return-object! loc (ghil-env-reify env)))))
+ ((<ghil-reified-env> env src)
+ (return-object! src (ghil-env-reify env)))))
;;
;; main
(record-case ghil
- ((<ghil-lambda> env loc vars rest meta body)
+ ((<ghil-lambda> env src vars rest meta body)
(let* ((evars (ghil-env-variables env))
- (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+ (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))
@@ -501,7 +262,7 @@
;; meta bindings
(push-bindings! #f vars)
;; push on definition source location
- (if loc (set! stack (cons (make-glil-source loc) stack)))
+ (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)))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
new file mode 100644
index 0000000..69aff6f
--- /dev/null
+++ b/module/language/tree-il/optimize.scm
@@ -0,0 +1,143 @@
+;;; Tree-il optimizer
+
+;; Copyright (C) 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 optimize)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (resolve-primitives!))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;; * always when single call site
+;; * always for "trivial" procs
+;; * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
+(define (post-order! f x)
+ (let lp ((x x))
+ (record-case x
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args))
+ (or (f x) x))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else))
+ (or (f x) x))
+
+ ((<primitive-ref> name)
+ (or (f x) x))
+
+ ((<lexical-ref> name gensym)
+ (or (f x) x))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<module-ref> mod name public?)
+ (or (f x) x))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-ref> name)
+ (or (f x) x))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body))
+ (or (f x) x))
+
+ ((<const> exp)
+ (or (f x) x))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps))
+ (or (f x) x))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp))
+ (or (f x) x)))))
+
+(define *interesting-primitive-names*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ values
+ ;; compile-time-environment
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+
+ car cdr
+ set-car! set-cdr!
+
+ caar cadr cdar cddr
+
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+
+(define *interesting-primitive-vars*
+ (let ((h (make-hash-table)))
+ (for-each (lambda (x)
+ (hashq-set! h (module-variable the-root-module x) x))
+ *interesting-primitive-names*)
+ h))
+
+(define (resolve-primitives! x mod)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name))
+ (make-primitive-ref src name)))
+ ((<module-ref> mod name public?)
+ (let ((m (if public? (resolve-interface mod) (resolve-module mod))))
+ (and m (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (make-primitive-ref src name))))
+ (else #f)))
+ x))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index d69a4ec..c1f0982 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -29,24 +29,15 @@
(define (write-tree-il exp . port)
(apply write (unparse-tree-il exp) port))
-(define (parse x)
- (make-lambda #f '() '() (parse-tree-il x)))
-
(define (join exps env)
- (if (or-map (lambda (x)
- (or (not (lambda? x))
- (not (null? (lambda-vars x)))))
- exps)
- (error "tree-il expressions to join must be thunks"))
-
- (make-lambda #f '() '() (make-sequence #f (map lambda-body exps))))
+ (make-sequence #f exps))
(define-language tree-il
#:title "Tree Intermediate Language"
#:version "1.0"
#:reader read
#:printer write-tree-il
- #:parser parse
+ #:parser parse-tree-il
#:joiner join
#:compilers `((glil . ,compile-glil))
)
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 9efc833d65adef11e76410fee7ea548143131417,
Andy Wingo <=