mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

new language: tree-il. psyntax generates it when run in compile mode.

Browse source 
* module/Makefile.am: Add tree-il sources.

* module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing
  tree-il in compile mode.

* module/ice-9/psyntax.scm: Switch from expand-support to tree-il for
  generating output in compile mode. Completely generate tree-il -- the
  output wasn't Scheme before, but now it's completely not Scheme.

* module/ice-9/psyntax-pp.scm: Regenerated.

* module/language/scheme/compile-ghil.scm: Strip structures using
  tree-il, not expand-support.

* module/language/tree-il.scm:
* module/language/tree-il/spec.scm
* module/language/tree-il/compile-glil.scm: New language. It will compile
  to GLIL, though it doesn't yet.
This commit is contained in:
Andy Wingo 2009-05-07 13:45:03 +02:00
parent 1aeb082b82
commit 811d10f5a2
8 changed files with 1024 additions and 111 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/Makefile.am
View file

@ -31,13 +31,15 @@ modpath =
# putting these core modules first.
SOURCES = \
ice-9/psyntax-pp.scm \
ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
\
language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
@ -67,6 +69,9 @@ SCHEME_LANG_SOURCES = \
language/scheme/compile-ghil.scm language/scheme/spec.scm \
language/scheme/inline.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/spec.scm language/tree-il/compile-glil.scm
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm

4
module/ice-9/compile-psyntax.scm
View file

