wingo pushed a commit to branch wip-inlinable-exports
in repository guile.
commit 89ad8234809ab26a3fecfbbf875d37c0ea7e6ee8
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri Apr 2 11:54:15 2021 +0200
Optimize letrec* binding order in fix-letrec
* 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.
---
module/language/tree-il/fix-letrec.scm | 44 +++++++++++++++++++++++++++++++---
1 file changed, 41 insertions(+), 3 deletions(-)
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index afc9b8e..2cd550a 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -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>
