diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il.scm | 248 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 591 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 52 |
4 files changed, 893 insertions, 2 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 163b4b72d..3d5b0159b 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,7 +27,7 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) - #:use-module (ice-9 expand-support) + #:use-module (language tree-il) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) @@ -70,7 +70,7 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (strip-expansion-structures + (let ((x (tree-il->scheme (sc-expand x 'c '(compile load eval))))) (let ((x (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm new file mode 100644 index 000000000..fa655d815 --- /dev/null +++ b/module/language/tree-il.scm @@ -0,0 +1,248 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (language tree-il) + #:use-module (system base pmatch) + #:use-module (system base syntax) + :export (tree-il-loc + + <lexical> make-lexical + lexical-name lexical-gensym + + <application> make-application application-loc application-proc application-args + <conditional> make-conditional conditional-loc conditional-test conditional-then conditional-else + <primitive-ref> make-primitive-ref primitive-ref-loc primitive-ref-name + <lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym + <lexical-set> make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp + <module-ref> make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public? + <module-set> make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp + <toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name + <toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp + <toplevel-define> make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp + <lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body + <const> make-const const-loc const-exp + <sequence> make-sequence sequence-loc sequence-exps + <let> make-let let-loc let-vars let-vals let-exp + <letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp + + parse-tree-il + unparse-tree-il + tree-il->scheme)) + +(define-type (<tree-il> #:common-slots (src)) + (<application> proc args) + (<conditional> test then else) + (<primitive-ref> name) + (<lexical-ref> name gensym) + (<lexical-set> name gensym exp) + (<module-ref> mod name public?) + (<module-set> mod name public? exp) + (<toplevel-ref> name) + (<toplevel-set> name exp) + (<toplevel-define> name exp) + (<lambda> vars meta body) + (<const> exp) + (<sequence> exps) + (<let> vars vals exp) + (<letrec> vars vals exp)) + +(define <lexical> <lexical-ref>) +(define lexical? lexical-ref?) +(define make-lexical make-lexical-ref) +(define lexical-name lexical-ref-name) +(define lexical-gensym lexical-ref-gensym) + + + +;; FIXME: use this in psyntax +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + (vector (assq-ref props 'line) + (assq-ref props 'column) + (assq-ref props 'filename)))))) + +(define (parse-tree-il env exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-ghil env x)))) + (pmatch exp + ((apply ,proc ,args) + (make-application loc (retrans proc) (retrans args))) + + ((if ,test ,then ,else) + (make-conditional loc (retrans test) (retrans then) (retrans else))) + + ((primitive ,name) (guard (symbol? name)) + (make-primitive-ref loc name)) + + ((lexical ,name) (guard (symbol? name)) + (make-lexical-ref loc name name)) + + ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) + (make-lexical-ref loc name sym)) + + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) + (make-lexical-set loc name sym (retrans exp))) + + ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #t)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #t (retrans exp))) + + ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #f)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #f (retrans exp))) + + ((toplevel ,name) (guard (symbol? name)) + (make-toplevel-ref loc name)) + + ((set! (toplevel ,name) exp) (guard (symbol? name)) + (make-toplevel-set loc name (retrans exp))) + + ((define ,name exp) (guard (symbol? name)) + (make-toplevel-define loc name (retrans exp))) + + ((lambda ,vars ,exp) + (make-lambda loc vars '() (retrans exp))) + + ((lambda ,vars ,meta ,exp) + (make-lambda loc vars meta (retrans exp))) + + ((const ,exp) + (make-const loc exp)) + + ((begin . ,exps) + (make-sequence loc (map retrans exps))) + + ((let ,vars ,vals ,exp) + (make-let loc vars vals (retrans exp))) + + ((letrec ,vars ,vals ,exp) + (make-letrec loc vars vals (retrans exp))) + + (else + (error "unrecognized tree-il" exp))))) + +(define (unparse-tree-il tree-il) + (record-case tree-il + ((<application> proc args) + `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args))) + + ((<conditional> test then else) + `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) + + ((<primitive-ref> name) + `(primitive ,name)) + + ((<lexical-ref> name gensym) + `(lexical ,name ,gensym)) + + ((<lexical-set> name gensym exp) + `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + + ((<module-ref> mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + ((<module-set> mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + + ((<toplevel-ref> name) + `(toplevel ,name)) + + ((<toplevel-set> name exp) + `(set! (toplevel ,name) ,(unparse-tree-il exp))) + + ((<toplevel-define> name exp) + `(define ,name ,(unparse-tree-il exp))) + + ((<lambda> vars meta body) + `(lambda ,vars ,meta ,(unparse-tree-il body))) + + ((<const> exp) + `(const ,exp)) + + ((<sequence> exps) + `(begin ,@(map unparse-tree-il exps))) + + ((<let> vars vals exp) + `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + + ((<letrec> vars vals exp) + `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + +(define (tree-il->scheme e) + (cond ((list? e) + (map tree-il->scheme e)) + ((pair? e) + (cons (tree-il->scheme (car e)) + (tree-il->scheme (cdr e)))) + ((record? e) + (record-case e + ((<application> proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + + ((<conditional> test then else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))) + + ((<primitive-ref> name) + name) + + ((<lexical-ref> name gensym) + gensym) + + ((<lexical-set> name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + ((<module-ref> mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + ((<module-set> mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + ((<toplevel-ref> name) + name) + + ((<toplevel-set> name exp) + `(set! ,name ,(tree-il->scheme exp))) + + ((<toplevel-define> name exp) + `(define ,name ,(tree-il->scheme exp))) + + ((<lambda> vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + ((<const> exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + ((<sequence> exps) + `(begin ,@(map tree-il->scheme exps))) + + ((<let> vars vals exp) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))) + + ((<letrec> vars vals exp) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) + (else e))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..3a0225577 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,591 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il compile-glil) + #:use-module (system base syntax) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (ice-9 common-list) + #:export (compile-glil)) + +(define (compile-glil x e opts) + (if (memq #:O opts) (set! x (optimize x))) + (values (codegen x) + (and e (cons (car e) (cddr e))) + e)) + + +;;; +;;; Stage 2: Optimization +;;; + +(define (lift-variables! env) + (let ((parent-env (ghil-env-parent env))) + (for-each (lambda (v) + (case (ghil-var-kind v) + ((argument) (set! (ghil-var-kind v) 'local))) + (set! (ghil-var-env v) parent-env) + (ghil-env-add! parent-env v)) + (ghil-env-variables env)))) + +;; The premise of this, unused, approach to optimization is that you can +;; determine the environment of a variable lexically, because they have +;; been alpha-renamed. It makes the transformations *much* easier. +;; Unfortunately it doesn't work yet. +(define (optimize* x) + (transform-record (<ghil> env loc) x + ((quasiquote exp) + (define (optimize-qq x) + (cond ((list? x) (map optimize-qq x)) + ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) + ((record? x) (optimize x)) + (else x))) + (-> (quasiquote (optimize-qq x)))) + + ((unquote exp) + (-> (unquote (optimize exp)))) + + ((unquote-splicing exp) + (-> (unquote-splicing (optimize exp)))) + + ((set var val) + (-> (set var (optimize val)))) + + ((define var val) + (-> (define var (optimize val)))) + + ((if test then else) + (-> (if (optimize test) (optimize then) (optimize else)))) + + ((and exps) + (-> (and (map optimize exps)))) + + ((or exps) + (-> (or (map optimize exps)))) + + ((begin exps) + (-> (begin (map optimize exps)))) + + ((bind vars vals body) + (-> (bind vars (map optimize vals) (optimize body)))) + + ((mv-bind producer vars rest body) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((inline inst args) + (-> (inline inst (map optimize args)))) + + ((call (proc (lambda vars (rest #f) meta body)) args) + (-> (bind vars (optimize args) (optimize body)))) + + ((call proc args) + (-> (call (optimize proc) (map optimize args)))) + + ((lambda vars rest meta body) + (-> (lambda vars rest meta (optimize body)))) + + ((mv-call producer (consumer (lambda vars rest meta body))) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((mv-call producer consumer) + (-> (mv-call (optimize producer) (optimize consumer)))) + + ((values values) + (-> (values (map optimize values)))) + + ((values* values) + (-> (values* (map optimize values)))) + + (else + (error "unrecognized GHIL" x)))) + +(define (optimize x) + (record-case x + ((<ghil-set> env loc var val) + (make-ghil-set env var (optimize val))) + + ((<ghil-define> env loc var val) + (make-ghil-define env var (optimize val))) + + ((<ghil-if> env loc test then else) + (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) + + ((<ghil-and> env loc exps) + (make-ghil-and env loc (map optimize exps))) + + ((<ghil-or> env loc exps) + (make-ghil-or env loc (map optimize exps))) + + ((<ghil-begin> env loc exps) + (make-ghil-begin env loc (map optimize exps))) + + ((<ghil-bind> env loc vars vals body) + (make-ghil-bind env loc vars (map optimize vals) (optimize body))) + + ((<ghil-lambda> env loc vars rest meta body) + (make-ghil-lambda env loc vars rest meta (optimize body))) + + ((<ghil-inline> env loc instruction args) + (make-ghil-inline env loc instruction (map optimize args))) + + ((<ghil-call> env loc proc args) + (let ((parent-env env)) + (record-case proc + ;; ((@lambda (VAR...) BODY...) ARG...) => + ;; (@let ((VAR ARG) ...) BODY...) + ((<ghil-lambda> env loc vars rest meta body) + (cond + ((not rest) + (lift-variables! env) + (make-ghil-bind parent-env loc (map optimize args))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) + + ((<ghil-mv-call> env loc producer consumer) + (record-case consumer + ;; (mv-call PRODUCER (lambda ARGS BODY...)) => + ;; (mv-let PRODUCER ARGS BODY...) + ((<ghil-lambda> env loc vars rest meta body) + (lift-variables! env) + (make-ghil-mv-bind producer vars rest body)) + (else + (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) + + (else x))) + + +;;; +;;; Stage 3: Code generation +;;; + +(define *ia-void* (make-glil-void)) +(define *ia-drop* (make-glil-call 'drop 1)) +(define *ia-return* (make-glil-call 'return 1)) + +(define (make-label) (gensym ":L")) + +(define (make-glil-var op env var) + (case (ghil-var-kind var) + ((argument) + (make-glil-argument op (ghil-var-index var))) + ((local) + (make-glil-local op (ghil-var-index var))) + ((external) + (do ((depth 0 (1+ depth)) + (e env (ghil-env-parent e))) + ((eq? e (ghil-var-env var)) + (make-glil-external op depth (ghil-var-index var))))) + ((toplevel) + (make-glil-toplevel op (ghil-var-name var))) + ((public private) + (make-glil-module op (ghil-var-env var) (ghil-var-name var) + (eq? (ghil-var-kind var) 'public))) + (else (error "Unknown kind of variable:" var)))) + +(define (constant? x) + (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) + ((pair? x) (and (constant? (car x)) + (constant? (cdr x)))) + ((vector? x) (let lp ((i (vector-length x))) + (or (zero? i) + (and (constant? (vector-ref x (1- i))) + (lp (1- i)))))))) + +(define (codegen ghil) + (let ((stack '())) + (define (push-code! loc code) + (set! stack (cons code stack)) + (if loc (set! stack (cons (make-glil-source loc) stack)))) + (define (var->binding var) + (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (define (push-bindings! loc vars) + (if (not (null? vars)) + (push-code! loc (make-glil-bind (map var->binding vars))))) + (define (comp tree tail drop) + (define (push-label! label) + (push-code! #f (make-glil-label label))) + (define (push-branch! loc inst label) + (push-code! loc (make-glil-branch inst label))) + (define (push-call! loc inst args) + (for-each comp-push args) + (push-code! loc (make-glil-call inst (length args)))) + ;; possible tail position + (define (comp-tail tree) (comp tree tail drop)) + ;; push the result + (define (comp-push tree) (comp tree #f #f)) + ;; drop the result + (define (comp-drop tree) (comp tree #f #t)) + ;; drop the result if unnecessary + (define (maybe-drop) + (if drop (push-code! #f *ia-drop*))) + ;; return here if necessary + (define (maybe-return) + (if tail (push-code! #f *ia-return*))) + ;; return this code if necessary + (define (return-code! loc code) + (if (not drop) (push-code! loc code)) + (maybe-return)) + ;; return void if necessary + (define (return-void!) + (return-code! #f *ia-void*)) + ;; return object if necessary + (define (return-object! loc obj) + (return-code! loc (make-glil-const obj))) + ;; + ;; dispatch + (record-case tree + ((<ghil-void>) + (return-void!)) + + ((<ghil-quote> env loc obj) + (return-object! loc obj)) + + ((<ghil-quasiquote> env loc exp) + (let loop ((x exp) (in-car? #f)) + (cond + ((list? x) + (push-call! #f 'mark '()) + (for-each (lambda (x) (loop x #t)) x) + (push-call! #f 'list-mark '())) + ((pair? x) + (push-call! #f 'mark '()) + (loop (car x) #t) + (loop (cdr x) #f) + (push-call! #f 'cons-mark '())) + ((record? x) + (record-case x + ((<ghil-unquote> env loc exp) + (comp-push exp)) + ((<ghil-unquote-splicing> env loc exp) + (if (not in-car?) + (error "unquote-splicing in the cdr of a pair" exp)) + (comp-push exp) + (push-call! #f 'list-break '())))) + ((constant? x) + (push-code! #f (make-glil-const x))) + (else + (error "element of quasiquote can't be compiled" x)))) + (maybe-drop) + (maybe-return)) + + ((<ghil-unquote> env loc exp) + (error "unquote outside of quasiquote" exp)) + + ((<ghil-unquote-splicing> env loc exp) + (error "unquote-splicing outside of quasiquote" exp)) + + ((<ghil-ref> env loc var) + (return-code! loc (make-glil-var 'ref env var))) + + ((<ghil-set> env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'set env var)) + (return-void!)) + + ((<ghil-define> env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'define env var)) + (return-void!)) + + ((<ghil-if> env loc test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (push-branch! loc 'br-if-not L1) + (comp-tail then) + (if (not tail) (push-branch! #f 'br L2)) + (push-label! L1) + (comp-tail else) + (if (not tail) (push-label! L2)))) + + ((<ghil-and> env loc exps) + ;; EXP + ;; (br-if-not L1) + ;; ... + ;; TAIL + ;; (br L2) + ;; L1: (const #f) + ;; L2: + (cond ((null? exps) (return-object! loc #t)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label)) (L2 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-branch! #f 'br L2) + (push-label! L1) + (return-object! #f #f) + (push-label! L2) + (maybe-return)) + (else + (comp-push (car exps)) + (push-branch! #f 'br-if-not L1) + (lp (cdr exps))))))))) + + ((<ghil-or> env loc exps) + ;; EXP + ;; (dup) + ;; (br-if L1) + ;; (drop) + ;; ... + ;; TAIL + ;; L1: + (cond ((null? exps) (return-object! loc #f)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-label! L1) + (maybe-return)) + (else + (comp-push (car exps)) + (if (not drop) + (push-call! #f 'dup '())) + (push-branch! #f 'br-if L1) + (if (not drop) + (push-code! loc (make-glil-call 'drop 1))) + (lp (cdr exps))))))))) + + ((<ghil-begin> env loc exps) + ;; EXPS... + ;; TAIL + (if (null? exps) + (return-void!) + (do ((exps exps (cdr exps))) + ((null? (cdr exps)) + (comp-tail (car exps))) + (comp-drop (car exps))))) + + ((<ghil-bind> env loc vars vals body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (for-each comp-push vals) + (push-bindings! loc vars) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars)) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + ((<ghil-mv-bind> env loc producer vars rest body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (let ((MV (make-label))) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! #f (make-glil-const 1)) + (push-label! MV) + (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars))) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + ((<ghil-lambda> env loc vars rest meta body) + (return-code! loc (codegen tree))) + + ((<ghil-inline> env loc inline args) + ;; ARGS... + ;; (INST NARGS) + (let ((tail-table '((call . goto/args) + (apply . goto/apply) + (call/cc . goto/cc)))) + (cond ((and tail (assq-ref tail-table inline)) + => (lambda (tail-inst) + (push-call! loc tail-inst args))) + (else + (push-call! loc inline args) + (maybe-drop) + (maybe-return))))) + + ((<ghil-values> env loc values) + (cond (tail ;; (lambda () (values 1 2)) + (push-call! loc 'return/values values)) + (drop ;; (lambda () (values 1 2) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (values 10 12) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'call values)))) + + ((<ghil-values*> env loc values) + (cond (tail ;; (lambda () (apply values '(1 2))) + (push-call! loc 'return/values* values)) + (drop ;; (lambda () (apply values '(1 2)) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (apply values '(10 12)) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'apply values)))) + + ((<ghil-call> env loc proc args) + ;; PROC + ;; ARGS... + ;; ([tail-]call NARGS) + (comp-push proc) + (let ((nargs (length args))) + (cond ((< nargs 255) + (push-call! loc (if tail 'goto/args 'call) args)) + (else + (push-call! loc 'mark '()) + (for-each comp-push args) + (push-call! loc 'list-mark '()) + (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2))))) + (maybe-drop)) + + ((<ghil-mv-call> env loc producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (maybe-drop))))) + + ((<ghil-reified-env> env loc) + (return-object! loc (ghil-env-reify env))))) + + ;; + ;; main + (record-case ghil + ((<ghil-lambda> env loc vars rest meta body) + (let* ((evars (ghil-env-variables env)) + (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) + (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) + (nargs (allocate-indices-linearly! vars)) + (nlocs (allocate-locals! locs body)) + (nexts (allocate-indices-linearly! exts))) + ;; meta bindings + (push-bindings! #f vars) + ;; push on definition source location + (if loc (set! stack (cons (make-glil-source loc) stack))) + ;; copy args to the heap if they're marked as external + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l)) + (let ((v (car l))) + (case (ghil-var-kind v) + ((external) + (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) + ;; compile body + (comp body #t #f) + ;; create GLIL + (make-glil-program nargs (if rest 1 0) nlocs nexts meta + (reverse! stack))))))) + +(define (allocate-indices-linearly! vars) + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l) n) + (let ((v (car l))) (set! (ghil-var-index v) n)))) + +(define (allocate-locals! vars body) + (let ((free '()) (nlocs 0)) + (define (allocate! var) + (cond + ((pair? free) + (set! (ghil-var-index var) (car free)) + (set! free (cdr free))) + (else + (set! (ghil-var-index var) nlocs) + (set! nlocs (1+ nlocs))))) + (define (deallocate! var) + (set! free (cons (ghil-var-index var) free))) + (let lp ((x body)) + (record-case x + ((<ghil-void>)) + ((<ghil-quote>)) + ((<ghil-quasiquote> exp) + (let qlp ((x exp)) + (cond ((list? x) (for-each qlp x)) + ((pair? x) (qlp (car x)) (qlp (cdr x))) + ((record? x) + (record-case x + ((<ghil-unquote> exp) (lp exp)) + ((<ghil-unquote-splicing> exp) (lp exp))))))) + ((<ghil-unquote> exp) + (lp exp)) + ((<ghil-unquote-splicing> exp) + (lp exp)) + ((<ghil-reified-env>)) + ((<ghil-set> val) + (lp val)) + ((<ghil-ref>)) + ((<ghil-define> val) + (lp val)) + ((<ghil-if> test then else) + (lp test) (lp then) (lp else)) + ((<ghil-and> exps) + (for-each lp exps)) + ((<ghil-or> exps) + (for-each lp exps)) + ((<ghil-begin> exps) + (for-each lp exps)) + ((<ghil-bind> vars vals body) + (for-each allocate! vars) + (for-each lp vals) + (lp body) + (for-each deallocate! vars)) + ((<ghil-mv-bind> vars producer body) + (lp producer) + (for-each allocate! vars) + (lp body) + (for-each deallocate! vars)) + ((<ghil-inline> args) + (for-each lp args)) + ((<ghil-call> proc args) + (lp proc) + (for-each lp args)) + ((<ghil-lambda>)) + ((<ghil-mv-call> producer consumer) + (lp producer) + (lp consumer)) + ((<ghil-values> values) + (for-each lp values)) + ((<ghil-values*> values) + (for-each lp values)))) + nlocs)) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..d69a4ec37 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,52 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (parse x) + (make-lambda #f '() '() (parse-tree-il x))) + +(define (join exps env) + (if (or-map (lambda (x) + (or (not (lambda? x)) + (not (null? (lambda-vars x))))) + exps) + (error "tree-il expressions to join must be thunks")) + + (make-lambda #f '() '() (make-sequence #f (map lambda-body exps)))) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) |