diff options
author | Andy Wingo <wingo@pobox.com> | 2021-04-02 11:54:15 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-04-21 22:41:12 +0200 |
commit | fafe845c11fb611d3b51959086b61aee10235664 (patch) | |
tree | be9bb9fd7b9b9c6a5901c51bdf07b6fa42a26bde /module/language/tree-il/fix-letrec.scm | |
parent | 6069fa5ce24ae466437543b98665b004e874b7f0 (diff) | |
download | guile-fafe845c11fb611d3b51959086b61aee10235664.tar.gz |
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.
Diffstat (limited to 'module/language/tree-il/fix-letrec.scm')
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 44 |
1 files changed, 41 insertions, 3 deletions
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index afc9b8e21..2cd550ae9 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> |