bug#38486: specialize-numbers.scm: compute-significant-bits

[Matt Wette]

I've narrowed it down to the named let loop "lp" in this routine in
module/language/cps/specialize-numbers.scm


(define (compute-significant-bits cps types kfun)
  "Given the locally inferred types @var{types}, compute a map of VAR ->
BITS indicating the significant bits needed for a variable.  BITS may be
#f to indicate all bits, or a non-negative integer indicating a bitmask."
  (let ((preds (invert-graph (compute-successors cps kfun))))
    (let lp ((worklist (intmap-keys preds)) (visited empty-intset)
             (out empty-intmap))
      (match (intset-prev worklist)
        (#f out)
        (label
         (let ((worklist (intset-remove worklist label))
               (visited* (intset-add visited label)))
           (define (continue out*)
             (if (and (eq? out out*) (eq? visited visited*))
                 (lp worklist visited out)
                 (lp (intset-union worklist (intmap-ref preds label))
                     visited* out*)))
           (define (add-def out var)
             (intmap-add out var 0 sigbits-union))
           (define (add-defs out vars)
             (match vars
               (() out)
               ((var . vars) (add-defs (add-def out var) vars))))
           (define (add-unknown-use out var)
             (intmap-add out var (inferred-sigbits types label var)
                         sigbits-union))
           (define (add-unknown-uses out vars)
             (match vars
               (() out)
               ((var . vars)
                (add-unknown-uses (add-unknown-use out var) vars))))
           (continue
            (match (intmap-ref cps label)
              (($ $kfun src meta self)
               (add-def out self))
              (($ $kargs names vars ($ $continue k src exp))
               (let ((out (add-defs out vars)))
                 (match exp
                   ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ 
$rec))
                    ;; No uses, so no info added to sigbits.
                    out)
                   (($ $values args)
                    (match (intmap-ref cps k)
                      (($ $kargs _ vars)
                       (if (intset-ref visited k)
                           (fold (lambda (arg var out)
                                   (intmap-add out arg (intmap-ref out var)
                                               sigbits-union))
                                 out args vars)
                           out))
                      (($ $ktail)
                       (add-unknown-uses out args))))
                   (($ $call proc args)
                    (add-unknown-use (add-unknown-uses out args) proc))
                   (($ $callk label proc args)
                    (add-unknown-use (add-unknown-uses out args) proc))
                   (($ $branch kt ($ $values (arg)))
                    (add-unknown-use out arg))
                   (($ $branch kt ($ $primcall name args))
                    (add-unknown-uses out args))
                   (($ $primcall name args)
                    (let ((h (significant-bits-handler name)))
                      (if h
                          (match (intmap-ref cps k)
                            (($ $kargs _ defs)
                             (h label types out args defs)))
                          (add-unknown-uses out args))))
                   (($ $prompt escape? tag handler)
                    (add-unknown-use out tag)))))
              (_ out)))))))))