mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Optimize make-global-cont-folder

Browse source 
* module/language/cps.scm (make-global-cont-folder): Inline the
  fold-values, as peval doesn't do so.  Allows closure conversion to
  avoid any closure creation.
This commit is contained in:
Andy Wingo 2014-04-14 13:53:35 +02:00
parent 560bfa9241
commit 2ad91e6b34
1 changed files with 10 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/cps.scm
View file

@ -476,12 +476,6 @@
(define-syntax-rule (make-global-cont-folder seed ...)
(lambda (proc cont seed ...)
(define (fold-values proc in seed ...)
(if (null? in)
(values seed ...)
(let-values (((seed ...) (proc (car in) seed ...)))
(fold-values proc (cdr in) seed ...))))
(define (cont-folder cont seed ...)
(match cont
(($ $cont k cont)
@ -513,7 +507,11 @@
(match term
(($ $letk conts body)
(let-values (((seed ...) (term-folder body seed ...)))
(fold-values cont-folder conts seed ...)))
(let lp ((conts conts) (seed seed) ...)
(if (null? conts)
(values seed ...)
(let-values (((seed ...) (cont-folder (car conts) seed ...)))
(lp (cdr conts) seed ...))))))
(($ $continue k src exp)
(match exp
@ -522,7 +520,11 @@
(($ $letrec names syms funs body)
(let-values (((seed ...) (term-folder body seed ...)))
(fold-values fun-folder funs seed ...)))))
(let lp ((funs funs) (seed seed) ...)
(if (null? funs)
(values seed ...)
(let-values (((seed ...) (fun-folder (car funs) seed ...)))
(lp (cdr funs) seed ...))))))))
(cont-folder cont seed ...)))