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

[Matt Wette <matt.wette@gmail.com>]

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)))))))))