From 686a6490f4cfa368be13b4ca7d4661ae1577384a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 11 Apr 2014 10:12:37 +0200 Subject: [PATCH] Function defined by make-cont-folder takes a cont, not a $fun * module/language/cps.scm (make-cont-folder): Take a cont instead of a $fun. (with-fresh-name-state): Adapt. * module/language/cps/cse.scm (compute-label-and-var-ranges): * module/language/cps/dce.scm (compute-live-code): * module/language/cps/dfg.scm (compute-dfg): * module/language/cps/elide-values.scm (elide-values): * module/language/cps/reify-primitives.scm (reify-primitives): * module/language/cps/renumber.scm (compute-new-labels-and-vars): (renumber): Adapt. --- module/language/cps.scm | 8 +- module/language/cps/cse.scm | 4 +- module/language/cps/dce.scm | 10 +- module/language/cps/dfg.scm | 36 ++--- module/language/cps/elide-values.scm | 8 +- module/language/cps/reify-primitives.scm | 114 ++++++++------- module/language/cps/renumber.scm | 177 ++++++++++++----------- 7 files changed, 186 insertions(+), 171 deletions(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index 056a71f29..e6cb3cbd6 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -216,7 +216,9 @@ (define-syntax-rule (with-fresh-name-state fun body ...) (call-with-values (lambda () - (compute-max-label-and-var fun)) + (match fun + (($ $fun free fun-k) + (compute-max-label-and-var fun-k)))) (lambda (max-label max-var) (parameterize ((label-counter (1+ max-label)) (var-counter (1+ max-var))) @@ -451,7 +453,7 @@ (error "unexpected cps" exp)))) (define-syntax-rule (make-cont-folder global? seed ...) - (lambda (proc fun seed ...) + (lambda (proc cont seed ...) (define (fold-values proc in seed ...) (if (null? in) (values seed ...) @@ -505,7 +507,7 @@ (fold-values fun-folder funs seed ...) (values seed ...)))))) - (fun-folder fun seed ...))) + (cont-folder cont seed ...))) (define (compute-max-label-and-var fun) ((make-cont-folder #t max-label max-var) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 9ce49756b..5b97c59c2 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -229,7 +229,7 @@ be that both true and false proofs are available." (define (compute-label-and-var-ranges fun) (match fun - (($ $fun free ($ $cont kfun ($ $kfun src meta self))) + (($ $fun free (and body ($ $cont kfun ($ $kfun src meta self)))) ((make-cont-folder #f min-label label-count min-var var-count) (lambda (k cont min-label label-count min-var var-count) (let ((min-label (min k min-label)) @@ -250,7 +250,7 @@ be that both true and false proofs are available." (values min-label label-count (min self min-var) (1+ var-count))) (_ (values min-label label-count min-var var-count))))) - fun kfun 0 self 0)))) + body kfun 0 self 0)))) (define (compute-idoms dfg min-label label-count) (define (label->idx label) (- label min-label)) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 73ae7e379..6c96fde52 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -90,10 +90,12 @@ (define (ensure-fun-data fun) (or (hashq-ref fun-data-table fun) (call-with-values (lambda () - ((make-cont-folder #f label-count max-label) - (lambda (k cont label-count max-label) - (values (1+ label-count) (max k max-label))) - fun 0 -1)) + (match fun + (($ $fun free body) + ((make-cont-folder #f label-count max-label) + (lambda (k cont label-count max-label) + (values (1+ label-count) (max k max-label))) + body 0 -1)))) (lambda (label-count max-label) (let* ((min-label (- (1+ max-label) label-count)) (effects (compute-effects dfg min-label label-count)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index a3d6b5a77..816a8dc57 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -895,23 +895,25 @@ body continuation in the prompt." (do-fold #f))) (define* (compute-dfg fun #:key (global? #t)) - (call-with-values (lambda () (compute-label-and-var-ranges fun global?)) - (lambda (min-label max-label label-count min-var max-var var-count) - (when (or (zero? label-count) (zero? var-count)) - (error "internal error (no vars or labels for fun?)")) - (let* ((nlabels (- (1+ max-label) min-label)) - (nvars (- (1+ max-var) min-var)) - (conts (make-vector nlabels #f)) - (preds (make-vector nlabels '())) - (defs (make-vector nvars #f)) - (uses (make-vector nvars '())) - (scopes (make-vector nlabels #f)) - (scope-levels (make-vector nlabels #f))) - (visit-fun fun conts preds defs uses scopes scope-levels - min-label min-var global?) - (make-dfg conts preds defs uses scopes scope-levels - min-label max-label label-count - min-var max-var var-count))))) + (match fun + (($ $fun free body) + (call-with-values (lambda () (compute-label-and-var-ranges body global?)) + (lambda (min-label max-label label-count min-var max-var var-count) + (when (or (zero? label-count) (zero? var-count)) + (error "internal error (no vars or labels for fun?)")) + (let* ((nlabels (- (1+ max-label) min-label)) + (nvars (- (1+ max-var) min-var)) + (conts (make-vector nlabels #f)) + (preds (make-vector nlabels '())) + (defs (make-vector nvars #f)) + (uses (make-vector nvars '())) + (scopes (make-vector nlabels #f)) + (scope-levels (make-vector nlabels #f))) + (visit-fun fun conts preds defs uses scopes scope-levels + min-label min-var global?) + (make-dfg conts preds defs uses scopes scope-levels + min-label max-label label-count + min-var max-var var-count))))))) (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...) (parameterize ((label-counter (1+ (dfg-max-label dfg))) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm index e75aa9840..754bcc7c6 100644 --- a/module/language/cps/elide-values.scm +++ b/module/language/cps/elide-values.scm @@ -103,6 +103,8 @@ ($fun free ,(visit-cont body))))) (define (elide-values fun) - (with-fresh-name-state fun - (let ((conts (build-cont-table fun))) - (elide-values* fun conts)))) + (match fun + (($ $fun free funk) + (with-fresh-name-state fun + (let ((conts (build-cont-table funk))) + (elide-values* fun conts)))))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 3c5e5bcd3..c34d6c600 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -107,61 +107,63 @@ ;; 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 (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 (_)) + (match fun + (($ $fun free body) + (with-fresh-name-state fun + (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) (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 - ((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))))) + ((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-fun fun)))))) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index 1415f8cc7..217d6b0d7 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -74,7 +74,10 @@ (lp (1+ n) next)))))) (define (compute-new-labels-and-vars fun) - (call-with-values (lambda () (compute-max-label-and-var fun)) + (call-with-values (lambda () + (match fun + (($ $fun free body) + (compute-max-label-and-var body)))) (lambda (max-label max-var) (let ((labels (make-vector (1+ max-label) #f)) (next-label 0) @@ -177,88 +180,90 @@ (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 (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) - (($ $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 (visit-fun fun) nlabels nvars)))) + (match fun + (($ $fun free cont) + (call-with-values (lambda () (compute-new-labels-and-vars fun)) + (lambda (labels vars nlabels nvars) + (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) + (($ $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 (visit-fun fun) nlabels nvars))))))