mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

First-order CPS has $program and $closure forms

Browse source 
* module/language/cps.scm ($closure, $program): New CPS types, part of
  low-level (first-order) CPS.
  (build-cps-exp, build-cps-term, parse-cps, unparse-cps)
  (compute-max-label-and-var): Update for new CPS types.

* module/language/cps/closure-conversion.scm: Rewrite to produce a
  $program with $closures, and no $funs.

* module/language/cps/reify-primitives.scm:
* module/language/cps/compile-bytecode.scm (compile-fun):
  (compile-bytecode): Adapt to new first-order format.

* module/language/cps/dfg.scm (compute-dfg): Add $closure case.

* module/language/cps/renumber.scm (renumber): Allow this pass to work
  on either format.

* module/language/cps/slot-allocation.scm (allocate-slots): Add $closure
  case.
This commit is contained in:
Andy Wingo 2014-04-12 11:52:38 +02:00
parent 405805fbc3
commit cf8bb03772
7 changed files with 444 additions and 422 deletions
Download patch file Download diff file Expand all files Collapse all files

64
module/language/cps.scm
View file

@ -122,7 +122,11 @@
$kif $kreceive $kargs $kfun $ktail $kclause
;; Expressions.
$void $const $prim $fun $call $callk $primcall $values $prompt
$void $const $prim $fun $closure
$call $callk $primcall $values $prompt
;; First-order CPS root.
$program
;; Fresh names.
label-counter var-counter
@ -173,7 +177,7 @@
;; Terms.
(define-cps-type $letk conts body)
(define-cps-type $continue k src exp)
(define-cps-type $letrec names syms funs body)
(define-cps-type $letrec names syms funs body) ; Higher-order.
;; Continuations
(define-cps-type $cont k cont)
@ -188,13 +192,18 @@
(define-cps-type $void)
(define-cps-type $const val)
(define-cps-type $prim name)
(define-cps-type $fun free body)
(define-cps-type $fun free body) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
(define-cps-type $call proc args)
(define-cps-type $callk k proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
;; The root of a higher-order CPS term is $cont containing a $kfun. The
;; root of a first-order CPS term is a $program.
(define-cps-type $program funs)
(define label-counter (make-parameter #f))
(define var-counter (make-parameter #f))
@ -257,13 +266,14 @@
(define-syntax build-cps-exp
(syntax-rules (unquote
$void $const $prim $fun $call $callk $primcall $values $prompt)
$void $const $prim $fun $closure
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($fun free body))
(make-$fun free (build-cps-cont body)))
((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
@ -280,7 +290,7 @@
(make-$prompt escape? tag handler))))
(define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
(syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
((_ (unquote exp))
exp)
((_ ($letk (unquote conts) body))
@ -303,6 +313,12 @@
($const val))))))
((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term body)))
((_ ($program (unquote conts)))
(make-$program conts))
((_ ($program (cont ...)))
(make-$program (list (build-cps-cont cont) ...)))
((_ ($program conts))
(make-$program conts))
((_ ($continue k src exp))
(make-$continue k src (build-cps-exp exp)))))
@ -375,9 +391,13 @@
(build-cps-exp ($prim name)))
(('fun free body)
(build-cps-exp ($fun free ,(parse-cps body))))
(('closure k nfree)
(build-cps-exp ($closure k nfree)))
(('letrec ((name sym fun) ...) body)
(build-cps-term
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont))))
(('call proc arg ...)
(build-cps-exp ($call proc arg)))
(('callk k proc arg ...)
@ -432,11 +452,15 @@
`(prim ,name))
(($ $fun free body)
`(fun ,free ,(unparse-cps body)))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
names syms funs)
,(unparse-cps body)))
(($ $program conts)
`(program ,(map unparse-cps conts)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
@ -541,6 +565,8 @@
(cont-folder tail seed ...))))))
(define (compute-max-label-and-var fun)
(match fun
(($ $cont)
((make-global-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
@ -556,6 +582,28 @@
(max self max-var))
(_ max-var))))
fun -1 -1))
(($ $program conts)
(define (fold/2 proc in s0 s1)
(if (null? in)
(values s0 s1)
(let-values (((s0 s1) (proc (car in) s0 s1)))
(fold/2 proc (cdr in) s0 s1))))
(let lp ((conts conts) (max-label -1) (max-var -1))
(if (null? conts)
(values max-label max-var)
(call-with-values (lambda ()
((make-local-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars body)
(fold max max-var vars))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
(car conts) max-label max-var))
(lambda (max-label max-var)
(lp (cdr conts) max-label max-var))))))))
(define (fold-conts proc seed fun)
((make-global-cont-folder seed) proc fun seed))

327
module/language/cps/closure-conversion.scm
View file

@ -34,249 +34,226 @@
#:use-module ((srfi srfi-1) #:select (fold
lset-union lset-difference
list-index))
#:use-module (ice-9 receive)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:export (convert-closures))
(define (union s1 s2)
(lset-union eq? s1 s2))
;; free := var ...
(define (difference s1 s2)
(lset-difference eq? s1 s2))
;; bound := sym ...
;; free := sym ...
(define (convert-free-var sym self bound k)
(define (convert-free-var var self free k)
"Convert one possibly free variable reference to a bound reference.
If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
If @var{var} is free (i.e., present in @var{free},), it is replaced
by a closure reference via a @code{free-ref} primcall, and @var{k} is
called with the new var. Otherwise @var{sym} is bound, so @var{k} is
called with @var{sym}.
called with the new var. Otherwise @var{var} is bound, so @var{k} is
called with @var{var}."
(cond
((list-index (cut eq? <> var) free)
=> (lambda (free-idx)
(let-fresh (k* kidx) (idx var*)
(build-cps-term
($letk ((kidx ($kargs ('idx) (idx)
($letk ((k* ($kargs (var*) (var*) ,(k var*))))
($continue k* #f
($primcall 'free-ref (self idx)))))))
($continue kidx #f ($const free-idx)))))))
(else (k var))))
@var{k} should return two values: a term and a list of additional free
values in the term."
(if (memq sym bound)
(k sym)
(let-fresh (k*) (sym*)
(receive (exp free) (k sym*)
(values (build-cps-term
($letk ((k* ($kargs (sym*) (sym*) ,exp)))
($continue k* #f ($primcall 'free-ref (self sym)))))
(cons sym free))))))
(define (convert-free-vars syms self bound k)
(define (convert-free-vars vars self free k)
"Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return two
values: the term and a list of additional free variables in the term."
(match syms
@var{k} is called with the bound references, and should return the
term."
(match vars
(() (k '()))
((sym . syms)
(convert-free-var sym self bound
(lambda (sym)
(convert-free-vars syms self bound
(lambda (syms)
(k (cons sym syms)))))))))
((var . vars)
(convert-free-var var self free
(lambda (var)
(convert-free-vars vars self free
(lambda (vars)
(k (cons var vars)))))))))
(define (init-closure src v free outer-self outer-bound body)
(define (init-closure src v free outer-self outer-free body)
"Initialize the free variables @var{free} in a closure bound to
@var{v}, and continue with @var{body}. @var{outer-self} must be the
label of the outer procedure, where the initialization will be
performed, and @var{outer-bound} is the list of bound variables there."
performed, and @var{outer-free} is the list of free variables there."
(fold (lambda (free idx body)
(let-fresh (k) (idxsym)
(let-fresh (k) (idxvar)
(build-cps-term
($letk ((k ($kargs () () ,body)))
,(convert-free-var
free outer-self outer-bound
free outer-self outer-free
(lambda (free)
(values (build-cps-term
($letconst (('idx idxsym idx))
($letconst (('idx idxvar idx))
($continue k src
($primcall 'free-set! (v idxsym free)))))
($primcall 'free-set! (v idxvar free)))))
'())))))))
body
free
(iota (length free))))
(define (cc* exps self bound)
"Convert all free references in the list of expressions @var{exps} to
bound references, and convert functions to flat closures. Returns two
values: the transformed list, and a cumulative set of free variables."
(let lp ((exps exps) (exps* '()) (free '()))
(match exps
(() (values (reverse exps*) free))
((exp . exps)
(receive (exp* free*) (cc exp self bound)
(lp exps (cons exp* exps*) (union free free*)))))))
;; Closure conversion.
(define (cc exp self bound)
"Convert all free references in @var{exp} to bound references, and
convert functions to flat closures."
(match exp
(define (compute-free-vars exp)
"Compute the set of free variables for all $fun instances in
@var{exp}."
(let ((table (make-hash-table)))
(define (union a b)
(lset-union eq? a b))
(define (difference a b)
(lset-difference eq? a b))
(define (visit-cont cont bound)
(match cont
(($ $cont label ($ $kargs names vars body))
(visit-term body (append vars bound)))
(($ $cont label ($ $kfun src meta self tail clause))
(let ((free (if clause
(visit-cont clause (list self))
'())))
(hashq-set! table label (cons free cont))
(difference free bound)))
(($ $cont label ($ $kclause arity body alternate))
(let ((free (visit-cont body bound)))
(if alternate
(union (visit-cont alternate bound) free)
free)))
(($ $cont) '())))
(define (visit-term term bound)
(match term
(($ $letk conts body)
(receive (conts free) (cc* conts self bound)
(receive (body free*) (cc body self bound)
(values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
(fold (lambda (cont free)
(union (visit-cont cont bound) free))
(visit-term body bound)
conts))
(($ $letrec names vars (($ $fun () cont) ...) body)
(let ((bound (append vars bound)))
(fold (lambda (cont free)
(union (visit-cont cont bound) free))
(visit-term body bound)
cont)))
(($ $continue k src ($ $fun () body))
(visit-cont body bound))
(($ $continue k src exp)
(visit-exp exp bound))))
(define (visit-exp exp bound)
(define (adjoin var free)
(if (or (memq var bound) (memq var free))
free
(cons var free)))
(match exp
((or ($ $void) ($ $const) ($ $prim)) '())
(($ $call proc args)
(fold adjoin (adjoin proc '()) args))
(($ $callk k* proc args)
(fold adjoin (adjoin proc '()) args))
(($ $primcall name args)
(fold adjoin '() args))
(($ $values args)
(fold adjoin '() args))
(($ $prompt escape? tag handler)
(adjoin tag '()))))
(($ $cont sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
(values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
(let ((free (visit-cont exp '())))
(unless (null? free)
(error "Expected no free vars in toplevel thunk" free exp))
table)))
(($ $cont sym ($ $kfun src meta self tail clause))
(receive (clause free) (if clause
(cc clause self (list self))
(values #f '()))
(values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
free)))
(($ $cont sym ($ $kclause arity body alternate))
(receive (body free) (cc body self bound)
(receive (alternate free*) (if alternate
(cc alternate self bound)
(values #f '()))
(values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
(union free free*)))))
(($ $cont)
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(values exp '()))
(define (convert-one label table)
(match (hashq-ref table label)
((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont) ,cont)))
(define (visit-term term)
(match term
(($ $letk conts body)
(build-cps-term
($letk ,(map visit-cont conts) ,(visit-term body))))
;; Remove letrec.
(($ $letrec names syms funs body)
(let ((bound (append bound syms)))
(receive (body free) (cc body self bound)
(let lp ((in (map list names syms funs))
(($ $letrec names vars funs body)
(let lp ((in (map list names vars funs))
(bindings (lambda (body) body))
(body body)
(free free))
(body (visit-term body)))
(match in
(() (values (bindings body) free))
(((name sym ($ $fun () (and fun-body
($ $cont _ ($ $kfun src))))) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(() (bindings body))
(((name var ($ $fun ()
(and fun-body
($ $cont kfun ($ $kfun src))))) . in)
(match (hashq-ref table kfun)
((fun-free . _)
(lp in
(lambda (body)
(let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (sym) ,(bindings body))))
($letk ((k ($kargs (name) (var) ,(bindings body))))
($continue k src
($fun fun-free ,fun-body))))))
(init-closure src sym fun-free self bound body)
(union free (difference fun-free bound))))))))))
($closure kfun (length fun-free)))))))
(init-closure src var fun-free self free body))))))))
(($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
term)
(($ $continue k src ($ $fun () body))
(receive (body free) (cc body #f '())
(match free
(()
(values (build-cps-term
($continue k src ($fun free ,body)))
free))
(_
(values
(($ $continue k src ($ $fun () ($ $cont kfun)))
(match (hashq-ref table kfun)
((() . _)
(build-cps-term ($continue k src ($closure kfun 0))))
((fun-free . _)
(let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
src v free self bound
src v fun-free self free
(build-cps-term
($continue k src ($values (v))))))))
($continue kinit src ($fun free ,body)))))
(difference free bound))))))
($continue kinit src
($closure kfun (length fun-free)))))))))
(($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(convert-free-vars (cons proc args) self free
(match-lambda
((proc . args)
(values (build-cps-term
($continue k src ($call proc args)))
'())))))
(build-cps-term
($continue k src ($call proc args)))))))
(($ $continue k src ($ $callk k* proc args))
(convert-free-vars (cons proc args) self bound
(convert-free-vars (cons proc args) self free
(match-lambda
((proc . args)
(values (build-cps-term
($continue k src ($callk k* proc args)))
'())))))
(build-cps-term
($continue k src ($callk k* proc args)))))))
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(convert-free-vars args self free
(lambda (args)
(values (build-cps-term
($continue k src ($primcall name args)))
'()))))
(build-cps-term
($continue k src ($primcall name args))))))
(($ $continue k src ($ $values args))
(convert-free-vars args self bound
(convert-free-vars args self free
(lambda (args)
(values (build-cps-term
($continue k src ($values args)))
'()))))
(build-cps-term
($continue k src ($values args))))))
(($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var
tag self bound
(convert-free-var tag self free
(lambda (tag)
(values (build-cps-term
($continue k src ($prompt escape? tag handler)))
'()))))
(_ (error "what" exp))))
;; Convert the slot arguments of 'free-ref' primcalls from symbols to
;; indices.
(define (convert-to-indices body free)
(define (free-index sym)
(or (list-index (cut eq? <> sym) free)
(error "free variable not found!" sym free)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
,(let-fresh () (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
($continue k src ($primcall 'free-ref (closure idx)))))))
(($ $continue k src ($ $fun free body))
($continue k src
($fun free ,(convert-to-indices body free))))
(($ $continue)
,term)))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(($ $cont)
,cont)))
(rewrite-cps-cont body
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
($prompt escape? tag handler))))))))
(visit-cont fun))))
(define (convert-closures fun)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(with-fresh-name-state fun
(receive (body free) (cc fun #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" fun body free))
(convert-to-indices body free))))
(let* ((table (compute-free-vars fun))
(labels (sort (hash-map->list (lambda (k v) k) table) <)))
(build-cps-term
($program ,(map (cut convert-one <> table) labels))))))

41
module/language/cps/compile-bytecode.scm
View file

@ -245,10 +245,10 @@
(emit-load-constant asm dst *unspecified*))
(($ $const exp)
(emit-load-constant asm dst exp))
(($ $fun () ($ $cont k))
(($ $closure k 0)
(emit-load-static-procedure asm dst k))
(($ $fun free ($ $cont k))
(emit-make-closure asm dst k (length free)))
(($ $closure k nfree)
(emit-make-closure asm dst k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
@ -474,43 +474,18 @@
(($ $cont k ($ $kfun src meta self tail clause))
(compile-entry)))))
(define (visit-funs proc exp)
(match exp
(($ $continue _ _ exp)
(visit-funs proc exp))
(($ $fun free body)
(visit-funs proc body))
(($ $letk conts body)
(visit-funs proc body)
(for-each (lambda (cont) (visit-funs proc cont)) conts))
(($ $cont sym ($ $kargs names syms body))
(visit-funs proc body))
(($ $cont sym ($ $kclause arity body alternate))
(visit-funs proc body)
(when alternate
(visit-funs proc alternate)))
(($ $cont sym ($ $kfun src meta self tail clause))
(proc exp)
(when clause
(visit-funs proc clause)))
(_ (values))))
(define (compile-bytecode exp env opts)
(let* ((exp (fix-arities exp))
(exp (optimize exp opts))
(exp (convert-closures exp))
;; first-order optimization should go here
(exp (reify-primitives exp))
(exp (renumber exp))
(asm (make-assembler)))
(visit-funs (lambda (fun)
(compile-fun fun asm))
exp)
(match exp
(($ $program funs)
(for-each (lambda (fun) (compile-fun fun asm))
funs)))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))

2
module/language/cps/dfg.scm
View file

@ -851,7 +851,7 @@ body continuation in the prompt."
(define (use! sym)
(add-use! sym label))
(match exp
((or ($ $void) ($ $const) ($ $prim)) #f)
((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
(($ $call proc args)
(use! proc)
(for-each use! args))

83
module/language/cps/reify-primitives.scm
View file

@ -33,16 +33,16 @@
#:export (reify-primitives))
(define (module-box src module name public? bound? val-proc)
(let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(let-fresh (kbox) (module-var name-var public?-var bound?-var box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
($letconst (('module module-var module)
('name name-var name)
('public? public?-var public?)
('bound? bound?-var bound?))
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
(module-var name-var public?-var bound?-var))))))))
(define (primitive-module name)
(case name
@ -81,11 +81,11 @@
($continue k src ($primcall 'box-ref (box)))))))
(define (builtin-ref idx k src)
(let-fresh () (idx-sym)
(let-fresh () (idx-var)
(build-cps-term
($letconst (('idx idx-sym idx))
($letconst (('idx idx-var idx))
($continue k src
($primcall 'builtin-ref (idx-sym)))))))
($primcall 'builtin-ref (idx-var)))))))
(define (reify-clause ktail)
(let-fresh (kclause kbody kthrow) (wna false str eol throw)
@ -105,45 +105,40 @@
,(primitive-ref 'throw kthrow #f)))))
,#f)))))
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(with-fresh-name-state fun
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
(rewrite-cps-exp term
(($ $fun free body)
($fun free ,(visit-cont body)))))
(define (reify-primitives/1 fun single-value-conts)
(define (visit-clause cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-clause alternate)))))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
;; A case-lambda with no clauses. Reify a clause.
(sym ($kfun src meta self ,tail ,(reify-clause ktail))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(visit-cont clause))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont label ($ $kargs (name) (var) body))
,(begin
(bitvector-set! single-value-conts label #t)
(build-cps-cont
(label ($kargs (name) (var) ,(visit-term body))))))
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(match term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
;; Visit continuations before their uses.
(let ((conts (map visit-cont conts)))
(build-cps-term
($letk ,conts ,(visit-term body)))))
(($ $continue k src exp)
,(match exp
(match exp
(($ $prim name)
(match (vector-ref conts k)
(($ $kargs (_))
(if (bitvector-ref single-value-conts k)
(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k src)))
(else (primitive-ref name k src))))
(_ (build-cps-term ($continue k src ($void))))))
(($ $fun)
(build-cps-term ($continue k src ,(visit-fun exp))))
(else (primitive-ref name k src)))
(build-cps-term ($continue k src ($void)))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
@ -164,4 +159,18 @@
(else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-cont fun))))
(rewrite-cps-cont fun
(($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
;; A case-lambda with no clauses. Reify a clause.
(label ($kfun src meta self ,tail ,(reify-clause ktail))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail ,(visit-clause clause))))))
(define (reify-primitives term)
(with-fresh-name-state term
(let ((single-value-conts (make-bitvector (label-counter) #f)))
(rewrite-cps-term term
(($ $program procs)
($program ,(map (lambda (cont)
(reify-primitives/1 cont single-value-conts))
procs)))))))

25
module/language/cps/renumber.scm
View file

@ -169,19 +169,19 @@
(set! queue (cons body queue))))
(($ $continue) #f)))
(collect-conts fun)
(match fun
(($ $cont kfun)
(collect-conts fun)
(set! next-label (sort-conts kfun labels next-label))
(visit-cont fun)
(for-each compute-names-in-fun (reverse queue)))))
(for-each compute-names-in-fun (reverse queue)))
(($ $program conts)
(for-each compute-names-in-fun conts))))
(compute-names-in-fun fun)
(values labels vars next-label next-var)))))
(define (renumber fun)
(call-with-values (lambda () (compute-new-labels-and-vars fun))
(lambda (labels vars nlabels nvars)
(define (apply-renumbering term labels vars)
(define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
@ -243,6 +243,8 @@
(match exp
((or ($ $void) ($ $const) ($ $prim))
exp)
(($ $closure k nfree)
(build-cps-exp ($closure (relabel k) nfree)))
(($ $fun)
(visit-fun exp))
(($ $values args)
@ -264,4 +266,15 @@
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(values (must-visit-cont fun) nlabels nvars))))
(match term
(($ $cont)
(must-visit-cont term))
(($ $program conts)
(build-cps-term
($program ,(map must-visit-cont conts))))))
(define (renumber term)
(call-with-values (lambda () (compute-new-labels-and-vars term))
(lambda (labels vars nlabels nvars)
(values (apply-renumbering term labels vars) nlabels nvars))))

2
module/language/cps/slot-allocation.scm
View file

@ -442,7 +442,7 @@ are comparable with eqv?. A tmp slot may be used."
;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions.
(match (find-expression body)
((or ($ $void) ($ $const) ($ $prim) ($ $fun)
((or ($ $void) ($ $const) ($ $prim) ($ $closure)
($ $primcall) ($ $prompt)
;; If $values has more than one argument, it may
;; use a temporary, which would invalidate our