mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

Fix bad algorithmic growth in fix-letrec

Browse source 
We were using list sets, which when you end up with thousands of
bindings in an SCC reaches the point where we are off the quadratic end
of the curve.  Fix to use intsets and intmaps instead.

* module/language/tree-il/fix-letrec.scm (compute-ids): New function.
(compute-referenced-and-assigned): Rename from analyze-lexicals, and
compute intsets.
(make-compute-free-variables): Rename from free-variables, return a
procedure instead of a hash table, and use intsets.  Use a global cache
to avoid quadratic behavior with regard to binding depth.
(compute-complex): Compute a global set of "complex" variables, as an
intset.
(compute-sccs): Use intsets and intmaps to compute the free-variable and
ordering edges.
(fix-scc, fix-term): Refactorings.
(reorder-bindings): Avoid a linear search.
(fix-letrec): Refactor.
This commit is contained in:
Andy Wingo 2025-01-22 14:35:59 +01:00
parent 787e49f137
commit 60c1e5cc42
1 changed files with 216 additions and 153 deletions
Download patch file Download diff file Expand all files Collapse all files

369
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-2013,2016,2019,2021,2023 Free Software Foundation, Inc. ;; Copyright (C) 2009-2013,2016,2019,2021,2023,2025 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
@ -17,7 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il fix-letrec) (define-module (language tree-il fix-letrec)
#:use-module (srfi srfi-1) #:use-module ((srfi srfi-1) #:select (fold fold-right partition))
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (language tree-il) #:use-module (language tree-il)
@ -32,52 +32,85 @@
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig, as well as ;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig, as well as
;; "Fixing Letrec (reloaded)", by Abdulaziz Ghuloum and R. Kent Dybvig. ;; "Fixing Letrec (reloaded)", by Abdulaziz Ghuloum and R. Kent Dybvig.
(define fix-fold (make-tree-il-folder)) (define (compute-ids expr)
(define (analyze-lexicals x) "For each lexical in @var{expr}, assign it an integer identifier.
(define referenced (make-hash-table)) Identifiers are assigned sequentially in pre-order, which allows later
(define assigned (make-hash-table)) code to sort letrec* bindings by identifier value."
;; Functional hash sets would be nice. (define counter 0)
(fix-fold x (define sym->id (make-hash-table))
(match-lambda (define (intern! sym)
(($ <lexical-ref> src name gensym) (let ((id counter))
(hashq-set! referenced gensym #t) (set! counter (1+ id))
(values)) (hashq-set! sym->id sym id)))
(($ <lexical-set> src name gensym) (define (for-each/0 f l)
(hashq-set! assigned gensym #t) (for-each f l)
(values)) (values))
(_ (define tree-il-fold/0 (make-tree-il-folder))
(values))) (tree-il-fold/0 expr
(lambda (x) (match-lambda
(values))) (($ <lambda-case> src req opt rest kw inits syms body alt)
(values referenced assigned)) (for-each/0 intern! syms))
(($ <let> src names syms inits body)
(for-each/0 intern! syms))
(($ <letrec> src in-order? names syms inits body)
(for-each/0 intern! syms))
(($ <fix> src names syms inits body)
(for-each/0 intern! syms))
(_ (values)))
(lambda (_) (values)))
(lambda (sym)
(or (hashq-ref sym->id sym)
(error "unknown binding" sym))))
(define (compute-referenced-and-assigned expr sym->id)
(define tree-il-fold/2 (make-tree-il-folder referenced assigned))
(tree-il-fold/2
expr
(lambda (expr referenced assigned)
(match expr
(($ <lexical-ref> src name gensym)
(values (intset-add referenced (sym->id gensym))
assigned))
(($ <lexical-set> src name gensym val)
(values referenced
(intset-add assigned (sym->id gensym))))
(_
(values referenced assigned))))
(lambda (term referenced assigned)
(values referenced assigned))
empty-intset
empty-intset))
(define (make-seq* src head tail) (define (make-seq* src head tail)
(match head (match head
((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail) ((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail)
(else (make-seq src head tail)))) (else (make-seq src head tail))))
(define (free-variables expr cache) (define (make-compute-free-variables sym->id)
(define (empty)
empty-intset)
(define (adjoin elt set) (define (adjoin elt set)
(lset-adjoin eq? set elt)) (intset-add set (sym->id elt)))
(define (list->set elts)
(fold adjoin (empty) elts))
(define (union set1 set2) (define (union set1 set2)
(lset-union eq? set1 set2)) (intset-union set1 set2))
(define (difference set1 set2) (define (difference set1 set2)
(lset-difference eq? set1 set2)) (intset-subtract set1 set2))
(define fix-fold (make-tree-il-folder))
(define (recurse expr) (define (recurse expr)
(free-variables expr cache)) (visit expr))
(define (recurse* exprs) (define (recurse* exprs)
(fold (lambda (expr free) (fold (lambda (expr free)
(union (recurse expr) free)) (union (recurse expr) free))
'() (empty)
exprs)) exprs))
(define (visit expr) (define (visit expr)
(match expr (match expr
((or ($ <void>) ($ <const>) ($ <primitive-ref>) ((or ($ <void>) ($ <const>) ($ <primitive-ref>)
($ <module-ref>) ($ <toplevel-ref>)) ($ <module-ref>) ($ <toplevel-ref>))
'()) (empty))
(($ <lexical-ref> src name gensym) (($ <lexical-ref> src name gensym)
(list gensym)) (adjoin gensym (empty)))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(adjoin gensym (recurse exp))) (adjoin gensym (recurse exp)))
(($ <module-set> src mod name public? exp) (($ <module-set> src mod name public? exp)
@ -102,22 +135,22 @@
(($ <lambda-case> src req opt rest kw inits gensyms body alternate) (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
(union (difference (union (recurse* inits) (union (difference (union (recurse* inits)
(recurse body)) (recurse body))
gensyms) (list->set gensyms))
(if alternate (if alternate
(recurse alternate) (recurse alternate)
'()))) (empty))))
(($ <let> src names gensyms vals body) (($ <let> src names gensyms vals body)
(union (recurse* vals) (union (recurse* vals)
(difference (recurse body) (difference (recurse body)
gensyms))) (list->set gensyms))))
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
(difference (union (recurse* vals) (difference (union (recurse* vals)
(recurse body)) (recurse body))
gensyms)) (list->set gensyms)))
(($ <fix> src names gensyms vals body) (($ <fix> src names gensyms vals body)
(difference (union (recurse* vals) (difference (union (recurse* vals)
(recurse body)) (recurse body))
gensyms)) (list->set gensyms)))
(($ <let-values> src exp body) (($ <let-values> src exp body)
(union (recurse exp) (union (recurse exp)
(recurse body))) (recurse body)))
@ -129,55 +162,68 @@
(union (recurse tag) (union (recurse tag)
(union (recurse* args) (union (recurse* args)
(recurse tail)))))) (recurse tail))))))
(or (hashq-ref cache expr) (define cache (make-hash-table))
(let ((res (visit expr))) (lambda (expr)
(hashq-set! cache expr res) (or (hashq-ref cache expr)
res))) (let ((res (visit expr)))
(hashq-set! cache expr res)
res))))
(define (enumerate elts) (define (compute-complex expr assigned sym->id)
(fold2 (lambda (x out id) (define (assigned? id)
(values (intmap-add out id x) (1+ id))) (intset-ref assigned id))
elts empty-intmap 0)) (define (assigned-sym? sym)
(assigned? (sym->id sym)))
(define (compute-complex id->sym id->init assigned)
(define compute-effects (define compute-effects
(make-effects-analyzer (lambda (x) (hashq-ref assigned x)))) (make-effects-analyzer assigned-sym?))
(intmap-fold (define (compute-complex-bindings syms inits complex)
(lambda (id sym complex) (fold (lambda (sym init complex)
(if (or (hashq-ref assigned sym) (let ((id (sym->id sym)))
(let ((effects (compute-effects (intmap-ref id->init id)))) (if (or (assigned? id)
(not (constant? (exclude-effects effects &allocation))))) (let ((effects (compute-effects init)))
(intset-add complex id) (not (constant?
complex)) (exclude-effects effects &allocation)))))
id->sym empty-intset)) (intset-add complex id)
complex)))
complex syms inits))
(define tree-il-fold/1 (make-tree-il-folder complex))
(tree-il-fold/1
expr
(lambda (expr complex) complex)
(lambda (expr complex)
;; Complex variables are bound by let or letrec.
(match expr
(($ <letrec> src in-order? names syms inits body)
(compute-complex-bindings syms inits complex))
(($ <let> src names syms inits body)
(compute-complex-bindings syms inits complex))
(_
complex)))
empty-intset))
(define (compute-sccs names syms inits in-order? fv-cache assigned) (define (compute-sccs names syms inits in-order?
(define id->name (enumerate names)) sym->id complex compute-free-variables)
(define id->sym (enumerate syms)) (define nodes
(define id->init (enumerate inits)) (fold (lambda (name sym init nodes)
(define sym->id (intmap-fold (lambda (id sym out) (acons sym id out)) (intmap-add nodes (sym->id sym) (list name sym init)))
id->sym '())) empty-intmap names syms inits))
(define (var-list->intset vars) (define node-ids (intmap-keys nodes))
(fold1 (lambda (sym out)
(intset-add out (assq-ref sym->id sym)))
vars empty-intset))
(define (free-in-init init)
(var-list->intset
(lset-intersection eq? syms (free-variables init fv-cache))))
(define fv-edges (define fv-edges
(fold2 (lambda (init fv i) (intmap-fold (lambda (id node edges)
(values (match node
(intmap-add fv i (free-in-init init)) ((name sym init)
(1+ i))) (let ((fv (compute-free-variables init)))
inits empty-intmap 0)) (intmap-add edges id
(intset-intersect node-ids fv))))))
nodes empty-intmap))
(define order-edges (define order-edges
(if in-order? (if in-order?
(let ((complex (compute-complex id->sym id->init assigned))) ;; Rely on identifier ordering.
(intmap-fold (lambda (id sym out prev) (intset-fold (lambda (id out prev)
(values (values
(intmap-add out id (intset-intersect complex prev)) (intmap-add out id (intset-intersect complex prev))
(intset-add prev id))) (intset-add prev id)))
id->sym empty-intmap empty-intset)) node-ids empty-intmap empty-intset)
empty-intmap)) empty-intmap))
(define sccs (define sccs
(reverse (reverse
@ -185,23 +231,20 @@
(invert-graph (intmap-union fv-edges order-edges intset-union))))) (invert-graph (intmap-union fv-edges order-edges intset-union)))))
(map (lambda (ids) (map (lambda (ids)
(intset-fold-right (lambda (id out) (intset-fold-right (lambda (id out)
(cons (list (intmap-ref id->name id) (cons (intmap-ref nodes id) out))
(intmap-ref id->sym id)
(intmap-ref id->init id))
out))
ids '())) ids '()))
sccs)) sccs))
(define (fix-scc src binds body fv-cache referenced assigned) (define (fix-scc src binds body unreferenced? unassigned? recursive?)
(match binds (match binds
(((name sym init)) (((name sym init))
;; Case of an SCC containing just a single binding. ;; Case of an SCC containing just a single binding.
(cond (cond
((not (hashq-ref referenced sym)) ((unreferenced? sym)
(make-seq* src init body)) (make-seq* src init body))
((and (lambda? init) (not (hashq-ref assigned sym))) ((and (lambda? init) (unassigned? sym))
(make-fix src (list name) (list sym) (list init) body)) (make-fix src (list name) (list sym) (list init) body))
((memq sym (free-variables init fv-cache)) ((recursive? init sym)
(make-let src (list name) (list sym) (list (make-void src)) (make-let src (list name) (list sym) (list (make-void src))
(make-seq src (make-seq src
(make-lexical-set src name sym init) (make-lexical-set src name sym init)
@ -215,19 +258,20 @@
(lambda (bind) (lambda (bind)
(match bind (match bind
((name sym init) ((name sym init)
(and (lambda? init) (and (lambda? init) (unassigned? sym)))))
(not (hashq-ref assigned sym))))))
binds)) binds))
(lambda (l c) (lambda (l c)
(define (bind-complex-vars body) (define (bind-complex-vars body)
(if (null? c) (match c
body (() body)
(let ((inits (map (lambda (x) (make-void #f)) c))) (((names syms inits) ...)
(make-let src (map car c) (map cadr c) inits body)))) (let ((inits (map (lambda (x) (make-void #f)) inits)))
(make-let src names syms inits body)))))
(define (bind-lambdas body) (define (bind-lambdas body)
(if (null? l) (match l
body (() body)
(make-fix src (map car l) (map cadr l) (map caddr l) body))) (((names syms inits) ...)
(make-fix src names syms inits body))))
(define (initialize-complex body) (define (initialize-complex body)
(fold-right (lambda (bind body) (fold-right (lambda (bind body)
(match bind (match bind
@ -241,74 +285,93 @@
(initialize-complex body)))))))) (initialize-complex body))))))))
(define (fix-term src in-order? names gensyms vals body (define (fix-term src in-order? names gensyms vals body
fv-cache referenced assigned) sym->id referenced assigned complex
compute-free-variables)
(define (unreferenced? sym)
(not (intset-ref referenced (sym->id sym))))
(define (unassigned? sym)
(not (intset-ref assigned (sym->id sym))))
(define (recursive? expr sym)
(intset-ref (compute-free-variables expr) (sym->id sym)))
(fold-right (lambda (binds body) (fold-right (lambda (binds body)
(fix-scc src binds body fv-cache referenced assigned)) (fix-scc src binds body
unreferenced? unassigned? recursive?))
body body
(compute-sccs names gensyms vals in-order? fv-cache (compute-sccs names gensyms vals in-order?
assigned))) sym->id complex compute-free-variables)))
;; For letrec*, try to minimize false dependencies introduced by ;; For letrec*, try to minimize false dependencies introduced by
;; ordering. ;; ordering.
(define (reorder-bindings bindings) (define (reorder-bindings bindings sym->id compute-free-variables)
(define (possibly-references? expr bindings) (define (possibly-references? expr remaining-ids)
(let visit ((expr expr)) (not (eq? empty-intset
(match expr (intset-intersect (compute-free-variables expr)
((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)) #f) remaining-ids))))
(($ <lexical-ref> _ name var) (define (binding-ids bindings)
(or-map (match-lambda (#(name var' val) (eq? var' var))) (fold (lambda (binding ids)
bindings)) (match binding
(($ <seq> _ head tail) (#(name sym val) (intset-add ids (sym->id sym)))))
(or (visit head) (visit tail))) empty-intset bindings))
(($ <primcall> _ name args) (or-map visit args)) (let visit ((bindings bindings) (remaining-ids (binding-ids bindings))
(($ <conditional> _ test consequent alternate) (sunk-lambdas '()) (sunk-exprs '()))
(or (visit test) (visit consequent) (visit alternate)))
(_ #t))))
(let visit ((bindings bindings) (sunk-lambdas '()) (sunk-exprs '()))
(match bindings (match bindings
(() (append sunk-lambdas (reverse sunk-exprs))) (() (append sunk-lambdas (reverse sunk-exprs)))
((binding . bindings) ((binding . bindings)
(match binding (match binding
(#(_ _ ($ <lambda>)) (#(_ sym expr)
(visit bindings (cons binding sunk-lambdas) sunk-exprs)) (let ((remaining-ids (intset-remove remaining-ids (sym->id sym))))
(#(_ _ expr) (cond
(cond ((lambda? expr)
((possibly-references? expr bindings) (visit bindings remaining-ids
;; Init expression might refer to later bindings. (cons binding sunk-lambdas) sunk-exprs))
;; Serialize. ((possibly-references? expr remaining-ids)
(append sunk-lambdas (reverse sunk-exprs) ;; Init expression might refer to later bindings.
(cons binding (visit bindings '() '())))) ;; Serialize.
(else (append sunk-lambdas (reverse sunk-exprs)
(visit bindings sunk-lambdas (cons binding sunk-exprs)))))))))) (cons binding (visit bindings remaining-ids '() '()))))
(else
(visit bindings remaining-ids
sunk-lambdas (cons binding sunk-exprs)))))))))))
(define (fix-letrec x) (define (fix-letrec x)
(let-values (((referenced assigned) (analyze-lexicals x))) (define sym->id
(define fv-cache (make-hash-table)) (compute-ids x))
(post-order (define-values (referenced assigned)
(lambda (x) (compute-referenced-and-assigned x sym->id))
(match x (define complex
;; Sets to unreferenced variables may be replaced by their (compute-complex x assigned sym->id))
;; expression, called for effect. (define compute-free-variables
(($ <lexical-set> src name gensym exp) (make-compute-free-variables sym->id))
(if (hashq-ref referenced gensym) (define (unreferenced? sym)
x (not (intset-ref referenced (sym->id sym))))
(make-seq* #f exp (make-void #f))))
(($ <letrec> src in-order? names gensyms vals body)
(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) (post-order
;; Apply the same algorithm to <let> that binds <lambda> (lambda (x)
(if (or-map lambda? vals) (match x
(fix-term src #f names gensyms vals body ;; Sets to unreferenced variables may be replaced by their
fv-cache referenced assigned) ;; expression, called for effect.
x)) (($ <lexical-set> src name (? unreferenced?) exp)
(make-seq* #f exp (make-void #f)))
(_ x)))
x))) (($ <letrec> src in-order? names gensyms vals body)
(if in-order?
(match (reorder-bindings (map vector names gensyms vals)
sym->id compute-free-variables)
((#(names gensyms vals) ...)
(fix-term src #t names gensyms vals body
sym->id referenced assigned complex
compute-free-variables)))
(fix-term src #f names gensyms vals body
sym->id referenced assigned complex
compute-free-variables)))
(($ <let> src names gensyms vals body)
;; Apply the same algorithm to <let> that binds <lambda>
(if (or-map lambda? vals)
(fix-term src #f names gensyms vals body
sym->id referenced assigned complex
compute-free-variables)
x))
(_ x)))
x))