Fix bad algorithmic growth in fix-letrec

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.

module/language/tree-il/fix-letrec.scm

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