summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps.scm62
-rw-r--r--module/language/cps/cse.scm2
-rw-r--r--module/language/cps/dce.scm2
-rw-r--r--module/language/cps/dfg.scm9
4 files changed, 53 insertions, 22 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm
index ddda6ff50..c685ddc93 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -136,7 +136,8 @@
;; Misc.
parse-cps unparse-cps
- make-cont-folder fold-conts fold-local-conts
+ make-global-cont-folder make-local-cont-folder
+ fold-conts fold-local-conts
visit-cont-successors))
;; FIXME: Use SRFI-99, when Guile adds it.
@@ -449,7 +450,7 @@
(_
(error "unexpected cps" exp))))
-(define-syntax-rule (make-cont-folder global? seed ...)
+(define-syntax-rule (make-global-cont-folder seed ...)
(lambda (proc cont seed ...)
(define (fold-values proc in seed ...)
(if (null? in)
@@ -492,22 +493,55 @@
(($ $continue k src exp)
(match exp
- (($ $fun)
- (if global?
- (fun-folder exp seed ...)
- (values seed ...)))
+ (($ $fun) (fun-folder exp seed ...))
(_ (values seed ...))))
(($ $letrec names syms funs body)
(let-values (((seed ...) (term-folder body seed ...)))
- (if global?
- (fold-values fun-folder funs seed ...)
- (values seed ...))))))
+ (fold-values fun-folder funs seed ...)))))
(cont-folder cont seed ...)))
+(define-syntax-rule (make-local-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k (and cont ($ $kargs names syms body)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (term-folder body seed ...)))
+ (($ $cont k cont)
+ (proc k cont seed ...))))
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (match conts
+ (() (values seed ...))
+ ((cont) (cont-folder cont seed ...))
+ ((cont . conts)
+ (let-values (((seed ...) (cont-folder cont seed ...)))
+ (lp conts seed ...)))))))
+ (($ $letrec names syms funs body) (term-folder body seed ...))
+ (_ (values seed ...))))
+ (define (clause-folder clause seed ...)
+ (match clause
+ (($ $cont k (and cont ($ $kclause arity body alternate)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (if alternate
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (clause-folder alternate seed ...))
+ (cont-folder body seed ...))))))
+ (match cont
+ (($ $cont k (and cont ($ $kfun src meta self tail clause)))
+ (let*-values (((seed ...) (proc k cont seed ...))
+ ((seed ...) (if clause
+ (clause-folder clause seed ...)
+ (values seed ...))))
+ (cont-folder tail seed ...))))))
+
(define (compute-max-label-and-var fun)
- ((make-cont-folder #t max-label max-var)
+ ((make-global-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
@@ -521,15 +555,13 @@
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
- fun
- -1
- -1))
+ fun -1 -1))
(define (fold-conts proc seed fun)
- ((make-cont-folder #t seed) proc fun seed))
+ ((make-global-cont-folder seed) proc fun seed))
(define (fold-local-conts proc seed fun)
- ((make-cont-folder #f seed) proc fun seed))
+ ((make-local-cont-folder seed) proc fun seed))
(define (visit-cont-successors proc cont)
(match cont
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 2ecf40ca5..5ca0bb54c 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -230,7 +230,7 @@ be that both true and false proofs are available."
(define (compute-label-and-var-ranges fun)
(match fun
(($ $cont kfun ($ $kfun src meta self))
- ((make-cont-folder #f min-label label-count min-var var-count)
+ ((make-local-cont-folder min-label label-count min-var var-count)
(lambda (k cont min-label label-count min-var var-count)
(let ((min-label (min k min-label))
(label-count (1+ label-count)))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 9105c4eaa..9100b93d7 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -90,7 +90,7 @@
(define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun)
(call-with-values (lambda ()
- ((make-cont-folder #f label-count max-label)
+ ((make-local-cont-folder label-count max-label)
(lambda (k cont label-count max-label)
(values (1+ label-count) (max k max-label)))
fun 0 -1))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 5233719b1..efafd745d 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -735,9 +735,8 @@ body continuation in the prompt."
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
- (define-syntax-rule (do-fold global?)
- ((make-cont-folder global?
- min-label max-label label-count
+ (define-syntax-rule (do-fold make-cont-folder)
+ ((make-cont-folder min-label max-label label-count
min-var max-var var-count)
(lambda (label cont
min-label max-label label-count
@@ -778,8 +777,8 @@ body continuation in the prompt."
fun
#f -1 0 #f -1 0))
(if global?
- (do-fold #t)
- (do-fold #f)))
+ (do-fold make-global-cont-folder)
+ (do-fold make-local-cont-folder)))
(define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?))