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

compute-dfg takes a $kfun $cont, not a $fun

Browse source 
* module/language/cps/dfg.scm (compute-dfg): Take a $kfun $cont instead
  of a $fun.

* module/language/cps/arities.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm: Adapt callers.
This commit is contained in:
Andy Wingo 2014-04-11 11:22:06 +02:00
parent d3dbf75ab3
commit a16af11320
8 changed files with 141 additions and 139 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -191,6 +191,8 @@
($fun free ,(fix-clause-arities body dfg)))))
(define (fix-arities fun)
(let ((dfg (compute-dfg fun)))
(let ((dfg (match fun
(($ $fun free body)
(compute-dfg body)))))
(with-fresh-name-state-from-dfg dfg
(fix-arities* fun dfg))))

4
module/language/cps/compile-bytecode.scm
View file

@ -89,7 +89,9 @@
exp))
(define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f))
(let* ((dfg (match f
(($ $fun free body)
(compute-dfg body #:global? #f))))
(allocation (allocate-slots f dfg)))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))

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

@ -39,7 +39,9 @@
#:export (contify))
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
(let* ((dfg (match fun
(($ $fun free body)
(compute-dfg body))))
(scope-table (make-hash-table))
(call-substs '())
(cont-substs '())

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

@ -525,4 +525,6 @@ be that both true and false proofs are available."
(define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun))
(lambda (fun nlabels nvars)
(cse fun (compute-dfg fun)))))
(match fun
(($ $fun free body)
(cse fun (compute-dfg body)))))))

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

@ -78,7 +78,9 @@
(define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table))
(dfg (compute-dfg fun #:global? #t))
(dfg (match fun
(($ $fun free body)
(compute-dfg body #:global? #t))))
(live-vars (make-bitvector (dfg-var-count dfg) #f))
(changed? #f))
(define (mark-live! var)

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

@ -733,118 +733,6 @@ body continuation in the prompt."
(newline)
(lp (1+ n)))))))
(define (visit-fun fun conts preds defs uses scopes scope-levels
min-label min-var global?)
(define (add-def! var def-k)
(vector-set! defs (- var min-var) def-k))
(define (add-use! var use-k)
(vector-push! uses (- var min-var) use-k))
(define* (declare-block! label cont parent
#:optional (level
(1+ (vector-ref
scope-levels
(- parent min-label)))))
(vector-set! conts (- label min-label) cont)
(vector-set! scopes (- label min-label) parent)
(vector-set! scope-levels (- label min-label) level))
(define (link-blocks! pred succ)
(vector-push! preds (- succ min-label) pred))
(define (visit exp exp-k)
(define (def! sym)
(add-def! sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! k)
(link-blocks! exp-k k))
(define (recur exp)
(visit exp exp-k))
(match exp
(($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each/2 (lambda (cont k)
(declare-block! k cont exp-k))
cont k)
(for-each/2 visit cont k)
(recur body))
(($ $kargs names syms body)
(for-each def! syms)
(recur body))
(($ $kif kt kf)
(use-k! kt)
(use-k! kf))
(($ $kreceive arity k)
(use-k! k))
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
(for-each def! syms)
(for-each
(cut visit-fun <> conts preds defs uses scopes scope-levels
min-label min-var global?)
funs)
(visit body exp-k))
(($ $continue k src exp)
(use-k! k)
(match exp
(($ $call proc args)
(use! proc)
(for-each use! args))
(($ $callk k proc args)
(use! proc)
(for-each use! args))
(($ $primcall name args)
(for-each use! args))
(($ $values args)
(for-each use! args))
(($ $prompt escape? tag handler)
(use! tag)
(use-k! handler))
(($ $fun)
(when global?
(visit-fun exp conts preds defs uses scopes scope-levels
min-label min-var global?)))
(_ #f)))))
(match fun
(($ $fun free
($ $cont kfun
(and entry
($ $kfun src meta self ($ $cont ktail tail) clause))))
(declare-block! kfun entry #f 0)
(add-def! self kfun)
(declare-block! ktail tail kfun)
(let lp ((clause clause))
(match clause
(#f #t)
(($ $cont kclause
(and clause ($ $kclause arity ($ $cont kbody body)
alternate)))
(declare-block! kclause clause kfun)
(link-blocks! kfun kclause)
(declare-block! kbody body kclause)
(link-blocks! kclause kbody)
(visit body kbody)
(lp alternate)))))))
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
@ -895,25 +783,124 @@ body continuation in the prompt."
(do-fold #f)))
(define* (compute-dfg fun #:key (global? #t))
(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)))))))
(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)))
(define (var->idx var) (- var min-var))
(define (label->idx label) (- label min-label))
(define (add-def! var def-k)
(vector-set! defs (var->idx var) def-k))
(define (add-use! var use-k)
(vector-push! uses (var->idx var) use-k))
(define* (declare-block! label cont parent
#:optional (level
(1+ (vector-ref
scope-levels
(label->idx parent)))))
(vector-set! conts (label->idx label) cont)
(vector-set! scopes (label->idx label) parent)
(vector-set! scope-levels (label->idx label) level))
(define (link-blocks! pred succ)
(vector-push! preds (label->idx succ) pred))
(define (visit-cont cont label)
(match cont
(($ $kargs names syms body)
(for-each (cut add-def! <> label) syms)
(visit-term body label))
(($ $kif kt kf)
(link-blocks! label kt)
(link-blocks! label kf))
(($ $kreceive arity k)
(link-blocks! label k))))
(define (visit-term term label)
(match term
(($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each/2 (lambda (cont k)
(declare-block! k cont label))
cont k)
(for-each/2 visit-cont cont k)
(visit-term body label))
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
(for-each (cut add-def! <> label) syms)
(for-each (lambda (fun)
(match fun
(($ $fun free body)
(visit-fun body))))
funs)
(visit-term body label))
(($ $continue k src exp)
(link-blocks! label k)
(visit-exp exp label))))
(define (visit-exp exp label)
(define (use! sym)
(add-use! sym label))
(match exp
((or ($ $void) ($ $const) ($ $prim)) #f)
(($ $call proc args)
(use! proc)
(for-each use! args))
(($ $callk k proc args)
(use! proc)
(for-each use! args))
(($ $primcall name args)
(for-each use! args))
(($ $values args)
(for-each use! args))
(($ $prompt escape? tag handler)
(use! tag)
(link-blocks! label handler))
(($ $fun free body)
(when global?
(visit-fun body)))))
(define (visit-clause clause kfun)
(match clause
(#f #t)
(($ $cont kclause
(and clause ($ $kclause arity ($ $cont kbody body)
alternate)))
(declare-block! kclause clause kfun)
(link-blocks! kfun kclause)
(declare-block! kbody body kclause)
(link-blocks! kclause kbody)
(visit-cont body kbody)
(visit-clause alternate kfun))))
(define (visit-fun fun)
(match fun
(($ $cont kfun
(and cont
($ $kfun src meta self ($ $cont ktail tail) clause)))
(declare-block! kfun cont #f 0)
(add-def! self kfun)
(declare-block! ktail tail kfun)
(visit-clause clause kfun))))
(visit-fun fun)
(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)))

7
module/language/cps/simplify.scm
View file

@ -69,7 +69,9 @@
(define (eta-reduce fun)
(let ((table (compute-eta-reductions fun))
(dfg (compute-dfg fun)))
(dfg (match fun
(($ $fun free body)
(compute-dfg body)))))
(define (reduce* k scope values?)
(match (hashq-ref table k)
(#f k)
@ -125,7 +127,8 @@
;; inlined if it is used only once, and not recursively.
(let ((var-table (make-hash-table))
(k-table (make-hash-table))
(dfg (compute-dfg fun)))
(dfg (match fun
(($ $fun free body) (compute-dfg body)))))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))

4
module/language/cps/specialize-primcalls.scm
View file

@ -31,7 +31,9 @@
#:export (specialize-primcalls))
(define (specialize-primcalls fun)
(let ((dfg (compute-dfg fun #:global? #t)))
(let ((dfg (match fun
(($ $fun free body)
(compute-dfg body #:global? #t)))))
(with-fresh-name-state-from-dfg dfg
(define (immediate-u8? sym)
(call-with-values (lambda () (find-constant-value sym dfg))