From b85f5f851fce230d16f3c13c371839f7e619059f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 11 Apr 2014 11:51:34 +0200 Subject: [PATCH] Closure conversion, reify-primitives use $kfun $cont * 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. --- module/language/cps/closure-conversion.scm | 3 +- module/language/cps/compile-bytecode.scm | 7 +- module/language/cps/reify-primitives.scm | 114 ++++++++++----------- 3 files changed, 60 insertions(+), 64 deletions(-) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 85bf30ec9..151448ea0 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -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)))))) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 8aec1d690..20414a7b0 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 6a4bea058..50d1db801 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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))))