mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Handle letrec*' like letrec' in simple cases.

Browse source 
* module/language/tree-il/fix-letrec.scm (fix-letrec!): When X is a
  `letrec*' with only lambdas and simple expressions, analyze it as if
  it were a `letrec'.
* test-suite/tests/tree-il.test ("letrec"): Add test for
  `(letrec* (x y) (xx yy) ((const 1) (const 2)) (lexical y yy))'.
This commit is contained in:
Ludovic Courtès 2011-03-06 23:02:57 +01:00
parent 821eca02eb
commit 65ea26c582
2 changed files with 94 additions and 60 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011 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
@ -190,64 +190,83 @@
x))
((<letrec> src in-order? names gensyms vals body)
(let ((binds (map list gensyms names vals)))
;; The bindings returned by this function need to appear in the same
;; order that they appear in the letrec.
(define (lookup set)
(let lp ((binds binds))
(cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
(c (lookup complex)))
;; Bind "simple" bindings, and locations for complex
;; bindings.
(make-let
src
(append (map cadr s) (map cadr c))
(append (map car s) (map car c))
(append (map caddr s) (map (lambda (x) (make-void #f)) c))
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
src
(append
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(cond
((null? c)
;; No complex bindings, just emit the body.
(list body))
(in-order?
;; For letrec*, assign complex bindings in order, then the
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c) (caddr c)))
c)
(list body)))
(else
;; Otherwise for plain letrec, evaluate the the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body))))))))))
(if (and in-order?
(every (lambda (x)
(or (lambda? x)
(simple-expression?
x gensyms
effect+exception-free-primitive?)))
vals))
;; If it is a `letrec*', return an equivalent `letrec' when
;; it's possible. This is a hack until we implement the
;; algorithm described in "Fixing Letrec (Reloaded)"
;; (Ghuloum and Dybvig) to allow cases such as
;; (letrec* ((f (lambda () ...))(g (lambda () ...))) ...)
;; or
;; (letrec* ((x 2)(y 3)) y)
;; to be optimized. These can be common when using
;; internal defines.
(fix-letrec!
(make-letrec src #f names gensyms vals body))
(let ((binds (map list gensyms names vals)))
;; The bindings returned by this function need to appear in the same
;; order that they appear in the letrec.
(define (lookup set)
(let lp ((binds binds))
(cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
(c (lookup complex)))
;; Bind "simple" bindings, and locations for complex
;; bindings.
(make-let
src
(append (map cadr s) (map cadr c))
(append (map car s) (map car c))
(append (map caddr s) (map (lambda (x) (make-void #f)) c))
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
src
(append
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(cond
((null? c)
;; No complex bindings, just emit the body.
(list body))
(in-order?
;; For letrec*, assign complex bindings in order, then the
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c)
(caddr c)))
c)
(list body)))
(else
;; Otherwise for plain letrec, evaluate the the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body)))))))))))
((<let> src names gensyms vals body)
(let ((binds (map list gensyms names vals)))
@ -271,3 +290,7 @@
(else x)))
x)))
;;; Local Variables:
;;; eval: (put 'record-case 'scheme-indent-function 1)
;;; End:

13
test-suite/tests/tree-il.test
View file

@ -363,7 +363,18 @@
(lexical #t #t set 1)
(lexical #t #t ref 0)
(lexical #t #t ref 1)
(call add 2) (call return 1) (unbind))))
(call add 2) (call return 1) (unbind)))
;; simple bindings in letrec* -> equivalent to letrec
(assert-tree-il->glil
(letrec* (x y) (xx yy) ((const 1) (const 2))
(lexical y yy))
(program () (std-prelude 0 1 #f) (label _)
(const 2)
(bind (y #f 0)) ;; X is removed, and Y is unboxed
(lexical #t #f set 0)
(lexical #t #f ref 0)
(call return 1) (unbind))))
(with-test-prefix "lambda"
(assert-tree-il->glil