mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
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.
This commit is contained in:
parent
1eda52c8ad
commit
a6f823bd02
4 changed files with 21 additions and 44 deletions
|
@ -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))
|
||||
|
|
|
@ -32,9 +32,8 @@
|
|||
#:use-module (language cps primitives)
|
||||
#:export (fix-arities))
|
||||
|
||||
(define (fix-clause-arities clause)
|
||||
(let ((conts (build-local-cont-table clause))
|
||||
(ktail (match clause
|
||||
(define (fix-clause-arities clause conts)
|
||||
(let ((ktail (match clause
|
||||
(($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
|
@ -184,9 +183,10 @@
|
|||
(sym ($kentry self ,tail ,(map visit-cont clauses)))))))
|
||||
|
||||
(define (fix-arities* fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(fix-clause-arities body)))))
|
||||
(let ((conts (build-local-cont-table fun)))
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(fix-clause-arities body conts))))))
|
||||
|
||||
(define (fix-arities fun)
|
||||
(with-fresh-name-state fun
|
||||
|
|
|
@ -91,9 +91,7 @@
|
|||
(when idx
|
||||
(vector-set! contv idx cont))))
|
||||
'()
|
||||
(match f
|
||||
(($ $fun src meta free entry)
|
||||
entry)))
|
||||
f)
|
||||
contv))
|
||||
|
||||
(define (compile-fun f asm)
|
||||
|
|
|
@ -36,8 +36,7 @@
|
|||
#:export (elide-values))
|
||||
|
||||
(define (elide-values* fun)
|
||||
(let ((conts (build-local-cont-table
|
||||
(match fun (($ $fun src meta free body) body)))))
|
||||
(let ((conts (build-local-cont-table fun)))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue