1
Fork 0
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:
Andy Wingo 2014-03-29 07:56:08 +01:00
parent 1eda52c8ad
commit a6f823bd02
4 changed files with 21 additions and 44 deletions

View file

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

View file

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

View file

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

View file

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