summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/utils.scm33
1 files changed, 19 insertions, 14 deletions
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 24ede7ff5..f9092d0b3 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021, 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-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
@@ -171,12 +171,15 @@ predecessor."
"Compute a mapping LABEL->LABEL..., where each key is a reachable
$kfun and each associated value is the body of the function, as an
intset."
- (define (intset-cons i set) (intset-add set i))
- (define (visit-fun kfun body to-visit)
+ (define (visit-fun kfun body to-visit visited)
+ (define (add-function i to-visit)
+ (if (intset-ref visited i)
+ to-visit
+ (intset-add to-visit i)))
(intset-fold
(lambda (label to-visit)
- (define (return kfun*) (fold intset-cons to-visit kfun*))
- (define (return1 kfun) (intset-add to-visit kfun))
+ (define (return kfun*) (fold add-function to-visit kfun*))
+ (define (return1 kfun) (add-function kfun to-visit))
(define (return0) to-visit)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
@@ -190,20 +193,22 @@ intset."
(_ (return0))))
body
to-visit))
- (let lp ((to-visit (intset kfun)) (visited empty-intmap))
- (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
- (if (eq? to-visit empty-intset)
- visited
+ (let lp ((to-visit (intset kfun)) (visited empty-intset) (out empty-intmap))
+ (if (eq? to-visit empty-intset)
+ out
+ (let ((visited (intset-union to-visit visited)))
(call-with-values
(lambda ()
(intset-fold
- (lambda (kfun to-visit visited)
- (let ((body (compute-function-body conts kfun)))
- (values (visit-fun kfun body to-visit)
- (intmap-add visited kfun body))))
+ (lambda (kfun to-visit visited out)
+ (let* ((body (compute-function-body conts kfun)))
+ (values (visit-fun kfun body to-visit visited)
+ visited
+ (intmap-add out kfun body))))
to-visit
empty-intset
- visited))
+ visited
+ out))
lp)))))
(define* (compute-successors conts #:optional (kfun (intmap-next conts)))