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

fix-letrec tweak

Browse source 
* module/language/tree-il/fix-letrec.scm (make-sequence*, fix-letrec!):
  When turning unreferenced bindings into sequences, don't bother
  emitting trivially constant expressions in effect position.
This commit is contained in:
Andy Wingo 2012-05-15 17:20:57 +02:00
parent dc1ee62046
commit 86e4479abb
1 changed files with 18 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

22
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, 2011 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2010, 2011, 2012 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
@ -181,6 +181,20 @@
'()))) '())))
(values unref simple lambda* complex))) (values unref simple lambda* complex)))
(define (make-sequence* src exps)
(let lp ((in exps) (out '()))
(if (null? (cdr in))
(if (null? out)
(car in)
(make-sequence src (reverse (cons (car in) out))))
(let ((head (car in)))
(record-case head
((<lambda>) (lp (cdr in) out))
((<const>) (lp (cdr in) out))
((<lexical-ref>) (lp (cdr in) out))
((<void>) (lp (cdr in) out))
(else (lp (cdr in) (cons head out))))))))
(define (fix-letrec! x) (define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x))) (let-values (((unref simple lambda* complex) (partition-vars x)))
(post-order! (post-order!
@ -191,7 +205,7 @@
;; expression, called for effect. ;; expression, called for effect.
((<lexical-set> gensym exp) ((<lexical-set> gensym exp)
(if (memq gensym unref) (if (memq gensym unref)
(make-sequence #f (list exp (make-void #f))) (make-sequence* #f (list exp (make-void #f)))
x)) x))
((<letrec> src in-order? names gensyms vals body) ((<letrec> src in-order? names gensyms vals body)
@ -219,7 +233,7 @@
;; Bind lambdas using the fixpoint operator. ;; Bind lambdas using the fixpoint operator.
(make-fix (make-fix
src (map cadr l) (map car l) (map caddr l) src (map cadr l) (map car l) (map caddr l)
(make-sequence (make-sequence*
src src
(append (append
;; The right-hand-sides of the unreferenced ;; The right-hand-sides of the unreferenced
@ -263,7 +277,7 @@
(let ((u (lookup unref)) (let ((u (lookup unref))
(l (lookup lambda*)) (l (lookup lambda*))
(c (lookup complex))) (c (lookup complex)))
(make-sequence (make-sequence*
src src
(append (append
;; unreferenced bindings, called for effect. ;; unreferenced bindings, called for effect.