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

94
module/language/cps.scm
View file

@ -122,7 +122,11 @@
$kif $kreceive $kargs $kfun $ktail $kclause $kif $kreceive $kargs $kfun $ktail $kclause
;; Expressions. ;; 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. ;; Fresh names.
label-counter var-counter label-counter var-counter
@ -173,7 +177,7 @@
;; Terms. ;; Terms.
(define-cps-type $letk conts body) (define-cps-type $letk conts body)
(define-cps-type $continue k src exp) (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 ;; Continuations
(define-cps-type $cont k cont) (define-cps-type $cont k cont)
@ -188,13 +192,18 @@
(define-cps-type $void) (define-cps-type $void)
(define-cps-type $const val) (define-cps-type $const val)
(define-cps-type $prim name) (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 $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 $primcall name args)
(define-cps-type $values args) (define-cps-type $values args)
(define-cps-type $prompt escape? tag handler) (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 label-counter (make-parameter #f))
(define var-counter (make-parameter #f)) (define var-counter (make-parameter #f))
@ -257,13 +266,14 @@
(define-syntax build-cps-exp (define-syntax build-cps-exp
(syntax-rules (unquote (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) ((_ (unquote exp)) exp)
((_ ($void)) (make-$void)) ((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name)) ((_ ($prim name)) (make-$prim name))
((_ ($fun free body)) ((_ ($fun free body)) (make-$fun free (build-cps-cont 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 (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args)) ((_ ($call proc args)) (make-$call proc args))
@ -280,7 +290,7 @@
(make-$prompt escape? tag handler)))) (make-$prompt escape? tag handler))))
(define-syntax build-cps-term (define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue) (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
((_ (unquote exp)) ((_ (unquote exp))
exp) exp)
((_ ($letk (unquote conts) body)) ((_ ($letk (unquote conts) body))
@ -303,6 +313,12 @@
($const val)))))) ($const val))))))
((_ ($letrec names gensyms funs body)) ((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term 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)) ((_ ($continue k src exp))
(make-$continue k src (build-cps-exp exp))))) (make-$continue k src (build-cps-exp exp)))))
@ -375,9 +391,13 @@
(build-cps-exp ($prim name))) (build-cps-exp ($prim name)))
(('fun free body) (('fun free body)
(build-cps-exp ($fun free ,(parse-cps body)))) (build-cps-exp ($fun free ,(parse-cps body))))
(('closure k nfree)
(build-cps-exp ($closure k nfree)))
(('letrec ((name sym fun) ...) body) (('letrec ((name sym fun) ...) body)
(build-cps-term (build-cps-term
($letrec name sym (map parse-cps fun) ,(parse-cps body)))) ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont))))
(('call proc arg ...) (('call proc arg ...)
(build-cps-exp ($call proc arg))) (build-cps-exp ($call proc arg)))
(('callk k proc arg ...) (('callk k proc arg ...)
@ -432,11 +452,15 @@
`(prim ,name)) `(prim ,name))
(($ $fun free body) (($ $fun free body)
`(fun ,free ,(unparse-cps body))) `(fun ,free ,(unparse-cps body)))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun) `(letrec ,(map (lambda (name sym fun)
(list name sym (unparse-cps fun))) (list name sym (unparse-cps fun)))
names syms funs) names syms funs)
,(unparse-cps body))) ,(unparse-cps body)))
(($ $program conts)
`(program ,(map unparse-cps conts)))
(($ $call proc args) (($ $call proc args)
`(call ,proc ,@args)) `(call ,proc ,@args))
(($ $callk k proc args) (($ $callk k proc args)
@ -541,21 +565,45 @@
(cont-folder tail seed ...)))))) (cont-folder tail seed ...))))))
(define (compute-max-label-and-var fun) (define (compute-max-label-and-var fun)
((make-global-cont-folder max-label max-var) (match fun
(lambda (label cont max-label max-var) (($ $cont)
(values (max label max-label) ((make-global-cont-folder max-label max-var)
(match cont (lambda (label cont max-label max-var)
(($ $kargs names vars body) (values (max label max-label)
(let lp ((body body) (max-var (fold max max-var vars))) (match cont
(match body (($ $kargs names vars body)
(($ $letk conts body) (lp body max-var)) (let lp ((body body) (max-var (fold max max-var vars)))
(($ $letrec names vars funs body) (match body
(lp body (fold max max-var vars))) (($ $letk conts body) (lp body max-var))
(_ max-var)))) (($ $letrec names vars funs body)
(($ $kfun src meta self) (lp body (fold max max-var vars)))
(max self max-var)) (_ max-var))))
(_ max-var)))) (($ $kfun src meta self)
fun -1 -1)) (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) (define (fold-conts proc seed fun)
((make-global-cont-folder seed) proc fun seed)) ((make-global-cont-folder seed) proc fun seed))

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

@ -34,249 +34,226 @@
#:use-module ((srfi srfi-1) #:select (fold #:use-module ((srfi srfi-1) #:select (fold
lset-union lset-difference lset-union lset-difference
list-index)) list-index))
#:use-module (ice-9 receive)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (language cps) #:use-module (language cps)
#:export (convert-closures)) #:export (convert-closures))
(define (union s1 s2) ;; free := var ...
(lset-union eq? s1 s2))
(define (difference s1 s2) (define (convert-free-var var self free k)
(lset-difference eq? s1 s2))
;; bound := sym ...
;; free := sym ...
(define (convert-free-var sym self bound k)
"Convert one possibly free variable reference to a bound reference. "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 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 the new var. Otherwise @var{var} is bound, so @var{k} is
called with @var{sym}. called with @var{var}."
(cond
@var{k} should return two values: a term and a list of additional free ((list-index (cut eq? <> var) free)
values in the term." => (lambda (free-idx)
(if (memq sym bound) (let-fresh (k* kidx) (idx var*)
(k sym) (build-cps-term
(let-fresh (k*) (sym*) ($letk ((kidx ($kargs ('idx) (idx)
(receive (exp free) (k sym*) ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
(values (build-cps-term ($continue k* #f
($letk ((k* ($kargs (sym*) (sym*) ,exp))) ($primcall 'free-ref (self idx)))))))
($continue k* #f ($primcall 'free-ref (self sym))))) ($continue kidx #f ($const free-idx)))))))
(cons sym free)))))) (else (k var))))
(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. "Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return two @var{k} is called with the bound references, and should return the
values: the term and a list of additional free variables in the term." term."
(match syms (match vars
(() (k '())) (() (k '()))
((sym . syms) ((var . vars)
(convert-free-var sym self bound (convert-free-var var self free
(lambda (sym) (lambda (var)
(convert-free-vars syms self bound (convert-free-vars vars self free
(lambda (syms) (lambda (vars)
(k (cons sym syms))))))))) (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 "Initialize the free variables @var{free} in a closure bound to
@var{v}, and continue with @var{body}. @var{outer-self} must be the @var{v}, and continue with @var{body}. @var{outer-self} must be the
label of the outer procedure, where the initialization will be 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) (fold (lambda (free idx body)
(let-fresh (k) (idxsym) (let-fresh (k) (idxvar)
(build-cps-term (build-cps-term
($letk ((k ($kargs () () ,body))) ($letk ((k ($kargs () () ,body)))
,(convert-free-var ,(convert-free-var
free outer-self outer-bound free outer-self outer-free
(lambda (free) (lambda (free)
(values (build-cps-term (values (build-cps-term
($letconst (('idx idxsym idx)) ($letconst (('idx idxvar idx))
($continue k src ($continue k src
($primcall 'free-set! (v idxsym free))))) ($primcall 'free-set! (v idxvar free)))))
'()))))))) '())))))))
body body
free free
(iota (length free)))) (iota (length free))))
(define (cc* exps self bound) (define (compute-free-vars exp)
"Convert all free references in the list of expressions @var{exps} to "Compute the set of free variables for all $fun instances in
bound references, and convert functions to flat closures. Returns two @var{exp}."
values: the transformed list, and a cumulative set of free variables." (let ((table (make-hash-table)))
(let lp ((exps exps) (exps* '()) (free '())) (define (union a b)
(match exps (lset-union eq? a b))
(() (values (reverse exps*) free)) (define (difference a b)
((exp . exps) (lset-difference eq? a b))
(receive (exp* free*) (cc exp self bound) (define (visit-cont cont bound)
(lp exps (cons exp* exps*) (union free free*))))))) (match cont
(($ $cont label ($ $kargs names vars body))
;; Closure conversion. (visit-term body (append vars bound)))
(define (cc exp self bound) (($ $cont label ($ $kfun src meta self tail clause))
"Convert all free references in @var{exp} to bound references, and (let ((free (if clause
convert functions to flat closures." (visit-cont clause (list self))
(match exp '())))
(($ $letk conts body) (hashq-set! table label (cons free cont))
(receive (conts free) (cc* conts self bound) (difference free bound)))
(receive (body free*) (cc body self bound) (($ $cont label ($ $kclause arity body alternate))
(values (build-cps-term ($letk ,conts ,body)) (let ((free (visit-cont body bound)))
(union free free*))))) (if alternate
(union (visit-cont alternate bound) free)
(($ $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))) free)))
(($ $cont) '())))
(define (visit-term term bound)
(match term
(($ $letk conts body)
(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 ($ $kfun src meta self tail clause)) (let ((free (visit-cont exp '())))
(receive (clause free) (if clause (unless (null? free)
(cc clause self (list self)) (error "Expected no free vars in toplevel thunk" free exp))
(values #f '())) table)))
(values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
free)))
(($ $cont sym ($ $kclause arity body alternate)) (define (convert-one label table)
(receive (body free) (cc body self bound) (match (hashq-ref table label)
(receive (alternate free*) (if alternate ((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
(cc alternate self bound) (define (visit-cont cont)
(values #f '())) (rewrite-cps-cont cont
(values (build-cps-cont (sym ($kclause ,arity ,body ,alternate))) (($ $cont label ($ $kargs names vars body))
(union free free*))))) (label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kfun src meta self tail clause))
(($ $cont) (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
;; Other kinds of continuations don't bind values and don't have (($ $cont label ($ $kclause arity body alternate))
;; bodies. (label ($kclause ,arity ,(visit-cont body)
(values exp '())) ,(and alternate (visit-cont alternate)))))
(($ $cont) ,cont)))
;; Remove letrec. (define (visit-term term)
(($ $letrec names syms funs body) (match term
(let ((bound (append bound syms))) (($ $letk conts body)
(receive (body free) (cc body self bound)
(let lp ((in (map list names syms funs))
(bindings (lambda (body) body))
(body body)
(free free))
(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 '())
(lp in
(lambda (body)
(let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (sym) ,(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))))))))))
(($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
(($ $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
(let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
src v free self bound
(build-cps-term
($continue k src ($values (v))))))))
($continue kinit src ($fun free ,body)))))
(difference free bound))))))
(($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
($continue k src ($call proc args)))
'())))))
(($ $continue k src ($ $callk k* proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
($continue k src ($callk k* proc args)))
'())))))
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
($continue k src ($primcall name args)))
'()))))
(($ $continue k src ($ $values args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
($continue k src ($values args)))
'()))))
(($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var
tag self bound
(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 (build-cps-term
($letconst (('idx idx (free-index sym))) ($letk ,(map visit-cont conts) ,(visit-term body))))
($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 ;; Remove letrec.
(($ $cont sym ($ $kfun src meta self tail clause)) (($ $letrec names vars funs body)
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))) (let lp ((in (map list names vars funs))
(bindings (lambda (body) body))
(body (visit-term body)))
(match in
(() (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) (var) ,(bindings body))))
($continue k src
($closure kfun (length fun-free)))))))
(init-closure src var fun-free self free body))))))))
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
term)
(($ $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 fun-free self free
(build-cps-term
($continue k src ($values (v))))))))
($continue kinit src
($closure kfun (length fun-free)))))))))
(($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self free
(match-lambda
((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 free
(match-lambda
((proc . args)
(build-cps-term
($continue k src ($callk k* proc args)))))))
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self free
(lambda (args)
(build-cps-term
($continue k src ($primcall name args))))))
(($ $continue k src ($ $values args))
(convert-free-vars args self free
(lambda (args)
(build-cps-term
($continue k src ($values args))))))
(($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var tag self free
(lambda (tag)
(build-cps-term
($continue k src
($prompt escape? tag handler))))))))
(visit-cont fun))))
(define (convert-closures fun) (define (convert-closures fun)
"Convert free reference in @var{exp} to primcalls to @code{free-ref}, "Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures." and allocate and initialize flat closures."
(with-fresh-name-state fun (with-fresh-name-state fun
(receive (body free) (cc fun #f '()) (let* ((table (compute-free-vars fun))
(unless (null? free) (labels (sort (hash-map->list (lambda (k v) k) table) <)))
(error "Expected no free vars in toplevel thunk" fun body free)) (build-cps-term
(convert-to-indices body free)))) ($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*)) (emit-load-constant asm dst *unspecified*))
(($ $const exp) (($ $const exp)
(emit-load-constant asm dst exp)) (emit-load-constant asm dst exp))
(($ $fun () ($ $cont k)) (($ $closure k 0)
(emit-load-static-procedure asm dst k)) (emit-load-static-procedure asm dst k))
(($ $fun free ($ $cont k)) (($ $closure k nfree)
(emit-make-closure asm dst k (length free))) (emit-make-closure asm dst k nfree))
(($ $primcall 'current-module) (($ $primcall 'current-module)
(emit-current-module asm dst)) (emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
@ -474,43 +474,18 @@
(($ $cont k ($ $kfun src meta self tail clause)) (($ $cont k ($ $kfun src meta self tail clause))
(compile-entry))))) (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) (define (compile-bytecode exp env opts)
(let* ((exp (fix-arities exp)) (let* ((exp (fix-arities exp))
(exp (optimize exp opts)) (exp (optimize exp opts))
(exp (convert-closures exp)) (exp (convert-closures exp))
;; first-order optimization should go here
(exp (reify-primitives exp)) (exp (reify-primitives exp))
(exp (renumber exp)) (exp (renumber exp))
(asm (make-assembler))) (asm (make-assembler)))
(visit-funs (lambda (fun) (match exp
(compile-fun fun asm)) (($ $program funs)
exp) (for-each (lambda (fun) (compile-fun fun asm))
funs)))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env env
env))) env)))

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

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

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

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

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

@ -169,99 +169,112 @@
(set! queue (cons body queue)))) (set! queue (cons body queue))))
(($ $continue) #f))) (($ $continue) #f)))
(collect-conts fun)
(match fun (match fun
(($ $cont kfun) (($ $cont kfun)
(collect-conts fun)
(set! next-label (sort-conts kfun labels next-label)) (set! next-label (sort-conts kfun labels next-label))
(visit-cont fun) (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) (compute-names-in-fun fun)
(values labels vars next-label next-var))))) (values labels vars next-label next-var)))))
(define (renumber fun) (define (apply-renumbering term labels vars)
(call-with-values (lambda () (compute-new-labels-and-vars fun)) (define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
(match arity
(($ $arity req opt rest kw aok?)
(make-$arity req opt rest
(map (match-lambda
((kw kw-name kw-var)
(list kw kw-name (rename kw-var))))
kw)
aok?))))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "internal error -- failed to visit cont")))
(define (visit-conts conts)
(match conts
(() '())
((cont . conts)
(cond
((visit-cont cont)
=> (lambda (cont)
(cons cont (visit-conts conts))))
(else (visit-conts conts))))))
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kfun src meta self tail clause)
(label
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))
(($ $kclause arity body alternate)
(label
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs))))
(($ $kif kt kf)
(label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
,(match (visit-conts conts)
(() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
(($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
(match exp
((or ($ $void) ($ $const) ($ $prim))
exp)
(($ $closure k nfree)
(build-cps-exp ($closure (relabel k) nfree)))
(($ $fun)
(visit-fun exp))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(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) (lambda (labels vars nlabels nvars)
(define (relabel label) (vector-ref labels label)) (values (apply-renumbering term labels vars) nlabels nvars))))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
(match arity
(($ $arity req opt rest kw aok?)
(make-$arity req opt rest
(map (match-lambda
((kw kw-name kw-var)
(list kw kw-name (rename kw-var))))
kw)
aok?))))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "internal error -- failed to visit cont")))
(define (visit-conts conts)
(match conts
(() '())
((cont . conts)
(cond
((visit-cont cont)
=> (lambda (cont)
(cons cont (visit-conts conts))))
(else (visit-conts conts))))))
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kfun src meta self tail clause)
(label
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))
(($ $kclause arity body alternate)
(label
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs))))
(($ $kif kt kf)
(label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
,(match (visit-conts conts)
(() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
(($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
(match exp
((or ($ $void) ($ $const) ($ $prim))
exp)
(($ $fun)
(visit-fun exp))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(values (must-visit-cont fun) 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 ;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions. ;; terminator, but leave its definitions.
(match (find-expression body) (match (find-expression body)
((or ($ $void) ($ $const) ($ $prim) ($ $fun) ((or ($ $void) ($ $const) ($ $prim) ($ $closure)
($ $primcall) ($ $prompt) ($ $primcall) ($ $prompt)
;; If $values has more than one argument, it may ;; If $values has more than one argument, it may
;; use a temporary, which would invalidate our ;; use a temporary, which would invalidate our