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

4
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 ()
(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)))
fun 0 -1))
body 0 -1))))
(lambda (label-count max-label)
(let* ((min-label (- (1+ max-label) label-count))
(effects (compute-effects dfg min-label label-count))

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

@ -895,7 +895,9 @@ 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?))
(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?)"))
@ -911,7 +913,7 @@ body continuation in the prompt."
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)))))
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)))

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

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

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

@ -107,8 +107,10 @@
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(match fun
(($ $fun free body)
(with-fresh-name-state fun
(let ((conts (build-cont-table fun)))
(let ((conts (build-cont-table body)))
(define (visit-fun term)
(rewrite-cps-exp term
(($ $fun free body)
@ -164,4 +166,4 @@
(else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-fun fun))))
(visit-fun fun))))))

9
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,6 +180,8 @@
(values labels vars next-label next-var)))))
(define (renumber fun)
(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))
@ -261,4 +266,4 @@
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(values (visit-fun fun) nlabels nvars))))
(values (visit-fun fun) nlabels nvars))))))