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

Optimize letrec* binding order in fix-letrec

Browse source 
* module/language/tree-il/fix-letrec.scm (reorder-bindings):
(fix-letrec): Reorder definitions so that lambdas tend to stick
together, to avoid "complex" expressions interposing in lambda SCCs.
This commit is contained in:
Andy Wingo 2021-04-02 11:54:15 +02:00
parent 6069fa5ce2
commit fafe845c11
1 changed files with 41 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
;; Copyright (C) 2009-2013,2016,2019 Free Software Foundation, Inc.
;; Copyright (C) 2009-2013,2016,2019,2021 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
@ -253,6 +253,39 @@
(compute-sccs names gensyms vals in-order? fv-cache
assigned)))
;; For letrec*, try to minimize false dependencies introduced by
;; ordering.
(define (reorder-bindings bindings)
(define (possibly-references? expr bindings)
(let visit ((expr expr))
(match expr
((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)) #f)
(($ <lexical-ref> _ name var)
(or-map (match-lambda (#(name var' val) (eq? var' var)))
bindings))
(($ <seq> _ head tail)
(or (visit head) (visit tail)))
(($ <primcall> _ name args) (or-map visit args))
(($ <conditional> _ test consequent alternate)
(or (visit test) (visit consequent) (visit alternate)))
(_ #t))))
(let visit ((bindings bindings) (sunk-lambdas '()) (sunk-exprs '()))
(match bindings
(() (append sunk-lambdas (reverse sunk-exprs)))
((binding . bindings)
(match binding
(#(_ _ ($ <lambda>))
(visit bindings (cons binding sunk-lambdas) sunk-exprs))
(#(_ _ expr)
(cond
((possibly-references? expr bindings)
;; Init expression might refer to later bindings.
;; Serialize.
(append sunk-lambdas (reverse sunk-exprs)
(cons binding (visit bindings '() '()))))
(else
(visit bindings sunk-lambdas (cons binding sunk-exprs))))))))))
(define (fix-letrec x)
(let-values (((referenced assigned) (analyze-lexicals x)))
(define fv-cache (make-hash-table))
@ -268,8 +301,13 @@
(make-seq* #f exp (make-void #f))))
((<letrec> src in-order? names gensyms vals body)
(fix-term src in-order? names gensyms vals body
fv-cache referenced assigned))
(if in-order?
(match (reorder-bindings (map vector names gensyms vals))
((#(names gensyms vals) ...)
(fix-term src #t names gensyms vals body
fv-cache referenced assigned)))
(fix-term src #f names gensyms vals body
fv-cache referenced assigned)))
((<let> src names gensyms vals body)
;; Apply the same algorithm to <let> that binds <lambda>