mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +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 ...)
(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)

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)
(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))

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

@ -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))

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

@ -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)))

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

@ -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))))))

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

@ -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))))))

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

@ -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))))))