diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/assembly/disassemble.scm | 2 | ||||
-rw-r--r-- | module/language/ecmascript/spec.scm | 1 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 14 | ||||
-rw-r--r-- | module/language/glil.scm | 9 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 31 | ||||
-rw-r--r-- | module/language/glil/decompile-assembly.scm | 8 | ||||
-rw-r--r-- | module/language/scheme/amatch.scm | 37 | ||||
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 48 | ||||
-rw-r--r-- | module/language/scheme/compile-tree-il.scm | 64 | ||||
-rw-r--r-- | module/language/scheme/decompile-tree-il.scm | 27 | ||||
-rw-r--r-- | module/language/scheme/expand.scm | 307 | ||||
-rw-r--r-- | module/language/scheme/spec.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il.scm | 359 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 235 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 448 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 42 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 206 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 43 |
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)) + ) |