mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

add <fix> tree-il construct, and compile it

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-08-05 17:51:40 +02:00
parent dab0f9d55d
commit c21c89b138
9 changed files with 189 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/vm-i-system.c
View file

@ -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 ()

1
module/Makefile.am
View file

@ -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

60
module/language/glil/compile-assembly.scm
View file

@ -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)))

24
module/language/tree-il.scm
View file

@ -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)))

27
module/language/tree-il/analyze.scm
View file

@ -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)))

43
module/language/tree-il/compile-glil.scm
View file

@ -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

29
module/language/tree-il/fix-letrec.scm Normal file
View file

@ -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)

26
module/language/tree-il/inline.scm
View file

@ -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)

9
module/language/tree-il/optimize.scm
View file

@ -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))))))