summaryrefslogtreecommitdiff
path: root/module/language/cps.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-03-29 07:56:08 +0100
committerAndy Wingo <wingo@pobox.com>2014-03-31 18:21:04 +0200
commita6f823bd027b091114eeca9fe651e1025be1e537 (patch)
tree21af2b9ed7fbbe431823a0fe3ed01d50caac031e /module/language/cps.scm
parent1eda52c8adb6eef950ddd7e3ffd0606314fb0ed8 (diff)
downloadguile-a6f823bd027b091114eeca9fe651e1025be1e537.tar.gz
Public make-cont-folder
* module/language/cps.scm (make-cont-folder): Add global? parameter, and make public. (fold-conts): Adapt. (fold-local-conts): Use make-cont-folder, and take a function instead of a continuation. * module/language/cps/arities.scm (fix-clause-arities, fix-arities*): * module/language/cps/compile-bytecode.scm (collect-conts): * module/language/cps/elide-values.scm (elide-values*): Adapt to fold-local-conts change.
Diffstat (limited to 'module/language/cps.scm')
-rw-r--r--module/language/cps.scm46
1 files changed, 13 insertions, 33 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 9101aa108..f8b871ed0 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -136,7 +136,7 @@
;; Misc.
parse-cps unparse-cps
- fold-conts fold-local-conts))
+ make-cont-folder fold-conts fold-local-conts))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@@ -439,7 +439,7 @@
(_
(error "unexpected cps" exp))))
-(define-syntax-rule (make-cont-folder seed ...)
+(define-syntax-rule (make-cont-folder global? seed ...)
(lambda (proc fun seed ...)
(define (fold-values proc in seed ...)
(if (null? in)
@@ -477,17 +477,22 @@
(($ $continue k src exp)
(match exp
- (($ $fun) (fun-folder exp seed ...))
+ (($ $fun)
+ (if global?
+ (fun-folder exp seed ...)
+ (values seed ...)))
(_ (values seed ...))))
(($ $letrec names syms funs body)
(let-values (((seed ...) (term-folder body seed ...)))
- (fold-values fun-folder funs seed ...)))))
+ (if global?
+ (fold-values fun-folder funs seed ...)
+ (values seed ...))))))
(fun-folder fun seed ...)))
(define (compute-max-label-and-var fun)
- ((make-cont-folder max-label max-var)
+ ((make-cont-folder #t max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
@@ -501,32 +506,7 @@
-1))
(define (fold-conts proc seed fun)
- ((make-cont-folder seed) proc fun seed))
+ ((make-cont-folder #t seed) proc fun seed))
-(define (fold-local-conts proc seed cont)
- (define (cont-folder cont seed)
- (match cont
- (($ $cont k cont)
- (let ((seed (proc k cont seed)))
- (match cont
- (($ $kargs names syms body)
- (term-folder body seed))
-
- (($ $kentry self tail clauses)
- (fold cont-folder (cont-folder tail seed) clauses))
-
- (($ $kclause arity body)
- (cont-folder body seed))
-
- (_ seed))))))
-
- (define (term-folder term seed)
- (match term
- (($ $letk conts body)
- (fold cont-folder (term-folder body seed) conts))
-
- (($ $continue) seed)
-
- (($ $letrec names syms funs body) (term-folder body seed))))
-
- (cont-folder cont seed))
+(define (fold-local-conts proc seed fun)
+ ((make-cont-folder #f seed) proc fun seed))