summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-08-05 17:51:40 +0200
committerAndy Wingo <wingo@pobox.com>2009-08-05 17:52:27 +0200
commitc21c89b1384415313cd4bc03e76d6e1507e48d7a (patch)
treea1877790367919f17c418591735f7f2a27da3894
parentdab0f9d55db2e2f4251265443ab0599e424a02c9 (diff)
downloadguile-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.c14
-rw-r--r--module/Makefile.am1
-rw-r--r--module/language/glil/compile-assembly.scm60
-rw-r--r--module/language/tree-il.scm24
-rw-r--r--module/language/tree-il/analyze.scm27
-rw-r--r--module/language/tree-il/compile-glil.scm43
-rw-r--r--module/language/tree-il/fix-letrec.scm29
-rw-r--r--module/language/tree-il/inline.scm26
-rw-r--r--module/language/tree-il/optimize.scm9
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))))))