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 '()) (receive (body free) (cc body #f '())
(unless (null? free) (unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free)) (error "Expected no free vars in toplevel thunk" exp body free))
(build-cps-exp (convert-to-indices body free))))))
($fun free ,(convert-to-indices body free))))))))

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

@ -506,13 +506,12 @@
(exp (optimize exp opts)) (exp (optimize exp opts))
(exp (convert-closures exp)) (exp (convert-closures exp))
(exp (reify-primitives exp)) (exp (reify-primitives exp))
(exp (renumber exp)) (exp (match (renumber (build-cps-exp ($fun '() ,exp)))
(($ $fun free body) body)))
(asm (make-assembler))) (asm (make-assembler)))
(visit-funs (lambda (fun) (visit-funs (lambda (fun)
(compile-fun fun asm)) (compile-fun fun asm))
(match exp exp)
(($ $fun free body)
body)))
(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)))

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

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