guile-commits
[Top][All Lists]
Advanced

[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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]