summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/assembly/disassemble.scm2
-rw-r--r--module/language/ecmascript/spec.scm1
-rw-r--r--module/language/ghil/compile-glil.scm14
-rw-r--r--module/language/glil.scm9
-rw-r--r--module/language/glil/compile-assembly.scm31
-rw-r--r--module/language/glil/decompile-assembly.scm8
-rw-r--r--module/language/scheme/amatch.scm37
-rw-r--r--module/language/scheme/compile-ghil.scm48
-rw-r--r--module/language/scheme/compile-tree-il.scm64
-rw-r--r--module/language/scheme/decompile-tree-il.scm27
-rw-r--r--module/language/scheme/expand.scm307
-rw-r--r--module/language/scheme/spec.scm13
-rw-r--r--module/language/tree-il.scm359
-rw-r--r--module/language/tree-il/analyze.scm235
-rw-r--r--module/language/tree-il/compile-glil.scm448
-rw-r--r--module/language/tree-il/optimize.scm42
-rw-r--r--module/language/tree-il/primitives.scm206
-rw-r--r--module/language/tree-il/spec.scm43
18 files changed, 1466 insertions, 428 deletions
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 2752934f9..df6199977 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -82,7 +82,7 @@
(if (program? x)
(begin (display "----------------------------------------\n")
(disassemble x))))
- (cddr (vector->list objs))))))
+ (cdr (vector->list objs))))))
(else
(error "bad load-program form" asm))))
diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm
index 550a0b734..0112af5a4 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -33,7 +33,6 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
#:compilers `((ghil . ,compile-ghil))
;; a pretty-printer would be interesting.
#:printer write
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index c813319d6..02187be05 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -187,7 +187,7 @@
(define (make-glil-var op env var)
(case (ghil-var-kind var)
((argument)
- (make-glil-argument op (ghil-var-index var)))
+ (make-glil-local op (ghil-var-index var)))
((local)
(make-glil-local op (ghil-var-index var)))
((external)
@@ -217,7 +217,9 @@
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
(define (var->binding var)
- (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
+ (case kind ((argument) 'local) (else kind)))
+ (ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
(push-code! loc (make-glil-bind (map var->binding vars)))))
@@ -496,7 +498,7 @@
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
(nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body))
+ (nlocs (allocate-locals! locs body nargs))
(nexts (allocate-indices-linearly! exts)))
;; meta bindings
(push-bindings! #f vars)
@@ -509,7 +511,7 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
- (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-local 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
;; compile body
(comp body #t #f)
@@ -523,8 +525,8 @@
((null? l) n)
(let ((v (car l))) (set! (ghil-var-index v) n))))
-(define (allocate-locals! vars body)
- (let ((free '()) (nlocs 0))
+(define (allocate-locals! vars body nargs)
+ (let ((free '()) (nlocs nargs))
(define (allocate! var)
(cond
((pair? free)
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 01b680194..625760eaa 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
- <glil-argument> make-glil-argument glil-argument?
- glil-argument-op glil-argument-index
-
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
@@ -125,13 +121,12 @@
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
- ((label ,label) (make-label ,label))
+ ((label ,label) (make-label label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
@@ -150,8 +145,6 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-argument> op index)
- `(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index ffac9dbfb..4c92e0f5a 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -83,16 +83,15 @@
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
- ((,name argument ,i) (make-open-binding name #f i))
- ((,name local ,i) (make-open-binding name #f (+ nargs i)))
+ ((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
- (else (error "unknown binding type" name type))))
+ (else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@@ -129,13 +128,13 @@
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f -1)
+ (glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
-(define (glil->assembly glil nargs nexts-stack bindings
+(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
@@ -159,7 +158,7 @@
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
+ (glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
@@ -196,14 +195,14 @@
((<glil-bind> vars)
(values '()
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
@@ -238,16 +237,11 @@
(emit-code/object `((object-ref ,i))
object-alist)))))
- ((<glil-argument> op index)
+ ((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,(+ nargs index)))
- `((local-set ,(+ nargs index))))))
-
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)
@@ -318,7 +312,12 @@
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
- (emit-code `((,inst ,nargs))))
+ (case (instruction-length inst)
+ ((1) (emit-code `((,inst ,nargs))))
+ ((2) (emit-code `((,inst ,(quotient nargs 256)
+ ,(modulo nargs 256)))))
+ (else (error "Unknown length for variable-arg instruction:"
+ inst (instruction-length inst)))))
((= pops nargs)
(emit-code `((,inst))))
(else
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index a98c39975..a47bd80b2 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -175,15 +175,11 @@
(1+ pos)))
((local-ref ,n)
(lp (cdr in) (cons *placeholder* stack)
- (cons (if (< n nargs)
- (make-glil-argument 'ref n)
- (make-glil-local 'ref (- n nargs)))
+ (cons (make-glil-local 'ref n)
out) (+ pos 2)))
((local-set ,n)
(lp (cdr in) (cdr stack)
- (cons (if (< n nargs)
- (make-glil-argument 'set n)
- (make-glil-local 'set (- n nargs)))
+ (cons (make-glil-local 'set n)
(emit-constants (list-head stack 1) out))
(+ pos 2)))
((br-if-not ,l)
diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm
deleted file mode 100644
index 4ac973620..000000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-(define-module (language scheme amatch)
- #:use-module (ice-9 syncase)
- #:export (amatch apat))
-;; FIXME: shouldn't have to export apat...
-
-;; 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 86234059e..8d8332c34 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,13 +27,11 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module (ice-9 expand-support)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
@@ -70,12 +68,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (make-ghil-lambda env #f vars #f '()
- (translate-1 env #f x)))
- (cenv (make-cenv (current-module)
- (ghil-env-parent env)
- (if e (cenv-externals e) '()))))
- (values x cenv cenv)))))))
+ (let ((x (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))))
+ (let ((x (make-ghil-lambda env #f vars #f '()
+ (translate-1 env #f x)))
+ (cenv (make-cenv (current-module)
+ (ghil-env-parent env)
+ (if e (cenv-externals e) '()))))
+ (values x cenv cenv))))))))
;;;
@@ -104,9 +104,6 @@
(let* ((mod (current-module))
(val (cond
((symbol? head) (module-ref/safe mod head))
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((macro? head) head)
((pmatch head
((@ ,modname ,sym)
(module-ref/safe (resolve-interface modname) sym))
@@ -117,21 +114,6 @@
(cond
((hashq-ref *translate-table* val))
- ((defmacro? val)
- (lambda (env loc exp)
- (retrans (apply (defmacro-transformer val) (cdr exp)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (lambda (env loc exp)
- (retrans
- (strip-expansion-structures
- (sc-expand3 exp 'c '(compile load eval)))))))
-
- ((primitive-macro? val)
- (syntax-error #f "unhandled primitive macro" head))
-
((macro? val)
(syntax-error #f "unknown kind of macro" head))
@@ -180,7 +162,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- ,sym
+ (module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@@ -432,16 +414,6 @@
(,args
(-> (values (map retrans args)))))
-(define-scheme-translator compile-time-environment
- ;; (compile-time-environment)
- ;; => (MODULE LEXICALS . EXTERNALS)
- (()
- (-> (inline 'cons
- (list (retrans '(current-module))
- (-> (inline 'cons
- (list (-> (reified-env))
- (-> (inline 'externals '()))))))))))
-
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)
diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm
new file mode 100644
index 000000000..4635abc8a
--- /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/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
new file mode 100644
index 000000000..c4903d87f
--- /dev/null
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -0,0 +1,27 @@
+;;; Guile VM code converters
+
+;; 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
+;; 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 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/expand.scm b/module/language/scheme/expand.scm
deleted file mode 100644
index 2ffefb318..000000000
--- a/module/language/scheme/expand.scm
+++ /dev/null
@@ -1,307 +0,0 @@
-;;; 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 expand)
- #:use-module (language scheme amatch)
- #:use-module (ice-9 expand-support)
- #:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (expand *expand-table* define-scheme-expander))
-
-(define (aref x) (if (annotation? x) (annotation-expression x) x))
-(define (apair? x) (pair? (aref x)))
-(define (acar x) (car (aref x)))
-(define (acdr x) (cdr (aref x)))
-(define (acaar x) (acar (acar x)))
-(define (acdar x) (acdr (acar x)))
-(define (acadr x) (acar (acdr x)))
-(define (acddr x) (acdr (acdr x)))
-(define (aloc x) (and (annotation? x) (annotation-source x)))
-(define (re-annotate x y)
- (if (and (annotation? x) (not (annotation? y)))
- (make-annotation y (annotation-source x))
- y))
-(define-macro (-> exp) `(re-annotate x ,exp))
-
-(define* (expand x #:optional (mod (current-module)) (once? #f))
- (define re-expand
- (if once?
- (lambda (x) x)
- (lambda (x) (expand x mod once?))))
- (let ((exp (if (annotation? x) (annotation-expression x) x)))
- (cond
- ((pair? exp)
- (let ((head (car exp)) (tail (cdr exp)))
- (cond
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((or (symbol? head) (macro? head))
- (let ((val (cond
- ((macro? head) head)
- ((module-variable mod head)
- => (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))
- (else #f))))
- (cond
- ((hashq-ref *expand-table* val)
- => (lambda (expand1) (expand1 x re-expand)))
-
- ((defmacro? val)
- (re-expand (-> (apply (defmacro-transformer val)
- (deannotate tail)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (re-expand
- (with-fluids ((eec (module-eval-closure mod)))
- ;; fixme -- use ewes fluid?
- (sc-expand3 exp 'c '(compile load eval))))))
-
- ((primitive-macro? val)
- (syntax-error (aloc x) "unhandled primitive macro" head))
-
- ((macro? val)
- (syntax-error (aloc x) "unknown kind of macro" head))
-
- (else
- (-> (cons head (map re-expand tail)))))))
-
- (else
- (-> (map re-expand exp))))))
-
- (else x))))
-
-
-(define *expand-table* (make-hash-table))
-
-(define-macro (define-scheme-expander sym . clauses)
- `(hashq-set! (@ (language scheme expand) *expand-table*)
- ,sym
- (lambda (x re-expand)
- (define syntax-error (@ (system base compile) syntax-error))
- (amatch (acdr x)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error (aloc x) (format #f "bad ~A" ',sym) x))))))))
-
-(define-scheme-expander quote
- ;; (quote OBJ)
- ((,obj) x))
-
-(define-scheme-expander quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> `(,'quasiquote
- ,(let lp ((x obj) (level 0))
- (cond ((not (apair? x)) x)
- ;; FIXME: hygiene regarding imported , / ,@ rebinding
- ((memq (acar x) '(unquote unquote-splicing))
- (amatch (acdr x)
- ((,obj)
- (cond
- ((zero? level)
- (-> `(,(acar x) ,(re-expand obj))))
- (else
- (-> `(,(acar x) ,(lp obj (1- level)))))))
- (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x))))
- ((eq? (acar x) 'quasiquote)
- (amatch (acdr x)
- ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
- (else (syntax-error (aloc x) "bad quasiquote" x))))
- (else (-> (cons (lp (acar x) level) (lp (acdr x) level))))))))))
-
-(define-scheme-expander define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(define ,name ,(re-expand val))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (re-expand (-> `(define ,name (lambda ,formals . ,body))))))
-
-(define-scheme-expander set!
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name)
- (not (eq? name '@)) (not (eq? name '@@)))
- ;; -> ((setter NAME) ARGS... VAL)
- (re-expand (-> `((setter ,name) ,@args ,val))))
-
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(set! ,name ,(re-expand val)))))
-
-(define-scheme-expander if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> `(if ,(re-expand test) ,(re-expand then))))
- ((,test ,then ,else)
- (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
-
-(define-scheme-expander and
- ;; (and EXPS...)
- (,tail
- (-> `(and . ,(map re-expand tail)))))
-
-(define-scheme-expander or
- ;; (or EXPS...)
- (,tail
- (-> `(or . ,(map re-expand tail)))))
-
-(define-scheme-expander begin
- ;; (begin EXPS...)
- ((,single-exp)
- (-> (re-expand single-exp)))
- (,tail
- (-> `(begin . ,(map re-expand tail)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (amatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? (aref bindings))
- (and-map valid-binding? (aref bindings))))
-
-(define-scheme-expander let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
- . ,body)))
- (,name . ,(map acadr (aref bindings)))))))
-
- ((() . ,body)
- (re-expand (expand-internal-defines body)))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(let ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (re-expand (-> `(let () . ,body))))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
-
-(define-scheme-expander letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(letrec ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (-> '(begin)))
- (((else . ,body)) (re-expand (-> `(begin ,@body))))
- (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
- (((,test . ,body) . ,rest)
- (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
-
-(define-scheme-expander case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- ;; FIXME hygiene!
- (re-expand
- (->`(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
- (else `(if (memv _t ',(acaar ls))
- (begin ,@(acdar ls))
- ,(loop (acdr ls)))))))))))
-
-(define-scheme-expander do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
- (let ((sym (map acar (aref bindings)))
- (val (map acadr (aref bindings)))
- (update (map acddr (aref bindings))))
- (define (next s x) (if (pair? x) (car x) s))
- (re-expand
- ;; FIXME hygiene!
- (-> `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val)))))))
-
-(define-scheme-expander lambda
- ;; (lambda FORMALS BODY...)
- ((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
- (-> `(lambda ,formals ,docstring ,(expand-internal-defines
- (map re-expand (cons body1 body))))))
- ((,formals . ,body)
- (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander delay
- ;; FIXME not hygienic
- ((,expr)
- (re-expand `(make-promise (lambda () ,expr)))))
-
-(define-scheme-expander @
- ((,modname ,sym)
- x))
-
-(define-scheme-expander @@
- ((,modname ,sym)
- x))
-
-(define-scheme-expander eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (-> `(begin . ,body))
- (-> `(begin)))))
-
-;;; Hum, I don't think this takes imported modifications to `define'
-;;; properly into account. (Lexical bindings are OK because of alpha
-;;; renaming.)
-(define (expand-internal-defines body)
- (let loop ((ls body) (ds '()))
- (amatch ls
- (() (syntax-error l "bad body" body))
- (((define ,name ,val) . _)
- (loop (acdr ls) (cons (list name val) ds)))
- (else
- (if (null? ds)
- (if (null? (cdr ls)) (car ls) `(begin ,@ls))
- `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb63..cec2693aa 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))
;;;
@@ -30,12 +32,6 @@
(read-enable 'positions)
-(define (read-file port)
- (do ((x (read port) (read port))
- (l '() (cons x l)))
- ((eof-object? x)
- (cons 'begin (reverse! l)))))
-
;;;
;;; Language definition
;;;
@@ -44,8 +40,9 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #: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
new file mode 100644
index 000000000..335031182
--- /dev/null
+++ b/module/language/tree-il.scm
@@ -0,0 +1,359 @@
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+(define-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:export (tree-il-src
+
+ <void> void? make-void void-src
+ <const> const? make-const const-src const-exp
+ <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
+ <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
+ <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
+ <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
+ <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
+ <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
+ <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
+ <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
+ <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
+ <application> application? make-application application-src application-proc application-args
+ <sequence> sequence? make-sequence sequence-src sequence-exps
+ <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
+ <let> let? make-let let-src let-names let-vars let-vals let-exp
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme
+
+ post-order!
+ pre-order!))
+
+(define-type (<tree-il> #:common-slots (src))
+ (<void>)
+ (<const> exp)
+ (<primitive-ref> name)
+ (<lexical-ref> name gensym)
+ (<lexical-set> name gensym exp)
+ (<module-ref> mod name public?)
+ (<module-set> mod name public? exp)
+ (<toplevel-ref> name)
+ (<toplevel-set> name exp)
+ (<toplevel-define> name exp)
+ (<conditional> test then else)
+ (<application> proc args)
+ (<sequence> exps)
+ (<lambda> names vars meta body)
+ (<let> names vars vals exp)
+ (<letrec> names vars vals exp))
+
+
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (pair? props) props))))
+
+(define (parse-tree-il exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-tree-il x))))
+ (pmatch exp
+ ((void)
+ (make-void loc))
+
+ ((apply ,proc . ,args)
+ (make-application loc (retrans proc) (map retrans args)))
+
+ ((if ,test ,then ,else)
+ (make-conditional loc (retrans test) (retrans then) (retrans else)))
+
+ ((primitive ,name) (guard (symbol? name))
+ (make-primitive-ref loc name))
+
+ ((lexical ,name) (guard (symbol? name))
+ (make-lexical-ref loc name name))
+
+ ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+ (make-lexical-ref loc name sym))
+
+ ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+ (make-lexical-set loc name sym (retrans exp)))
+
+ ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #t))
+
+ ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #t (retrans exp)))
+
+ ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #f))
+
+ ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #f (retrans exp)))
+
+ ((toplevel ,name) (guard (symbol? name))
+ (make-toplevel-ref loc name))
+
+ ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+ (make-toplevel-set loc name (retrans exp)))
+
+ ((define ,name ,exp) (guard (symbol? name))
+ (make-toplevel-define loc name (retrans exp)))
+
+ ((lambda ,names ,vars ,exp)
+ (make-lambda loc names vars '() (retrans exp)))
+
+ ((lambda ,names ,vars ,meta ,exp)
+ (make-lambda loc names vars meta (retrans exp)))
+
+ ((const ,exp)
+ (make-const loc exp))
+
+ ((begin . ,exps)
+ (make-sequence loc (map retrans exps)))
+
+ ((let ,names ,vars ,vals ,exp)
+ (make-let loc names vars (map retrans vals) (retrans exp)))
+
+ ((letrec ,names ,vars ,vals ,exp)
+ (make-letrec loc names vars (map retrans vals) (retrans exp)))
+
+ (else
+ (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+ (record-case tree-il
+ ((<void>)
+ '(void))
+
+ ((<application> proc args)
+ `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<conditional> test then else)
+ `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
+
+ ((<primitive-ref> name)
+ `(primitive ,name))
+
+ ((<lexical-ref> name gensym)
+ `(lexical ,name ,gensym))
+
+ ((<lexical-set> name gensym exp)
+ `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-ref> name)
+ `(toplevel ,name))
+
+ ((<toplevel-set> name exp)
+ `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(unparse-tree-il exp)))
+
+ ((<lambda> names vars meta body)
+ `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+
+ ((<const> exp)
+ `(const ,exp))
+
+ ((<sequence> exps)
+ `(begin ,@(map unparse-tree-il exps)))
+
+ ((<let> names vars vals exp)
+ `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+ ((<letrec> names vars vals exp)
+ `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
+
+(define (tree-il->scheme e)
+ (cond ((list? e)
+ (map tree-il->scheme e))
+ ((pair? e)
+ (cons (tree-il->scheme (car e))
+ (tree-il->scheme (cdr e))))
+ ((record? e)
+ (record-case e
+ ((<void>)
+ '(if #f #f))
+
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ (if (void? else)
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> name gensym)
+ gensym)
+
+ ((<lexical-set> name gensym exp)
+ `(set! ,gensym ,(tree-il->scheme exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(tree-il->scheme exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(tree-il->scheme exp)))
+
+ ((<lambda> vars meta body)
+ `(lambda ,vars
+ ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+ ,(tree-il->scheme body)))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+ ((<sequence> exps)
+ `(begin ,@(map tree-il->scheme exps)))
+
+ ((<let> vars vals exp)
+ `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
+ (else e)))
+
+(define (post-order! f x)
+ (let lp ((x x))
+ (record-case x
+ ((<void>)
+ (or (f x) x))
+
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args))
+ (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 (pre-order! f x)
+ (let lp ((x x))
+ (let ((x (or (f x) x)))
+ (record-case x
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args)))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else)))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp)))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp)))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp)))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp)))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body)))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps)))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp)))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp)))
+
+ (else #f))
+ x)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
new file mode 100644
index 000000000..477f1fc2d
--- /dev/null
+++ b/module/language/tree-il/analyze.scm
@@ -0,0 +1,235 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals))
+
+;; allocation: the process of assigning a type and index to each var
+;; a var is external if it is heaps; assigning index is easy
+;; args are assigned in order
+;; locals are indexed as their linear position in the binding path
+;; (let (0 1)
+;; (let (2 3) ...)
+;; (let (2) ...))
+;; (let (2 3 4) ...))
+;; etc.
+;;
+;; This algorithm has the problem that variables are only allocated
+;; indices at the end of the binding path. If variables bound early in
+;; the path are not used in later portions of the path, their indices
+;; will not be recycled. This problem is particularly egregious in the
+;; expansion of `or':
+;;
+;; (or x y z)
+;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
+;;
+;; As you can see, the `a' binding is only used in the ephemeral `then'
+;; clause of the first `if', but its index would be reserved for the
+;; whole of the `or' expansion. So we have a hack for this specific
+;; case. A proper solution would be some sort of liveness analysis, and
+;; not our linear allocation algorithm.
+;;
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define (analyze-lexicals x)
+ ;; parents: lambda -> parent
+ ;; useful when we see a closed-over var, so we can calculate its
+ ;; coordinates (depth and index).
+ ;; bindings: lambda -> (sym ...)
+ ;; useful for two reasons: one, so we know how much space to allocate
+ ;; when we go into a lambda; and two, so that we know when to stop,
+ ;; when looking for closed-over vars.
+ ;; heaps: sym -> lambda
+ ;; allows us to heapify vars in an O(1) fashion
+ ;; refcounts: sym -> count
+ ;; allows us to detect the or-expansion an O(1) time
+
+ (define (find-heap sym parent)
+ ;; fixme: check displaced lexicals here?
+ (if (memq sym (hashq-ref bindings parent))
+ parent
+ (find-heap sym (hashq-ref parents parent))))
+
+ (define (analyze! x parent level)
+ (define (step y) (analyze! y parent level))
+ (define (recur x parent) (analyze! x parent (1+ level)))
+ (record-case x
+ ((<application> proc args)
+ (step proc) (for-each step args))
+
+ ((<conditional> test then else)
+ (step test) (step then) (step else))
+
+ ((<lexical-ref> name gensym)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (and (not (memq gensym (hashq-ref bindings parent)))
+ (not (hashq-ref heaps gensym)))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<lexical-set> name gensym exp)
+ (step exp)
+ (if (not (hashq-ref heaps gensym))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<module-set> mod name public? exp)
+ (step exp))
+
+ ((<toplevel-set> name exp)
+ (step exp))
+
+ ((<toplevel-define> name exp)
+ (step exp))
+
+ ((<sequence> exps)
+ (for-each step exps))
+
+ ((<lambda> vars meta body)
+ (hashq-set! parents x parent)
+ (hashq-set! bindings x
+ (let rev* ((vars vars) (out '()))
+ (cond ((null? vars) out)
+ ((pair? vars) (rev* (cdr vars)
+ (cons (car vars) out)))
+ (else (cons vars out)))))
+ (recur body x)
+ (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
+
+ ((<let> vars vals exp)
+ (for-each step vals)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (step exp))
+
+ ((<letrec> vars vals exp)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (for-each step vals)
+ (step exp))
+
+ (else #f)))
+
+ (define (allocate-heap! binder)
+ (hashq-set! heap-indexes binder
+ (1+ (hashq-ref heap-indexes binder -1))))
+
+ (define (allocate! x level n)
+ (define (recur y) (allocate! y level n))
+ (record-case x
+ ((<application> proc args)
+ (apply max (recur proc) (map recur args)))
+
+ ((<conditional> test then else)
+ (max (recur test) (recur then) (recur else)))
+
+ ((<lexical-set> name gensym exp)
+ (recur exp))
+
+ ((<module-set> mod name public? exp)
+ (recur exp))
+
+ ((<toplevel-set> name exp)
+ (recur exp))
+
+ ((<toplevel-define> name exp)
+ (recur exp))
+
+ ((<sequence> exps)
+ (apply max (map recur exps)))
+
+ ((<lambda> vars meta body)
+ (let lp ((vars vars) (n 0))
+ (if (null? vars)
+ (hashq-set! allocation x
+ (let ((nlocs (- (allocate! body (1+ level) n) n)))
+ (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap (1+ level) (allocate-heap! binder))
+ (cons 'stack n))))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
+ n)
+
+ ((<let> vars vals exp)
+ (let ((nmax (apply max (map recur vals))))
+ (cond
+ ;; the `or' hack
+ ((and (conditional? exp)
+ (= (length vars) 1)
+ (let ((v (car vars)))
+ (and (not (hashq-ref heaps v))
+ (= (hashq-ref refcounts v 0) 2)
+ (lexical-ref? (conditional-test exp))
+ (eq? (lexical-ref-gensym (conditional-test exp)) v)
+ (lexical-ref? (conditional-then exp))
+ (eq? (lexical-ref-gensym (conditional-then exp)) v))))
+ (hashq-set! allocation (car vars) (cons 'stack n))
+ ;; the 1+ for this var
+ (max nmax (1+ n) (allocate! (conditional-else exp) level n)))
+ (else
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! exp level n))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n)))))))))))
+
+ ((<letrec> vars vals exp)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x level n))
+ vals))))
+ (max nmax (allocate! exp level n)))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n))))))))
+
+ (else n)))
+
+ (define parents (make-hash-table))
+ (define bindings (make-hash-table))
+ (define heaps (make-hash-table))
+ (define refcounts (make-hash-table))
+ (define allocation (make-hash-table))
+ (define heap-indexes (make-hash-table))
+
+ (analyze! x #f -1)
+ (allocate! x -1 0)
+
+ allocation)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 000000000..94ace7e53
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,448 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (ice-9 receive)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il optimize)
+ #:use-module (language tree-il analyze)
+ #:export (compile-glil))
+
+;;; TODO:
+;;
+;; call-with-values -> mv-bind
+;; basic degenerate-case reduction
+
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define *comp-module* (make-fluid))
+
+(define (compile-glil x e opts)
+ (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (x (optimize! x e opts))
+ (allocation (analyze-lexicals x)))
+ (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (lambda ()
+ (values (flatten-lambda x -1 allocation)
+ (and e (cons (car e) (cddr e)))
+ e)))))
+
+
+
+(define *primcall-ops* (make-hash-table))
+(for-each
+ (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
+ '(((eq? . 2) . eq?)
+ ((eqv? . 2) . eqv?)
+ ((equal? . 2) . equal?)
+ ((= . 2) . ee?)
+ ((< . 2) . lt?)
+ ((> . 2) . gt?)
+ ((<= . 2) . le?)
+ ((>= . 2) . ge?)
+ ((+ . 2) . add)
+ ((- . 2) . sub)
+ ((* . 2) . mul)
+ ((/ . 2) . div)
+ ((quotient . 2) . quo)
+ ((remainder . 2) . rem)
+ ((modulo . 2) . mod)
+ ((not . 1) . not)
+ ((pair? . 1) . pair?)
+ ((cons . 2) . cons)
+ ((car . 1) . car)
+ ((cdr . 1) . cdr)
+ ((set-car! . 2) . set-car!)
+ ((set-cdr! . 2) . set-cdr!)
+ ((null? . 1) . null?)
+ ((list? . 1) . list?)
+ (list . list)
+ (vector . vector)
+ ((@slot-ref . 2) . slot-ref)
+ ((@slot-set! . 3) . slot-set)))
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation)
+ (map (lambda (id v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack) (list id 'local (cdr loc)))
+ ((heap) (list id 'external (cddr loc)))
+ (else (error "badness" id v loc)))))
+ ids
+ vars))
+
+(define (emit-bindings src ids vars allocation emit-code)
+ (if (pair? vars)
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation)))))
+
+(define (with-output-to-code proc)
+ (let ((out '()))
+ (define (emit-code src x)
+ (set! out (cons x out))
+ (if src
+ (set! out (cons (make-glil-source src) out))))
+ (proc emit-code)
+ (reverse out)))
+
+(define (flatten-lambda x level allocation)
+ (receive (ids vars nargs nrest)
+ (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
+ (oids '()) (ovars '()) (n 0))
+ (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
+ ((pair? vars) (lp (cdr ids) (cdr vars)
+ (cons (car ids) oids) (cons (car vars) ovars)
+ (1+ n)))
+ (else (values (reverse (cons ids oids))
+ (reverse (cons vars ovars))
+ (1+ n) 1))))
+ (let ((nlocs (car (hashq-ref allocation x)))
+ (nexts (cdr (hashq-ref allocation x))))
+ (make-glil-program
+ nargs nrest nlocs nexts (lambda-meta x)
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write bindings and source debugging info
+ (emit-bindings #f ids vars allocation emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+
+ ;; copy args to the heap if necessary
+ (let lp ((in vars) (n 0))
+ (if (not (null? in))
+ (let ((loc (hashq-ref allocation (car in))))
+ (case (car loc)
+ ((heap)
+ (emit-code #f (make-glil-local 'ref n))
+ (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
+ (lp (cdr in) (1+ n)))))
+
+ ;; and here, here, dear reader: we compile.
+ (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+
+(define (flatten x level allocation emit-code)
+ (define (emit-label label)
+ (emit-code #f (make-glil-label label)))
+ (define (emit-branch src inst label)
+ (emit-code src (make-glil-branch inst label)))
+
+ (let comp ((x x) (context 'tail))
+ (define (comp-tail tree) (comp tree context))
+ (define (comp-push tree) (comp tree 'push))
+ (define (comp-drop tree) (comp tree 'drop))
+
+ (record-case x
+ ((<void>)
+ (case context
+ ((push) (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<const> src exp)
+ (case context
+ ((push) (emit-code src (make-glil-const exp)))
+ ((tail)
+ (emit-code src (make-glil-const exp))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ;; FIXME: should represent sequence as exps tail
+ ((<sequence> src exps)
+ (let lp ((exps exps))
+ (if (null? (cdr exps))
+ (comp-tail (car exps))
+ (begin
+ (comp-drop (car exps))
+ (lp (cdr exps))))))
+
+ ((<application> src proc args)
+ ;; FIXME: need a better pattern-matcher here
+ (cond
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@apply)
+ (>= (length args) 1))
+ (let ((proc (car args))
+ (args (cdr args)))
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
+ ((push)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args)))))
+ ((drop)
+ ;; Well, shit. The proc might return any number of
+ ;; values (including 0), since it's in a drop context,
+ ;; yet apply does not create a MV continuation. So we
+ ;; mv-call out to our trampoline instead.
+ (comp-drop
+ (make-application src (make-primitive-ref #f 'apply)
+ (cons proc args)))))))))
+
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values (length args))))))
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2))
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (let ((MV (make-label)) (POST (make-label))
+ (producer (car args)) (consumer (cadr args)))
+ (comp-push consumer)
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))))))
+
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-current-continuation)
+ (= (length args) 1))
+ (case context
+ ((tail)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'goto/cc 1)))
+ ((push)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'call/cc 1)))
+ ((drop)
+ ;; Crap. Just like `apply' in drop context.
+ (comp-drop
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args)))))
+
+ ((and (primitive-ref? proc)
+ (or (hash-ref *primcall-ops*
+ (cons (primitive-ref-name proc) (length args)))
+ (hash-ref *primcall-ops* (primitive-ref-name proc))))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case context
+ ((tail) (emit-code #f (make-glil-call 'return 1)))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))))
+ (else
+ (comp-push proc)
+ (for-each comp-push args)
+ (let ((len (length args)))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args len)))
+ ((push) (emit-code src (make-glil-call 'call len)))
+ ((drop)
+ (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br POST)
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST))))))))
+
+ ((<conditional> src test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)
+ (comp-tail then)
+ (if (not (eq? context 'tail))
+ (emit-branch #f 'br L2))
+ (emit-label L1)
+ (comp-tail else)
+ (if (not (eq? context 'tail))
+ (emit-label L2))))
+
+ ((<primitive-ref> src name)
+ (cond
+ ((eq? (module-variable (fluid-ref *comp-module*) name)
+ (module-variable the-root-module name))
+ (case context
+ ((push)
+ (emit-code src (make-glil-toplevel 'ref name)))
+ ((tail)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (emit-code #f (make-glil-call 'return 1)))))
+ (else
+ (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
+ (case context
+ ((push)
+ (emit-code src (make-glil-module 'ref '(guile) name #f)))
+ ((tail)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-ref> src name gensym)
+ (case context
+ ((push tail)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'ref (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'ref (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc)))
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-set> src name gensym exp)
+ (comp-push exp)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'set (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc))))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-ref> src mod name public?)
+ (emit-code src (make-glil-module 'ref mod name public?))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-set> src mod name public? exp)
+ (comp-push exp)
+ (emit-code src (make-glil-module 'set mod name public?))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-ref> src name)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-set> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'set name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'define name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<lambda>)
+ (case context
+ ((push)
+ (emit-code #f (flatten-lambda x level allocation)))
+ ((tail)
+ (emit-code #f (flatten-lambda x level allocation))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<let> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<letrec> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind))))))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
new file mode 100644
index 000000000..3a02e021e
--- /dev/null
+++ b/module/language/tree-il/optimize.scm
@@ -0,0 +1,42 @@
+;;; 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 (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (optimize!))
+
+(define (env-module e)
+ (if e (car e) (current-module)))
+
+(define (optimize! x env opts)
+ (expand-primitives! (resolve-primitives! x (env-module env))))
+
+;; 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"
+
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
new file mode 100644
index 000000000..51bbfeae9
--- /dev/null
+++ b/module/language/tree-il/primitives.scm
@@ -0,0 +1,206 @@
+;;; GHIL macros
+
+;; 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 tree-il primitives)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-16)
+ #:export (resolve-primitives! add-interesting-primitive!
+ expand-primitives!))
+
+(define *interesting-primitive-names*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+
+ list vector
+
+ 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 (add-interesting-primitive! name)
+ (hashq-set! *interesting-primitive-vars*
+ (module-variable (current-module) name) name))
+
+(define *interesting-primitive-vars* (make-hash-table))
+
+(for-each add-interesting-primitive! *interesting-primitive-names*)
+
+(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> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (let ((m (and (not public?) (resolve-module mod))))
+ (and m (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (make-primitive-ref src name))))
+ (else #f)))
+ x))
+
+
+
+(define *primitive-expand-table* (make-hash-table))
+
+(define (expand-primitives! x)
+ (pre-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (and (primitive-ref? proc)
+ (let ((expand (hashq-ref *primitive-expand-table*
+ (primitive-ref-name proc))))
+ (and expand (apply expand src args)))))
+ (else #f)))
+ x))
+
+;;; I actually did spend about 10 minutes trying to redo this with
+;;; syntax-rules. Patches appreciated.
+;;;
+(define-macro (define-primitive-expander sym . clauses)
+ (define (inline-args args)
+ (let lp ((in args) (out '()))
+ (cond ((null? in) `(list ,@(reverse out)))
+ ((symbol? in) `(cons* ,@(reverse out) ,in))
+ ((pair? (car in))
+ (lp (cdr in)
+ (cons `(make-application src (make-primitive-ref src ',(caar in))
+ ,(inline-args (cdar in)))
+ out)))
+ ((symbol? (car in))
+ ;; assume it's locally bound
+ (lp (cdr in) (cons (car in) out)))
+ ((number? (car in))
+ (lp (cdr in) (cons `(make-const src ,(car in)) out)))
+ (else
+ (error "what what" (car in))))))
+ (define (consequent exp)
+ (cond
+ ((pair? exp)
+ `(make-application src (make-primitive-ref src ',(car exp))
+ ,(inline-args (cdr exp))))
+ ((symbol? exp)
+ ;; assume locally bound
+ exp)
+ ((number? exp)
+ `(make-const src ,exp))
+ (else (error "bad consequent yall" exp))))
+ `(hashq-set! *primitive-expand-table*
+ ',sym
+ (case-lambda
+ ,@(let lp ((in clauses) (out '()))
+ (if (null? in)
+ (reverse (cons '(else #f) out))
+ (lp (cddr in)
+ (cons `((src . ,(car in))
+ ,(consequent (cadr in))) out)))))))
+
+(define-primitive-expander +
+ () 0
+ (x) x
+ (x y z . rest) (+ x (+ y z . rest)))
+
+(define-primitive-expander *
+ () 1
+ (x) x
+ (x y z . rest) (* x (* y z . rest)))
+
+(define-primitive-expander -
+ (x) (- 0 x)
+ (x y z . rest) (- x (+ y z . rest)))
+
+(define-primitive-expander 1-
+ (x) (- x 1))
+
+(define-primitive-expander /
+ (x) (/ 1 x)
+ (x y z . rest) (/ x (* y z . rest)))
+
+(define-primitive-expander caar (x) (car (car x)))
+(define-primitive-expander cadr (x) (car (cdr x)))
+(define-primitive-expander cdar (x) (cdr (car x)))
+(define-primitive-expander cddr (x) (cdr (cdr x)))
+(define-primitive-expander caaar (x) (car (car (car x))))
+(define-primitive-expander caadr (x) (car (car (cdr x))))
+(define-primitive-expander cadar (x) (car (cdr (car x))))
+(define-primitive-expander caddr (x) (car (cdr (cdr x))))
+(define-primitive-expander cdaar (x) (cdr (car (car x))))
+(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
+(define-primitive-expander cddar (x) (cdr (cdr (car x))))
+(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
+(define-primitive-expander caaaar (x) (car (car (car (car x)))))
+(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
+(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
+(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
+(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
+(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
+(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
+(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
+(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
+(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
+(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
+(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-primitive-expander cons*
+ (x) x
+ (x y) (cons x y)
+ (x y . rest) (cons x (cons* y . rest)))
+
+(define-primitive-expander acons (x y z)
+ (cons (cons x y) z))
+
+(define-primitive-expander apply (f . args)
+ (@apply f . args))
+
+(define-primitive-expander call-with-values (producer consumer)
+ (@call-with-values producer consumer))
+
+(define-primitive-expander call-with-current-continuation (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander call/cc (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander values (x) x)
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
new file mode 100644
index 000000000..c1f098230
--- /dev/null
+++ b/module/language/tree-il/spec.scm
@@ -0,0 +1,43 @@
+;;; Tree Intermediate Language
+
+;; 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 spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il compile-glil)
+ #:export (tree-il))
+
+(define (write-tree-il exp . port)
+ (apply write (unparse-tree-il exp) port))
+
+(define (join exps env)
+ (make-sequence #f exps))
+
+(define-language tree-il
+ #:title "Tree Intermediate Language"
+ #:version "1.0"
+ #:reader read
+ #:printer write-tree-il
+ #:parser parse-tree-il
+ #:joiner join
+ #:compilers `((glil . ,compile-glil))
+ )