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? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body let? make-let let-src let-names let-vars let-vals let-body letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + fix? make-fix fix-src fix-names fix-vars fix-vals fix-body 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 @@ ( names vars meta body) ( names vars vals body) ( names vars vals body) + ( names vars vals body) ( 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 @@ (( names vars vals body) `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars vals body) + `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (( names vars exp body) `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) @@ -256,6 +264,10 @@ (( vars vals body) `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + (( 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))) + (( 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))))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) (( 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))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( 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))) + (( vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + (( 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)) + (( 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)) + (( 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)))))) + (( 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)))))) + (( vars exp body) (let ((nmax (recur exp))) (let lp ((vars vars) (n n)) @@ -381,6 +402,9 @@ (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) (( vars names) (make-binding-info (extend vars names) refs (cons src locs))) @@ -428,6 +452,9 @@ (( vars) (make-binding-info (shrink vars refs) refs (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) (( 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))) + (( 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))) + (( 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))))))