@ -1,4 +1,4 @@
(use-modules (ice-9 expand-support))
(use-modules (language tree-il))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))
(let ((in (open-input-file source))
@ -12,7 +12,7 @@
(close-port out)
(close-port in))
(begin
(write (strip-expansion-structures
(write (tree-il->scheme
(sc-expand x 'c '(compile load eval)))
out)
(newline out)

22
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because one or more lines are too long

207
module/ice-9/psyntax.scm
View file

@ -304,7 +304,7 @@
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define local-eval-hook
@ -312,7 +312,7 @@
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define-syntax gensym-hook
@ -351,132 +351,150 @@
;;; output constructors
(define (build-annotated src exp)
(if (and src (not (annotation? exp)))
(make-annotation exp src #t)
exp))
(define build-application
(lambda (source fun-exp arg-exps)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
(else `(,fun-exp . ,arg-exps)))))
(define-syntax build-application
(syntax-rules ()
((_ source fun-exp arg-exps)
(build-annotated source `(,fun-exp . ,arg-exps)))))
(define-syntax build-conditional
(syntax-rules ()
((_ source test-exp then-exp else-exp)
(build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-conditional)
source test-exp then-exp else-exp))
(else `(if ,test-exp ,then-exp ,else-exp)))))
(define build-lexical-reference
(lambda (type source name var)
(build-annotated
source
(case (fluid-ref *mode*)
((c) ((@ (ice-9 expand-support) make-lexical) source name var))
(else var)))))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lexical-ref) source name var))
(else var))))
(define build-lexical-assignment
(lambda (source name var exp)
(build-annotated
source
`(set! ,(build-lexical-reference 'set no-source name var)
,exp))))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lexical-set) source name var exp))
(else `(set! ,var ,exp)))))
;; Before modules are booted, we can't expand into data structures from
;; (ice-9 expand-support) -- we need to give the evaluator the
;; (language tree-il) -- we need to give the evaluator the
;; s-expressions that it understands natively. Actually the real truth
;; of the matter is that the evaluator doesn't understand expand-support
;; structures at all. So until we fix the evaluator, if ever, the
;; conflation that we should use expand-support iff we are compiling
;; conflation that we should use tree-il iff we are compiling
;; holds true.
;;
(define (analyze-variable mod var modref-cont bare-cont)
(if (not mod)
(bare-cont var)
(let ((kind (car mod))
(mod (cdr mod)))
(case kind
((public) (modref-cont mod var #t))
((private) (if (not (equal? mod (module-name (current-module))))
(modref-cont mod var #f)
(bare-cont var)))
((bare) (bare-cont var))
((hygiene) (if (and (not (equal? mod (module-name (current-module))))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
(lambda (source var mod)
(build-annotated
source
(if (not mod)
var
(let ((make-module-ref
(case (fluid-ref *mode*)
((c) (@ (ice-9 expand-support) make-module-ref))
(else (lambda (source mod var public?)
(list (if public? '@ '@@) mod var)))))
(kind (car mod))
(mod (cdr mod)))
(case kind
((public) (make-module-ref #f mod var #t))
((private) (if (not (equal? mod (module-name (current-module))))
(make-module-ref #f mod var #f)
var))
((bare) var)
((hygiene) (if (and (not (equal? mod (module-name (current-module))))
(module-variable (resolve-module mod) var))
(make-module-ref #f mod var #f)
var))
(else (syntax-violation #f "bad module kind" var mod))))))))
(analyze-variable
mod var
(lambda (mod var public?)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-module-ref) source mod var public?))
(else (list (if public? '@ '@@) mod var))))
(lambda (var)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-ref) source var))
(else var))))))
(define build-global-assignment
(lambda (source var exp mod)
(let ((ref (build-global-reference source var mod)))
(build-annotated
source
`(set! ,ref ,exp)))))
(analyze-variable
mod var
(lambda (mod var public?)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
(else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
(lambda (var)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-set) source var exp))
(else `(set! ,var ,exp)))))))
(define-syntax build-global-definition
(syntax-rules ()
((_ source var exp)
(build-annotated source `(define ,var ,exp)))))
(define build-global-definition
(lambda (source var exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-define) source var exp))
(else `(define ,var ,exp)))))
(define-syntax build-lambda
(syntax-rules ()
((_ src vars docstring exp)
(build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
,exp)))
((_ src vars exp)
(build-annotated src `(lambda ,vars ,exp)))))
(define build-lambda
(lambda (src vars docstring exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lambda) src vars
(if docstring `((documentation . ,docstring)) '())
exp))
(else `(lambda ,vars ,@(if docstring (list docstring) '())
,exp)))))
;; FIXME: wingo: add modules here somehow?
(define-syntax build-primref
(syntax-rules ()
((_ src name) (build-annotated src name))
((_ src level name) (build-annotated src name))))
(define build-primref
(lambda (src name)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-primitive-ref) src name))
;; hygiene guile is a hack
(else (build-global-reference src name '(hygiene guile))))))
(define (build-data src exp)
(if (and (self-evaluating? exp)
(not (vector? exp)))
(build-annotated src exp)
(build-annotated src (list 'quote exp))))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-const) src exp))
(else (if (and (self-evaluating? exp) (not (vector? exp)))
exp
(list 'quote exp)))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
(build-annotated src (car exps))
(build-annotated src `(begin ,@exps)))))
(car exps)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-sequence) src exps))
(else `(begin ,@exps))))))
(define build-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
(build-annotated src body-exp)
(build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
body-exp
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-let) src vars val-exps body-exp))
(else `(let ,(map list vars val-exps) ,body-exp))))))
(define build-named-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
(build-annotated src body-exp)
(build-annotated src
`(let ,(car vars)
,(map list (cdr vars) val-exps) ,body-exp)))))
(let ((f (car vars))
(vars (cdr vars)))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-letrec) src
(list f) (list (build-lambda src vars #f body-exp))
(build-application src (build-lexical-reference 'fun src f f)
val-exps)))
(else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
(lambda (src vars val-exps body-exp)
(if (null? vars)
(build-annotated src body-exp)
(build-annotated src
`(letrec ,(map list vars val-exps) ,body-exp)))))
body-exp
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-letrec) src vars val-exps body-exp))
(else `(letrec ,(map list vars val-exps) ,body-exp))))))
;; FIXME: wingo: use make-lexical
;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var
(syntax-rules ()
((_ src id) (build-annotated src (gensym (symbol->string id))))))
((_ src id) (gensym (symbol->string id)))))
(define-structure (syntax-object expression wrap module))
@ -1729,13 +1747,12 @@
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((lambda) (build-lambda no-source (cadr x) #f (regen (caddr x))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
(if (fx= (length ls) 2)
(build-primref no-source 'map)
; really need to do our own checking here
(build-primref no-source 2 'map)) ; require error check
;; this check used to be here, not sure what for:
;; (if (fx= (length ls) 2)
(build-primref no-source 'map)
ls)))
(else (build-application no-source
(build-primref no-source (car x))
@ -1913,7 +1930,7 @@
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
(list (build-lambda no-source new-vars
(list (build-lambda no-source new-vars #f
(chi exp
(extend-env
labels
@ -1940,7 +1957,7 @@
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
(build-lambda no-source (list y)
(build-lambda no-source (list y) #f
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
@ -1974,7 +1991,7 @@
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
(build-lambda no-source (list var)
(build-lambda no-source (list var) #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
@ -2000,7 +2017,7 @@
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
(build-lambda no-source (list x)
(build-lambda no-source (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
(syntax (key ...)) (syntax (m ...))

4
module/language/scheme/compile-ghil.scm
View file

@ -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)))

248
module/language/tree-il.scm Normal file
View file

@ -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)))

591
module/language/tree-il/compile-glil.scm Normal file
View file

@ -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))

52
module/language/tree-il/spec.scm Normal file
View file

@ -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))
)