diff options
author | Andy Wingo <wingo@pobox.com> | 2009-05-15 23:44:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-05-15 23:44:14 +0200 |
commit | cf10678fe7014a67020c45ee02f2aabb44598adc (patch) | |
tree | 0051e1969fd774e50b6eea3b28a66eed3ce21c1c /module | |
parent | 073bb617eb7e5f76269ca6dba0fe498baff6f058 (diff) | |
download | guile-cf10678fe7014a67020c45ee02f2aabb44598adc.tar.gz |
tree-il -> glil compiler works now, at least in initial tests
* module/language/tree-il/analyze.scm: Break analyzer out into its own
file.
* module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler
over to work on tree-il. Works, but still misses a number of important
optimizations.
* module/language/tree-il.scm: Add <void>. Not used quite yet.
* module/language/glil.scm: Remove <glil-argument>, as it is the same as
<glil-local> (minus an offset).
* module/language/glil/compile-assembly.scm:
* module/language/glil/decompile-assembly.scm:
* module/language/ghil/compile-glil.scm: Adapt for <glil-argument>
* removal.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add
analyze.scm.
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 7 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 14 | ||||
-rw-r--r-- | module/language/glil.scm | 7 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 24 | ||||
-rw-r--r-- | module/language/glil/decompile-assembly.scm | 8 | ||||
-rw-r--r-- | module/language/tree-il.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 201 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 714 |
8 files changed, 464 insertions, 525 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 36d670002..22a95626d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -72,10 +72,11 @@ SCHEME_LANG_SOURCES = \ language/scheme/inline.scm TREE_IL_LANG_SOURCES = \ - language/tree-il/spec.scm \ - language/tree-il/compile-glil.scm \ language/tree-il/inline.scm \ - language/tree-il/optimize.scm + language/tree-il/optimize.scm \ + language/tree-il/analyze.scm \ + language/tree-il/compile-glil.scm \ + language/tree-il/spec.scm GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm 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 51e7efac4..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,7 +121,6 @@ ((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)) @@ -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..73b2cd132 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) 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/tree-il.scm b/module/language/tree-il.scm index 774ca2ca7..c9857ac14 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -24,6 +24,7 @@ <lexical> make-lexical lexical-name lexical-gensym + <void> void? make-void void-src <application> application? make-application application-src application-proc application-args <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name @@ -48,6 +49,7 @@ pre-order!)) (define-type (<tree-il> #:common-slots (src)) + (<void>) (<application> proc args) (<conditional> test then else) (<primitive-ref> name) @@ -85,6 +87,9 @@ (let ((loc (location exp)) (retrans (lambda (x) (parse-ghil env x)))) (pmatch exp + ((void) + (make-void loc)) + ((apply ,proc ,args) (make-application loc (retrans proc) (retrans args))) @@ -147,6 +152,9 @@ (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))) @@ -200,6 +208,9 @@ (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))) @@ -253,6 +264,9 @@ (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)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..fdcd190b4 --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,201 @@ +;;; 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. +;; +;; 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 + + (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) + (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))) + (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)))) + (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) (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) (1+ n)))))) + + (else n))) + + (define parents (make-hash-table)) + (define bindings (make-hash-table)) + (define heaps (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 index f54da31f0..2b2410051 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -21,287 +21,123 @@ (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 (ice-9 common-list) + #:use-module (language tree-il analyze) #:export (compile-glil)) -;; 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 - -;; 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. - ;; allocation: ;; sym -> (local . index) | (heap level . index) - - -(define (analyze-lexicals x) - (define (find-diff parent this) - (let lp ((parent parent) (n 0)) - (if (eq? parent this) - n - (lp (hashq-ref parents parent) (1+ n))))) - - (define (find-heap sym parent) - ;; fixme: check displaced lexicals here? - (if (memq sym (hashq-ref bindings parent)) - parent - (find-binder 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) - (if (and (not (memq gensym (hashq-ref bindings parent))) - (not (hashq-ref heaps gensym))) - (hashq-set! heaps gensym (find-heap gensym parent level)))) - - ((<lexical-set> name gensym exp) - (step exp) - (if (not (hashq-ref heaps gensym)) - (hashq-set! heaps gensym (find-heap gensym parent level)))) - - ((<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 (step y) (allocate! y level n)) - (record-case x - ((<application> proc args) - (step proc) (for-each step args)) - - ((<conditional> test then else) - (step test) (step then) (step else)) - - ((<lexical-set> name gensym exp) - (step exp)) - - ((<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) - (let lp ((vars vars) (n 0)) - (if (null? vars) - (allocate! body (1+ level) n) - (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)))))) - - ((<let> vars vals exp) - (for-each step vals) - (let lp ((vars vars) (n n)) - (if (null? vars) - (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) (1+ n)))))) - - ((<letrec> vars vals exp) - (let lp ((vars vars) (n n)) - (if (null? vars) - (begin - (for-each (lambda (x) (allocate! x level n)) - vals) - (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) (1+ n)))))) - - (else #f))) - - (define parents (make-hash-table)) - (define bindings (make-hash-table)) - (define heaps (make-hash-table)) - (define allocation (make-hash-table)) - (define heap-indexes (make-hash-table)) - - (hashq-set! bindings #f '()) - (analyze! x #f 0) - (allocate! x 0 0) - - allocation) +;; lambda -> (nlocs . nexts) (define (compile-glil x e opts) - (let ((x (optimize! x e opts))) - (let ((allocation (analyze-lexicals x))) - (values (codegen (make-lambda (tree-il-src x) '() '() x) - allocation) - (and e (cons (car e) (cddr e))) - e)))) + (let* ((x (make-lambda (tree-il-src x) '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))) -(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 (codegen x) - (define stack '()) - (define (push-code! src code) - (set! stack (cons code stack)) - (if src (set! stack (cons (make-glil-source src) stack)))) - (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) - (define (push-bindings! src vars) - (if (not (null? vars)) - (push-code! src (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! src inst label) - (push-code! src (make-glil-branch inst label))) - (define (push-call! src inst args) - (for-each comp-push args) - (push-code! src (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! src code) - (if (not drop) (push-code! src code)) - (maybe-return)) - ;; return void if necessary - (define (return-void!) - (return-code! #f *ia-void*)) - ;; return object if necessary - (define (return-object! src obj) - (return-code! src (make-glil-const obj))) - ;; - ;; dispatch - (record-case tree - ((<ghil-void>) - (return-void!)) - - ((<ghil-quote> env src obj) - (return-object! src obj)) +(define (vars->bind-list vars allocation) + (map (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) (list v 'local (cdr loc))) + ((heap) (list v 'external (cddr loc))) + (else (error "badness" v loc))))) + vars)) + +(define (emit-bindings src vars allocation emit-code) + (if (pair? vars) + (emit-code src (make-glil-bind (vars->bind-list 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 (vars nargs nrest) + (let lp ((vars (lambda-vars x)) (out '()) (n 0)) + (cond ((null? vars) (values (reverse out) n 0)) + ((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n))) + (else (values (reverse (cons vars out)) (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 vars allocation emit-code) + (if (lambda-src x) + (emit-code (make-glil-src (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 vars)))) + (case (car loc) + ((heap) + (emit-code (make-glil-argument 'ref n)) + (emit-code (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)) - ((<ghil-ref> env src var) - (return-code! src (make-glil-var 'ref env var))) - - ((<ghil-set> env src var val) - (comp-push val) - (push-code! src (make-glil-var 'set env var)) - (return-void!)) - - ((<toplevel-define> src name exp) - (comp-push exp) - (push-code! src (make-glil-var 'define env var)) - (return-void!)) + (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) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call (case context + ((tail) 'goto/args) + (else 'call)) + (length args)))) ((<conditional> src test then else) ;; TEST @@ -312,228 +148,130 @@ ;; L2: (let ((L1 (make-label)) (L2 (make-label))) (comp-push test) - (push-branch! src 'br-if-not L1) + (emit-branch src 'br-if-not L1) (comp-tail then) - (if (not tail) (push-branch! #f 'br L2)) - (push-label! L1) + (if (not (eq? context 'tail)) + (emit-branch #f 'br L2)) + (emit-label L1) (comp-tail else) - (if (not tail) (push-label! L2)))) - - ((<sequence> src exps) - ;; EXPS... - ;; TAIL - (if (null? exps) - (return-void!) - (do ((exps exps (cdr exps))) - ((null? (cdr exps)) - (comp-tail (car exps))) - (comp-drop (car exps))))) - - ((<let> src vars vals body) - ;; VALS... - ;; (set VARS)... - ;; BODY + (if (not (eq? context 'tail)) + (emit-label L2)))) + + ((<primitive-ref> src name) + (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 vars vals exp) (for-each comp-push vals) - (push-bindings! src 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 src producer vars rest body) - ;; VALS... - ;; (set VARS)... - ;; BODY - (let ((MV (make-label))) - (comp-push producer) - (push-code! src (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 src vars rest meta body) - (return-code! src (codegen tree))) - - ((<ghil-inline> env src 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! src tail-inst args))) - (else - (push-call! src inline args) - (maybe-drop) - (maybe-return))))) - - ((<ghil-values> env src values) - (cond (tail ;; (lambda () (values 1 2)) - (push-call! src '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! src 'call values)))) - - ((<ghil-values*> env src values) - (cond (tail ;; (lambda () (apply values '(1 2))) - (push-call! src '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! src 'apply values)))) - - ((<ghil-call> env src proc args) - ;; PROC - ;; ARGS... - ;; ([tail-]call NARGS) - (comp-push proc) - (let ((nargs (length args))) - (cond ((< nargs 255) - (push-call! src (if tail 'goto/args 'call) args)) - (else - (push-call! src 'mark '()) - (for-each comp-push args) - (push-call! src 'list-mark '()) - (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2))))) - (maybe-drop)) - - ((<ghil-mv-call> env src 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! src (make-glil-mv-call 0 MV)) - (push-code! src (make-glil-call (if tail 'goto/args 'call) 1)) - (cond ((not tail) - (push-branch! #f 'br POST))) - (push-label! MV) - (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) - (cond ((not tail) - (push-label! POST) - (maybe-drop))))) - - ((<ghil-reified-env> env src) - (return-object! src (ghil-env-reify env))))) - - ;; - ;; main - ;; - - ;; analyze vars: partition into args, locs, exts, and assign indices - (record-case x - ((<ghil-lambda> env src vars rest meta body) - (let* ((evars (ghil-env-variables env)) - (srcs (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 src (set! stack (cons (make-glil-source src) 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)) + (emit-bindings src 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 vars vals exp) + (for-each comp-push vals) + (emit-bindings src 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)))))) |