summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/scheme/compile-ghil.scm4
-rw-r--r--module/language/tree-il.scm248
-rw-r--r--module/language/tree-il/compile-glil.scm591
-rw-r--r--module/language/tree-il/spec.scm52
4 files changed, 893 insertions, 2 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 163b4b72d..3d5b0159b 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,7 +27,7 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module (ice-9 expand-support)
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
@@ -70,7 +70,7 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (strip-expansion-structures
+ (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)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
new file mode 100644
index 000000000..fa655d815
--- /dev/null
+++ b/module/language/tree-il.scm
@@ -0,0 +1,248 @@
+;;;; 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-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))
+
+(define-type (<tree-il> #:common-slots (src))
+ (<application> proc args)
+ (<conditional> test then else)
+ (<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)
+ (<lambda> vars meta body)
+ (<const> exp)
+ (<sequence> exps)
+ (<let> vars vals exp)
+ (<letrec> vars vals exp))
+
+(define <lexical> <lexical-ref>)
+(define lexical? lexical-ref?)
+(define make-lexical make-lexical-ref)
+(define lexical-name lexical-ref-name)
+(define lexical-gensym lexical-ref-gensym)
+
+
+
+;; FIXME: use this in psyntax
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
+
+(define (parse-tree-il env exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-ghil env x))))
+ (pmatch exp
+ ((apply ,proc ,args)
+ (make-application loc (retrans proc) (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 ,vars ,exp)
+ (make-lambda loc vars '() (retrans exp)))
+
+ ((lambda ,vars ,meta ,exp)
+ (make-lambda loc vars meta (retrans exp)))
+
+ ((const ,exp)
+ (make-const loc exp))
+
+ ((begin . ,exps)
+ (make-sequence loc (map retrans exps)))
+
+ ((let ,vars ,vals ,exp)
+ (make-let loc vars vals (retrans exp)))
+
+ ((letrec ,vars ,vals ,exp)
+ (make-letrec loc vars vals (retrans exp)))
+
+ (else
+ (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+ (record-case tree-il
+ ((<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> vars meta body)
+ `(lambda ,vars ,meta ,(unparse-tree-il body)))
+
+ ((<const> exp)
+ `(const ,exp))
+
+ ((<sequence> exps)
+ `(begin ,@(map unparse-tree-il exps)))
+
+ ((<let> vars vals exp)
+ `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,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
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ `(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)))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 000000000..3a0225577
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,591 @@
+;;; TREE-IL -> GLIL compiler
+
+;; 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 compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 common-list)
+ #: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))
+(define *ia-return* (make-glil-call 'return 1))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+ (case (ghil-var-kind var)
+ ((argument)
+ (make-glil-argument op (ghil-var-index var)))
+ ((local)
+ (make-glil-local op (ghil-var-index var)))
+ ((external)
+ (do ((depth 0 (1+ depth))
+ (e env (ghil-env-parent e)))
+ ((eq? e (ghil-var-env var))
+ (make-glil-external op depth (ghil-var-index var)))))
+ ((toplevel)
+ (make-glil-toplevel op (ghil-var-name var)))
+ ((public private)
+ (make-glil-module op (ghil-var-env var) (ghil-var-name var)
+ (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)
+ (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)))
+ (define (push-bindings! loc vars)
+ (if (not (null? vars))
+ (push-code! loc (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)
+ (for-each comp-push args)
+ (push-code! loc (make-glil-call inst (length args))))
+ ;; possible tail position
+ (define (comp-tail tree) (comp tree tail drop))
+ ;; push the result
+ (define (comp-push tree) (comp tree #f #f))
+ ;; drop the result
+ (define (comp-drop tree) (comp tree #f #t))
+ ;; drop the result if unnecessary
+ (define (maybe-drop)
+ (if drop (push-code! #f *ia-drop*)))
+ ;; return here if necessary
+ (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))
+ (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)))
+ ;;
+ ;; 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-unquote> env loc exp)
+ (error "unquote outside of quasiquote" exp))
+
+ ((<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)
+ (comp-push val)
+ (push-code! loc (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))
+ (return-void!))
+
+ ((<ghil-if> env loc test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (push-branch! loc '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)
+ ;; EXPS...
+ ;; TAIL
+ (if (null? exps)
+ (return-void!)
+ (do ((exps exps (cdr exps)))
+ ((null? (cdr exps))
+ (comp-tail (car exps)))
+ (comp-drop (car exps)))))
+
+ ((<ghil-bind> env loc vars vals body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (for-each comp-push vals)
+ (push-bindings! loc 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)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (let ((MV (make-label)))
+ (comp-push producer)
+ (push-code! loc (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))
+ (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-lambda> env loc vars rest meta body)
+ (return-code! loc (codegen tree)))
+
+ ((<ghil-inline> env loc inline args)
+ ;; ARGS...
+ ;; (INST NARGS)
+ (let ((tail-table '((call . goto/args)
+ (apply . goto/apply)
+ (call/cc . goto/cc))))
+ (cond ((and tail (assq-ref tail-table inline))
+ => (lambda (tail-inst)
+ (push-call! loc tail-inst args)))
+ (else
+ (push-call! loc inline args)
+ (maybe-drop)
+ (maybe-return)))))
+
+ ((<ghil-values> env loc values)
+ (cond (tail ;; (lambda () (values 1 2))
+ (push-call! loc '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))))
+
+ ((<ghil-values*> env loc values)
+ (cond (tail ;; (lambda () (apply values '(1 2)))
+ (push-call! loc '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))))
+
+ ((<ghil-call> env loc 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))
+ (else
+ (push-call! loc 'mark '())
+ (for-each comp-push args)
+ (push-call! loc 'list-mark '())
+ (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
+ (maybe-drop))
+
+ ((<ghil-mv-call> env loc producer consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (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))
+ (cond ((not tail)
+ (push-branch! #f 'br POST)))
+ (push-label! MV)
+ (push-code! loc (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)))))
+
+ ;;
+ ;; main
+ (record-case ghil
+ ((<ghil-lambda> env loc vars rest meta body)
+ (let* ((evars (ghil-env-variables env))
+ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+ (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
+ (nargs (allocate-indices-linearly! vars))
+ (nlocs (allocate-locals! locs body))
+ (nexts (allocate-indices-linearly! exts)))
+ ;; meta bindings
+ (push-bindings! #f vars)
+ ;; push on definition source location
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
+ ;; copy args to the heap if they're marked as external
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l))
+ (let ((v (car l)))
+ (case (ghil-var-kind v)
+ ((external)
+ (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+ (reverse! stack)))))))
+
+(define (allocate-indices-linearly! vars)
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l) n)
+ (let ((v (car l))) (set! (ghil-var-index v) n))))
+
+(define (allocate-locals! vars body)
+ (let ((free '()) (nlocs 0))
+ (define (allocate! var)
+ (cond
+ ((pair? free)
+ (set! (ghil-var-index var) (car free))
+ (set! free (cdr free)))
+ (else
+ (set! (ghil-var-index var) nlocs)
+ (set! nlocs (1+ nlocs)))))
+ (define (deallocate! var)
+ (set! free (cons (ghil-var-index var) free)))
+ (let lp ((x body))
+ (record-case x
+ ((<ghil-void>))
+ ((<ghil-quote>))
+ ((<ghil-quasiquote> exp)
+ (let qlp ((x exp))
+ (cond ((list? x) (for-each qlp x))
+ ((pair? x) (qlp (car x)) (qlp (cdr x)))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> exp) (lp exp))
+ ((<ghil-unquote-splicing> exp) (lp exp)))))))
+ ((<ghil-unquote> exp)
+ (lp exp))
+ ((<ghil-unquote-splicing> exp)
+ (lp exp))
+ ((<ghil-reified-env>))
+ ((<ghil-set> val)
+ (lp val))
+ ((<ghil-ref>))
+ ((<ghil-define> val)
+ (lp val))
+ ((<ghil-if> test then else)
+ (lp test) (lp then) (lp else))
+ ((<ghil-and> exps)
+ (for-each lp exps))
+ ((<ghil-or> exps)
+ (for-each lp exps))
+ ((<ghil-begin> exps)
+ (for-each lp exps))
+ ((<ghil-bind> vars vals body)
+ (for-each allocate! vars)
+ (for-each lp vals)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-mv-bind> vars producer body)
+ (lp producer)
+ (for-each allocate! vars)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-inline> args)
+ (for-each lp args))
+ ((<ghil-call> proc args)
+ (lp proc)
+ (for-each lp args))
+ ((<ghil-lambda>))
+ ((<ghil-mv-call> producer consumer)
+ (lp producer)
+ (lp consumer))
+ ((<ghil-values> values)
+ (for-each lp values))
+ ((<ghil-values*> values)
+ (for-each lp values))))
+ nlocs))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
new file mode 100644
index 000000000..d69a4ec37
--- /dev/null
+++ b/module/language/tree-il/spec.scm
@@ -0,0 +1,52 @@
+;;; 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 (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))))
+
+(define-language tree-il
+ #:title "Tree Intermediate Language"
+ #:version "1.0"
+ #:reader read
+ #:printer write-tree-il
+ #:parser parse
+ #:joiner join
+ #:compilers `((glil . ,compile-glil))
+ )