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

Closure conversion, reify-primitives use $kfun $cont

Browse source 
* module/language/cps/closure-conversion.scm: Produce a $kfun $cont.
* module/language/cps/reify-primitives.scm: Produce and consume $kfun
  $cont.
* module/language/cps/compile-bytecode.scm: Adapt.
This commit is contained in:
Andy Wingo 2014-04-11 11:51:34 +02:00
parent 6bc36ca55e
commit b85f5f851f
3 changed files with 60 additions and 64 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -281,5 +281,4 @@ and allocate and initialize flat closures."
(receive (body free) (cc body #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free))
(build-cps-exp
($fun free ,(convert-to-indices body free))))))))
(convert-to-indices body free))))))

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

@ -506,13 +506,12 @@
(exp (optimize exp opts))
(exp (convert-closures exp))
(exp (reify-primitives exp))
(exp (renumber exp))
(exp (match (renumber (build-cps-exp ($fun '() ,exp)))
(($ $fun free body) body)))
(asm (make-assembler)))
(visit-funs (lambda (fun)
(compile-fun fun asm))
(match exp
(($ $fun free body)
body)))
exp)
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))

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

@ -107,63 +107,61 @@
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(match fun
(($ $fun free body)
(with-fresh-name-state body
(let ((conts (build-cont-table body)))
(define (visit-fun term)
(rewrite-cps-exp term
(($ $fun free body)
($fun free ,(visit-cont body)))))
(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)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src exp)
,(match exp
(($ $prim name)
(match (vector-ref conts k)
(($ $kargs (_))
(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))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
(($ $primcall name args)
(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 (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)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src exp)
,(match exp
(($ $prim name)
(match (vector-ref conts k)
(($ $kargs (_))
(cond
((or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
term)
(else
(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k* src)))
(else (primitive-ref name k* src)))))))))
(_ term)))))
((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))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
term)
(else
(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k* src)))
(else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-fun fun))))))
(visit-cont fun))))