mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Function defined by make-cont-folder takes a cont, not a $fun

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-04-11 10:12:37 +02:00
parent 8320f50431
commit 686a6490f4
7 changed files with 186 additions and 171 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/language/cps.scm
View file

@ -216,7 +216,9 @@
(define-syntax-rule (with-fresh-name-state fun body ...) (define-syntax-rule (with-fresh-name-state fun body ...)
(call-with-values (lambda () (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) (lambda (max-label max-var)
(parameterize ((label-counter (1+ max-label)) (parameterize ((label-counter (1+ max-label))
(var-counter (1+ max-var))) (var-counter (1+ max-var)))
@ -451,7 +453,7 @@
(error "unexpected cps" exp)))) (error "unexpected cps" exp))))
(define-syntax-rule (make-cont-folder global? seed ...) (define-syntax-rule (make-cont-folder global? seed ...)
(lambda (proc fun seed ...) (lambda (proc cont seed ...)
(define (fold-values proc in seed ...) (define (fold-values proc in seed ...)
(if (null? in) (if (null? in)
(values seed ...) (values seed ...)
@ -505,7 +507,7 @@
(fold-values fun-folder funs seed ...) (fold-values fun-folder funs seed ...)
(values seed ...)))))) (values seed ...))))))
(fun-folder fun seed ...))) (cont-folder cont seed ...)))
(define (compute-max-label-and-var fun) (define (compute-max-label-and-var fun)
((make-cont-folder #t max-label max-var) ((make-cont-folder #t max-label max-var)

4
module/language/cps/cse.scm
View file

@ -229,7 +229,7 @@ be that both true and false proofs are available."
(define (compute-label-and-var-ranges fun) (define (compute-label-and-var-ranges fun)
(match 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) ((make-cont-folder #f min-label label-count min-var var-count)
(lambda (k cont 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)) (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 self min-var) (1+ var-count)))
(_ (_
(values min-label label-count min-var 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 (compute-idoms dfg min-label label-count)
(define (label->idx label) (- label min-label)) (define (label->idx label) (- label min-label))

10
module/language/cps/dce.scm
View file

@ -90,10 +90,12 @@
(define (ensure-fun-data fun) (define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun) (or (hashq-ref fun-data-table fun)
(call-with-values (lambda () (call-with-values (lambda ()
((make-cont-folder #f label-count max-label) (match fun
(lambda (k cont label-count max-label) (($ $fun free body)
(values (1+ label-count) (max k max-label))) ((make-cont-folder #f label-count max-label)
fun 0 -1)) (lambda (k cont label-count max-label)
(values (1+ label-count) (max k max-label)))
body 0 -1))))
(lambda (label-count max-label) (lambda (label-count max-label)
(let* ((min-label (- (1+ max-label) label-count)) (let* ((min-label (- (1+ max-label) label-count))
(effects (compute-effects dfg min-label label-count)) (effects (compute-effects dfg min-label label-count))

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

@ -895,23 +895,25 @@ body continuation in the prompt."
(do-fold #f))) (do-fold #f)))
(define* (compute-dfg fun #:key (global? #t)) (define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?)) (match fun
(lambda (min-label max-label label-count min-var max-var var-count) (($ $fun free body)
(when (or (zero? label-count) (zero? var-count)) (call-with-values (lambda () (compute-label-and-var-ranges body global?))
(error "internal error (no vars or labels for fun?)")) (lambda (min-label max-label label-count min-var max-var var-count)
(let* ((nlabels (- (1+ max-label) min-label)) (when (or (zero? label-count) (zero? var-count))
(nvars (- (1+ max-var) min-var)) (error "internal error (no vars or labels for fun?)"))
(conts (make-vector nlabels #f)) (let* ((nlabels (- (1+ max-label) min-label))
(preds (make-vector nlabels '())) (nvars (- (1+ max-var) min-var))
(defs (make-vector nvars #f)) (conts (make-vector nlabels #f))
(uses (make-vector nvars '())) (preds (make-vector nlabels '()))
(scopes (make-vector nlabels #f)) (defs (make-vector nvars #f))
(scope-levels (make-vector nlabels #f))) (uses (make-vector nvars '()))
(visit-fun fun conts preds defs uses scopes scope-levels (scopes (make-vector nlabels #f))
min-label min-var global?) (scope-levels (make-vector nlabels #f)))
(make-dfg conts preds defs uses scopes scope-levels (visit-fun fun conts preds defs uses scopes scope-levels
min-label max-label label-count min-label min-var global?)
min-var max-var var-count))))) (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 ...) (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
(parameterize ((label-counter (1+ (dfg-max-label dfg))) (parameterize ((label-counter (1+ (dfg-max-label dfg)))

8
module/language/cps/elide-values.scm
View file

@ -103,6 +103,8 @@
($fun free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(define (elide-values fun) (define (elide-values fun)
(with-fresh-name-state fun (match fun
(let ((conts (build-cont-table fun))) (($ $fun free funk)
(elide-values* fun conts)))) (with-fresh-name-state fun
(let ((conts (build-cont-table funk)))
(elide-values* fun conts))))))

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

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

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

@ -74,7 +74,10 @@
(lp (1+ n) next)))))) (lp (1+ n) next))))))
(define (compute-new-labels-and-vars fun) (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) (lambda (max-label max-var)
(let ((labels (make-vector (1+ max-label) #f)) (let ((labels (make-vector (1+ max-label) #f))
(next-label 0) (next-label 0)
@ -177,88 +180,90 @@
(values labels vars next-label next-var))))) (values labels vars next-label next-var)))))
(define (renumber fun) (define (renumber fun)
(call-with-values (lambda () (compute-new-labels-and-vars fun)) (match fun
(lambda (labels vars nlabels nvars) (($ $fun free cont)
(define (relabel label) (vector-ref labels label)) (call-with-values (lambda () (compute-new-labels-and-vars fun))
(define (rename var) (vector-ref vars var)) (lambda (labels vars nlabels nvars)
(define (rename-kw-arity arity) (define (relabel label) (vector-ref labels label))
(match arity (define (rename var) (vector-ref vars var))
(($ $arity req opt rest kw aok?) (define (rename-kw-arity arity)
(make-$arity req opt rest (match arity
(map (match-lambda (($ $arity req opt rest kw aok?)
((kw kw-name kw-var) (make-$arity req opt rest
(list kw kw-name (rename kw-var)))) (map (match-lambda
kw) ((kw kw-name kw-var)
aok?)))) (list kw kw-name (rename kw-var))))
(define (must-visit-cont cont) kw)
(or (visit-cont cont) aok?))))
(error "internal error -- failed to visit cont"))) (define (must-visit-cont cont)
(define (visit-conts conts) (or (visit-cont cont)
(match conts (error "internal error -- failed to visit cont")))
(() '()) (define (visit-conts conts)
((cont . conts) (match conts
(cond (() '())
((visit-cont cont) ((cont . conts)
=> (lambda (cont) (cond
(cons cont (visit-conts conts)))) ((visit-cont cont)
(else (visit-conts conts)))))) => (lambda (cont)
(define (visit-cont cont) (cons cont (visit-conts conts))))
(match cont (else (visit-conts conts))))))
(($ $cont label cont) (define (visit-cont cont)
(let ((label (relabel label))) (match cont
(and (($ $cont label cont)
label (let ((label (relabel label)))
(rewrite-cps-cont cont (and
(($ $kargs names vars body) label
(label ($kargs names (map rename vars) ,(visit-term body)))) (rewrite-cps-cont cont
(($ $kfun src meta self tail clause) (($ $kargs names vars body)
(label (label ($kargs names (map rename vars) ,(visit-term body))))
($kfun src meta (rename self) ,(must-visit-cont tail) (($ $kfun src meta self tail clause)
,(and clause (must-visit-cont clause))))) (label
(($ $ktail) ($kfun src meta (rename self) ,(must-visit-cont tail)
(label ($ktail))) ,(and clause (must-visit-cont clause)))))
(($ $kclause arity body alternate) (($ $ktail)
(label (label ($ktail)))
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body) (($ $kclause arity body alternate)
,(and alternate (must-visit-cont alternate))))) (label
(($ $kreceive ($ $arity req () rest () #f) kargs) ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
(label ($kreceive req rest (relabel kargs)))) ,(and alternate (must-visit-cont alternate)))))
(($ $kif kt kf) (($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kif (relabel kt) (relabel kf)))))))))) (label ($kreceive req rest (relabel kargs))))
(define (visit-term term) (($ $kif kt kf)
(rewrite-cps-term term (label ($kif (relabel kt) (relabel kf))))))))))
(($ $letk conts body) (define (visit-term term)
,(match (visit-conts conts) (rewrite-cps-term term
(() (visit-term body)) (($ $letk conts body)
(conts (build-cps-term ($letk ,conts ,(visit-term body)))))) ,(match (visit-conts conts)
(($ $letrec names vars funs body) (() (visit-term body))
($letrec names (map rename vars) (map visit-fun funs) (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
,(visit-term body))) (($ $letrec names vars funs body)
(($ $continue k src exp) ($letrec names (map rename vars) (map visit-fun funs)
($continue (relabel k) src ,(visit-exp exp))))) ,(visit-term body)))
(define (visit-exp exp) (($ $continue k src exp)
(match exp ($continue (relabel k) src ,(visit-exp exp)))))
((or ($ $void) ($ $const) ($ $prim)) (define (visit-exp exp)
exp) (match exp
(($ $fun) ((or ($ $void) ($ $const) ($ $prim))
(visit-fun exp)) exp)
(($ $values args) (($ $fun)
(let ((args (map rename args))) (visit-fun exp))
(build-cps-exp ($values args)))) (($ $values args)
(($ $call proc args) (let ((args (map rename args)))
(let ((args (map rename args))) (build-cps-exp ($values args))))
(build-cps-exp ($call (rename proc) args)))) (($ $call proc args)
(($ $callk k proc args) (let ((args (map rename args)))
(let ((args (map rename args))) (build-cps-exp ($call (rename proc) args))))
(build-cps-exp ($callk (relabel k) (rename proc) args)))) (($ $callk k proc args)
(($ $primcall name args) (let ((args (map rename args)))
(let ((args (map rename args))) (build-cps-exp ($callk (relabel k) (rename proc) args))))
(build-cps-exp ($primcall name args)))) (($ $primcall name args)
(($ $prompt escape? tag handler) (let ((args (map rename args)))
(build-cps-exp (build-cps-exp ($primcall name args))))
($prompt escape? (rename tag) (relabel handler)))))) (($ $prompt escape? tag handler)
(define (visit-fun fun) (build-cps-exp
(rewrite-cps-exp fun ($prompt escape? (rename tag) (relabel handler))))))
(($ $fun free body) (define (visit-fun fun)
($fun (map rename free) ,(must-visit-cont body))))) (rewrite-cps-exp fun
(values (visit-fun fun) nlabels nvars)))) (($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(values (visit-fun fun) nlabels nvars))))))