diff options
author | Andy Wingo <wingo@pobox.com> | 2009-08-05 17:51:40 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-08-05 17:52:27 +0200 |
commit | c21c89b1384415313cd4bc03e76d6e1507e48d7a (patch) | |
tree | a1877790367919f17c418591735f7f2a27da3894 | |
parent | dab0f9d55db2e2f4251265443ab0599e424a02c9 (diff) | |
download | guile-c21c89b1384415313cd4bc03e76d6e1507e48d7a.tar.gz |
add <fix> tree-il construct, and compile it
* libguile/vm-i-system.c (fix-closure): New instruction, for wiring
together fixpoint procedures.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Add fix-letrec.scm.
* module/language/glil/compile-assembly.scm (glil->assembly): Reindent
the <glil-lexical> case, and handle 'fix for locally-bound vars.
* module/language/tree-il.scm (<fix>): Add the <fix> tree-il type and
accessors, for fixed-point bindings. This IL construct is taken from
the Waddell paper.
(parse-tree-il, unparse-tree-il, tree-il->scheme, tree-il-fold)
(pre-order!, post-order!): Update for <fix>.
* module/language/tree-il/analyze.scm (analyze-lexicals): Update for
<fix>. The difference here is that the bindings may not be assigned,
and are not marked as such. They are not boxed.
(report-unused-variables): Update for <fix>.
* module/language/tree-il/compile-glil.scm (flatten): Compile <fix> to
GLIL.
* module/language/tree-il/fix-letrec.scm: A stub implementation of
fixing letrec -- will flesh out in a separate commit.
* module/language/tree-il/inline.scm: Fix license, it was mistakenly
added with LGPL v2.1+.
* module/language/tree-il/optimize.scm (optimize!): Run the fix-letrec!
pass.
-rw-r--r-- | libguile/vm-i-system.c | 14 | ||||
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 60 | ||||
-rw-r--r-- | module/language/tree-il.scm | 24 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 27 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 43 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 29 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 26 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 9 |
9 files changed, 189 insertions, 44 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 4536b91da..9604ce55a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1232,6 +1232,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1) +{ + SCM x, vect; + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + POP (vect); + /* FIXME CHECK_LOCAL (i) */ + x = LOCAL_REF (i); + /* FIXME ASSERT_PROGRAM (x); */ + SCM_SET_CELL_WORD_3 (x, vect); + NEXT; +} + /* (defun renumber-ops () diff --git a/module/Makefile.am b/module/Makefile.am index b6bd341d6..f3b7e62d5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -78,6 +78,7 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ language/tree-il/optimize.scm \ language/tree-il/inline.scm \ + language/tree-il/fix-letrec.scm \ language/tree-il/analyze.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index fa5805757..4bd6c4f04 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -251,35 +251,41 @@ (emit-code (if local? (if (< index 256) - `((,(case op - ((ref) (if boxed? 'local-boxed-ref 'local-ref)) - ((set) (if boxed? 'local-boxed-set 'local-set)) - ((box) 'box) - ((empty-box) 'empty-box) - (else (error "what" op))) - ,index)) + (case op + ((ref) (if boxed? + `((local-boxed-ref ,index)) + `((local-ref ,index)))) + ((set) (if boxed? + `((local-boxed-set ,index)) + `((local-set ,index)))) + ((box) `((box ,index))) + ((empty-box) `((empty-box ,index))) + ((fix) `((fix-closure 0 ,index))) + (else (error "what" op))) (let ((a (quotient i 256)) (b (modulo i 256))) - `((,(case op - ((ref) - (if boxed? - `((long-local-ref ,a ,b) - (variable-ref)) - `((long-local-ref ,a ,b)))) - ((set) - (if boxed? - `((long-local-ref ,a ,b) - (variable-set)) - `((long-local-set ,a ,b)))) - ((box) - `((make-variable) - (variable-set) - (long-local-set ,a ,b))) - ((empty-box) - `((make-variable) - (long-local-set ,a ,b))) - (else (error "what" op))) - ,index)))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + ((fix) + `((fix-closure ,a ,b))) + (else (error "what" op))) + ,index)))) `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index aec4eedb9..01d52f181 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -38,6 +38,7 @@ <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-body <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body parse-tree-il @@ -65,6 +66,7 @@ (<lambda> names vars meta body) (<let> names vars vals body) (<letrec> names vars vals body) + (<fix> names vars vals body) (<let-values> names vars exp body)) @@ -141,6 +143,9 @@ ((letrec ,names ,vars ,vals ,body) (make-letrec loc names vars (map retrans vals) (retrans body))) + ((fix ,names ,vars ,vals ,body) + (make-fix loc names vars (map retrans vals) (retrans body))) + ((let-values ,names ,vars ,exp ,body) (make-let-values loc names vars (retrans exp) (retrans body))) @@ -197,6 +202,9 @@ ((<letrec> names vars vals body) `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<fix> names vars vals body) + `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<let-values> names vars exp body) `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) @@ -256,6 +264,10 @@ ((<letrec> vars vals body) `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + ((<fix> vars vals body) + ;; not a typo, we really do translate back to letrec + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + ((<let-values> vars exp body) `(call-with-values (lambda () ,(tree-il->scheme exp)) (lambda ,vars ,(tree-il->scheme body)))))) @@ -300,6 +312,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (down tree result))))) + ((<fix> vals body) + (up tree (loop body + (loop vals + (down tree result))))) ((<let-values> body) (up tree (loop body (down tree result)))) (else @@ -343,6 +359,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + ((<fix> vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + ((<let-values> vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) @@ -390,6 +410,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) + ((<fix> vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + ((<let-values> vars exp body) (set! (let-values-exp x) (lp exp)) (set! (let-values-body x) (lp body))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1b39b2dd4..35ddfaa3b 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -177,6 +177,13 @@ (apply lset-union eq? (step body) (map step vals)) vars)) + ((<fix> vars vals body) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) + ((<let-values> vars exp body) (hashq-set! bound-vars proc (let lp ((out (hashq-ref bound-vars proc)) (in vars)) @@ -285,6 +292,20 @@ `(#t ,(hashq-ref assigned v) . ,n))) (lp (cdr vars) (1+ n)))))) + ((<fix> vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (if (hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr vars) (1+ n)))))) + ((<let-values> vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) @@ -381,6 +402,9 @@ ((<letrec> vars names) (make-binding-info (extend vars names) refs (cons src locs))) + ((<fix> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) ((<let-values> vars names) (make-binding-info (extend vars names) refs (cons src locs))) @@ -428,6 +452,9 @@ ((<letrec> vars) (make-binding-info (shrink vars refs) refs (cdr locs))) + ((<fix> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) ((<let-values> vars) (make-binding-info (shrink vars refs) refs (cdr locs))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 975cbf02a..e3e45f56c 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -557,6 +557,49 @@ (comp-tail body) (emit-code #f (make-glil-unbind))) + ((<fix> src names vars vals body) + ;; For fixpoint procedures, we can do some tricks to avoid + ;; heap-allocation. Since we know the vals are lambdas, we can + ;; set them to their local var slots first, then capture their + ;; bindings, mutating them in place. + (for-each (lambda (x v) + (emit-code #f (flatten-lambda x allocation)) + (if (not (null? (cdr (hashq-ref allocation x)))) + ;; But we do have to make-closure them first, so + ;; we are mutating fresh closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + vals + vars) + (emit-bindings src names vars allocation proc emit-code) + ;; Now go back and fix up the bindings. + (for-each + (lambda (x v) + (let ((free-locs (cdr (hashq-ref allocation x)))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + ((<let-values> src names vars exp body) (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) (cond diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..61504f6f1 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,29 @@ +;;; transformation of letrec into simpler forms + +;; 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 3 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 fix-letrec) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (fix-letrec!)) + +;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet +;; Efficient Implementation of Scheme’s Recursive Binding Construct", by +;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. + +(define (fix-letrec! x) + x) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 10ec51c08..c534f195b 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -2,19 +2,19 @@ ;; 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 +;;;; 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 3 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 inline) #:use-module (system base syntax) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 9820f9417..23505201c 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -22,13 +22,14 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language tree-il inline) + #:use-module (language tree-il fix-letrec) #:export (optimize!)) (define (env-module e) (if e (car e) (current-module))) (define (optimize! x env opts) - (inline! - (expand-primitives! - (resolve-primitives! x (env-module env))))) - + (fix-letrec! + (inline! + (expand-primitives! + (resolve-primitives! x (env-module env)))))) |