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

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

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