mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +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

29
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,6 +190,24 @@
x))
((<letrec> src in-order? names gensyms vals 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.
@ -229,7 +247,8 @@
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c) (caddr c)))
(make-lexical-set #f (cadr c) (car c)
(caddr c)))
c)
(list body)))
(else
@ -247,7 +266,7 @@
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body))))))))))
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