mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Root higher-order CPS term is always $kfun $cont

Browse source 
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/tree-il/compile-cps.scm: Adapt to produce and consume
  raw $kfun $cont instances.

* .dir-locals.el: Update $letrec indentation.
This commit is contained in:
Andy Wingo 2014-04-11 14:01:27 +02:00
parent b85f5f851f
commit a0329d0109
16 changed files with 212 additions and 223 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -27,6 +27,7 @@
(eval . (put '$continue 'scheme-indent-function 2)) (eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$kargs 'scheme-indent-function 2)) (eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kfun 'scheme-indent-function 4)) (eval . (put '$kfun 'scheme-indent-function 4))
(eval . (put '$letrec 'scheme-indent-function 3))
(eval . (put '$kclause 'scheme-indent-function 1)) (eval . (put '$kclause 'scheme-indent-function 1))
(eval . (put '$fun 'scheme-indent-function 1)))) (eval . (put '$fun 'scheme-indent-function 1))))
(emacs-lisp-mode . ((indent-tabs-mode . nil))) (emacs-lisp-mode . ((indent-tabs-mode . nil)))

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

@ -32,7 +32,7 @@
#:use-module (language cps primitives) #:use-module (language cps primitives)
#:export (fix-arities)) #:export (fix-arities))
(define (fix-clause-arities clause dfg) (define (fix-arities* clause dfg)
(let ((ktail (match clause (let ((ktail (match clause
(($ $cont _ (($ $cont _
($ $kfun src meta _ ($ $cont ktail) _)) ktail)))) ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
@ -41,7 +41,11 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map (cut fix-arities* <> dfg) funs) ($letrec names syms (map (lambda (fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun free ,(fix-arities* body dfg)))))
funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k src exp) (($ $continue k src exp)
,(visit-exp k src exp)))) ,(visit-exp k src exp))))
@ -135,8 +139,9 @@
($ $prim) ($ $prim)
($ $values (_))) ($ $values (_)))
,(adapt-exp 1 k src exp)) ,(adapt-exp 1 k src exp))
(($ $fun) (($ $fun free body)
,(adapt-exp 1 k src (fix-arities* exp dfg))) ,(adapt-exp 1 k src (build-cps-exp
($fun free ,(fix-arities* body dfg)))))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to ;; reason every non-tail call has a $kreceive continuation to
@ -185,14 +190,7 @@
(($ $cont sym ($ $kfun src meta self tail clause)) (($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))) (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
(define (fix-arities* fun dfg)
(rewrite-cps-exp fun
(($ $fun free body)
($fun free ,(fix-clause-arities body dfg)))))
(define (fix-arities fun) (define (fix-arities fun)
(let ((dfg (match fun (let ((dfg (compute-dfg fun)))
(($ $fun free body)
(compute-dfg body)))))
(with-fresh-name-state-from-dfg dfg (with-fresh-name-state-from-dfg dfg
(fix-arities* fun dfg)))) (fix-arities* fun dfg))))

12
module/language/cps/closure-conversion.scm
View file

@ -272,13 +272,11 @@ convert functions to flat closures."
(($ $cont sym ($ $kfun src meta self tail clause)) (($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))) (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
(define (convert-closures exp) (define (convert-closures fun)
"Convert free reference in @var{exp} to primcalls to @code{free-ref}, "Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures." and allocate and initialize flat closures."
(match exp (with-fresh-name-state fun
(($ $fun () body) (receive (body free) (cc fun #f '())
(with-fresh-name-state body
(receive (body free) (cc body #f '())
(unless (null? free) (unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free)) (error "Expected no free vars in toplevel thunk" fun body free))
(convert-to-indices body free)))))) (convert-to-indices body free))))

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

@ -506,8 +506,7 @@
(exp (optimize exp opts)) (exp (optimize exp opts))
(exp (convert-closures exp)) (exp (convert-closures exp))
(exp (reify-primitives exp)) (exp (reify-primitives exp))
(exp (match (renumber (build-cps-exp ($fun '() ,exp))) (exp (renumber exp))
(($ $fun free body) body)))
(asm (make-assembler))) (asm (make-assembler)))
(visit-funs (lambda (fun) (visit-funs (lambda (fun)
(compile-fun fun asm)) (compile-fun fun asm))

16
module/language/cps/constructors.scm
View file

@ -47,7 +47,7 @@
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map inline-constructors* funs) ($letrec names syms (map visit-fun funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k src ($ $primcall 'list args)) (($ $continue k src ($ $primcall 'list args))
,(let-fresh (kvalues) (val) ,(let-fresh (kvalues) (val)
@ -90,16 +90,16 @@
($continue kalloc src ($continue kalloc src
($primcall 'make-vector (len init)))))))) ($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(inline-constructors* fun))) ($continue k src ,(visit-fun fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun free body)
($fun free ,(visit-cont body))))) ($fun free ,(inline-constructors* body)))))
(visit-cont fun))
(define (inline-constructors fun) (define (inline-constructors fun)
(match fun (with-fresh-name-state fun
(($ $fun free body) (inline-constructors* fun)))
(with-fresh-name-state body
(inline-constructors* fun)))))

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

@ -39,9 +39,7 @@
#:export (contify)) #:export (contify))
(define (compute-contification fun) (define (compute-contification fun)
(let* ((dfg (match fun (let* ((dfg (compute-dfg fun))
(($ $fun free body)
(compute-dfg body))))
(scope-table (make-hash-table)) (scope-table (make-hash-table))
(call-substs '()) (call-substs '())
(cont-substs '()) (cont-substs '())
@ -294,7 +292,7 @@
(visit-fun exp))) (visit-fun exp)))
(_ #t))))) (_ #t)))))
(visit-fun fun) (visit-cont fun)
(values call-substs cont-substs fun-elisions cont-splices))) (values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices) (define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
@ -401,7 +399,7 @@
(or (contify-call src proc args) (or (contify-call src proc args)
(continue k src exp))) (continue k src exp)))
(_ (continue k src exp))))))) (_ (continue k src exp)))))))
(visit-fun fun)) (visit-cont fun))
(define (contify fun) (define (contify fun)
(call-with-values (lambda () (compute-contification fun)) (call-with-values (lambda () (compute-contification fun))

25
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 (and body ($ $cont kfun ($ $kfun src meta self)))) (($ $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)))))
body kfun 0 self 0)))) fun 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))
@ -458,8 +458,10 @@ be that both true and false proofs are available."
(define (visit-exp* k src exp) (define (visit-exp* k src exp)
(match exp (match exp
((and fun ($ $fun)) (($ $fun free body)
(build-cps-term ($continue k src ,(cse fun dfg)))) (build-cps-term
($continue k src
($fun (map subst-var free) ,(cse body dfg)))))
(_ (_
(cond (cond
((vector-ref equiv-labels (label->idx label)) ((vector-ref equiv-labels (label->idx label))
@ -501,7 +503,12 @@ be that both true and false proofs are available."
(($ $letk conts body) (($ $letk conts body)
,(visit-term body label)) ,(visit-term body label))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map (lambda (fun) (cse fun dfg)) funs) ($letrec names syms
(map (lambda (fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map subst-var free) ,(cse body dfg)))))
funs)
,(visit-term body label))) ,(visit-term body label)))
(($ $continue k src exp) (($ $continue k src exp)
,(let ((conts (append-map visit-dom-conts ,(let ((conts (append-map visit-dom-conts
@ -511,9 +518,7 @@ be that both true and false proofs are available."
(build-cps-term (build-cps-term
($letk ,conts ,(visit-exp* k src exp)))))))) ($letk ,conts ,(visit-exp* k src exp))))))))
(rewrite-cps-exp fun (visit-fun-cont fun))
(($ $fun free body)
($fun (map subst-var free) ,(visit-fun-cont body)))))
(define (cse fun dfg) (define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
@ -525,6 +530,4 @@ be that both true and false proofs are available."
(define (eliminate-common-subexpressions fun) (define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun)) (call-with-values (lambda () (renumber fun))
(lambda (fun nlabels nvars) (lambda (fun nlabels nvars)
(match fun (cse fun (compute-dfg fun)))))
(($ $fun free body)
(cse fun (compute-dfg body)))))))

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

@ -78,9 +78,7 @@
(define (compute-live-code fun) (define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table)) (let* ((fun-data-table (make-hash-table))
(dfg (match fun (dfg (compute-dfg fun #:global? #t))
(($ $fun free body)
(compute-dfg body #:global? #t))))
(live-vars (make-bitvector (dfg-var-count dfg) #f)) (live-vars (make-bitvector (dfg-var-count dfg) #f))
(changed? #f)) (changed? #f))
(define (mark-live! var) (define (mark-live! var)
@ -92,12 +90,10 @@
(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 ()
(match fun
(($ $fun free body)
((make-cont-folder #f label-count max-label) ((make-cont-folder #f label-count max-label)
(lambda (k cont label-count max-label) (lambda (k cont label-count max-label)
(values (1+ label-count) (max k max-label))) (values (1+ label-count) (max k max-label)))
body 0 -1)))) fun 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))
@ -133,7 +129,9 @@
(lp body) (lp body)
(for-each (lambda (sym fun) (for-each (lambda (sym fun)
(when (value-live? sym) (when (value-live? sym)
(visit-fun fun))) (match fun
(($ $fun free body)
(visit-fun body)))))
syms funs)) syms funs))
(($ $continue k src exp) (($ $continue k src exp)
(unless (bitvector-ref live-conts n) (unless (bitvector-ref live-conts n)
@ -144,8 +142,8 @@
(match exp (match exp
((or ($ $void) ($ $const) ($ $prim)) ((or ($ $void) ($ $const) ($ $prim))
#f) #f)
((and fun ($ $fun)) (($ $fun free body)
(visit-fun fun)) (visit-fun body))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(mark-live! tag)) (mark-live! tag))
(($ $call proc args) (($ $call proc args)
@ -248,7 +246,12 @@
(match (filter-map (match (filter-map
(lambda (name sym fun) (lambda (name sym fun)
(and (value-live? sym) (and (value-live? sym)
(list name sym (visit-fun fun)))) (match fun
(($ $fun free body)
(list name
sym
(build-cps-exp
($fun free ,(visit-fun body))))))))
names syms funs) names syms funs)
(() body) (() body)
(((names syms funs) ...) (((names syms funs) ...)
@ -266,7 +269,8 @@
(($ $continue k src exp) (($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k)) (if (bitvector-ref live-conts (label->idx term-k))
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $fun) ($continue k src ,(visit-fun exp))) (($ $fun free body)
($continue k src ($fun free ,(visit-fun body))))
(_ (_
,(match (vector-ref defs (label->idx term-k)) ,(match (vector-ref defs (label->idx term-k))
((or #f ((? value-live?) ...)) ((or #f ((? value-live?) ...))
@ -278,9 +282,7 @@
($letk (,(make-adaptor adapt k syms)) ($letk (,(make-adaptor adapt k syms))
($continue adapt src ,exp)))))))) ($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ()))))))) (build-cps-term ($continue k src ($values ())))))))
(rewrite-cps-exp fun (visit-cont fun))))
(($ $fun free body)
($fun free ,(visit-cont body)))))))
(visit-fun fun)) (visit-fun fun))
(define (eliminate-dead-code fun) (define (eliminate-dead-code fun)

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

@ -53,7 +53,7 @@
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map (cut elide-values* <> conts) funs) ($letrec names syms (map visit-fun funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals)) (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (vector-ref conts k) ,(rewrite-cps-term (vector-ref conts k)
@ -94,17 +94,17 @@
(build-cps-term (build-cps-term
($continue k src ($values vals)))))))) ($continue k src ($values vals))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(elide-values* fun conts))) ($continue k src ,(visit-fun fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun free cont)
($fun free ,(visit-cont body))))) ($fun free ,(visit-cont cont)))))
(visit-cont fun))
(define (elide-values fun) (define (elide-values fun)
(match fun (with-fresh-name-state fun
(($ $fun free funk) (let ((conts (build-cont-table fun)))
(with-fresh-name-state funk (elide-values* fun conts))))
(let ((conts (build-cont-table funk)))
(elide-values* fun conts))))))

23
module/language/cps/prune-bailouts.scm
View file

@ -61,7 +61,7 @@
(define (visit-term term ktail) (define (visit-term term ktail)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letrec names vars funs body) (($ $letrec names vars funs body)
($letrec names vars (map prune-bailouts* funs) ($letrec names vars (map visit-fun funs)
,(visit-term body ktail))) ,(visit-term body ktail)))
(($ $letk conts body) (($ $letk conts body)
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts) ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
@ -71,7 +71,7 @@
(define (visit-exp k src exp ktail) (define (visit-exp k src exp ktail)
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $fun) ($continue k src ,(prune-bailouts* exp))) (($ $fun) ($continue k src ,(visit-fun exp)))
(($ $primcall (and name (or 'error 'scm-error 'throw)) args) (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
,(if (eq? k ktail) ,(if (eq? k ktail)
(build-cps-term ($continue k src ,exp)) (build-cps-term ($continue k src ,exp))
@ -86,16 +86,17 @@
,(primitive-ref name kprim src)))))) ,(primitive-ref name kprim src))))))
(_ ($continue k src ,exp)))) (_ ($continue k src ,exp))))
(define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free (($ $fun free body)
($ $cont kfun ($fun free ,(prune-bailouts* body)))))
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
($fun free (rewrite-cps-cont fun
(($ $cont kfun
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(kfun ($kfun src meta self (ktail ($ktail)) (kfun ($kfun src meta self (ktail ($ktail))
,(and clause (visit-cont clause ktail)))))))) ,(and clause (visit-cont clause ktail)))))))
(define (prune-bailouts fun) (define (prune-bailouts fun)
(match fun (with-fresh-name-state fun
(($ $fun free body) (prune-bailouts* fun)))
(with-fresh-name-state body
(prune-bailouts* fun)))))

6
module/language/cps/prune-top-level-scopes.scm
View file

@ -85,7 +85,7 @@
(($ $fun free body) (($ $fun free body)
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-cont fun)
scope-var->used?)) scope-var->used?))
(define (prune-top-level-scopes fun) (define (prune-top-level-scopes fun)
@ -114,6 +114,4 @@
($continue k src ($primcall 'values ()))) ($continue k src ($primcall 'values ())))
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (visit-cont fun)))
(($ $fun free body)
($fun free ,(visit-cont body))))))

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

@ -74,10 +74,7 @@
(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 () (call-with-values (lambda () (compute-max-label-and-var fun))
(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)
@ -113,9 +110,7 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
(visit-term body)) (visit-term body))
(($ $continue k src _) #f))) (($ $continue k src _) #f)))
(match fun (visit-cont fun))
(($ $fun free body)
(visit-cont body))))
(define (compute-names-in-fun fun) (define (compute-names-in-fun fun)
(define queue '()) (define queue '())
@ -162,26 +157,29 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
(when reachable? (when reachable?
(for-each rename! syms) (for-each rename! syms)
(set! queue (fold cons queue funs))) (set! queue (fold (lambda (fun queue)
(match fun
(($ $fun free body)
(cons body queue))))
queue
funs)))
(visit-term body reachable?)) (visit-term body reachable?))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src ($ $fun free body))
(when reachable? (when reachable?
(set! queue (cons fun queue)))) (set! queue (cons body queue))))
(($ $continue) #f))) (($ $continue) #f)))
(collect-conts fun) (collect-conts fun)
(match fun (match fun
(($ $fun free (and entry ($ $cont kfun))) (($ $cont kfun)
(set! next-label (sort-conts kfun labels next-label)) (set! next-label (sort-conts kfun labels next-label))
(visit-cont entry) (visit-cont fun)
(for-each compute-names-in-fun (reverse queue))))) (for-each compute-names-in-fun (reverse queue)))))
(compute-names-in-fun fun) (compute-names-in-fun fun)
(values labels vars next-label next-var))))) (values labels vars next-label next-var)))))
(define (renumber fun) (define (renumber fun)
(match fun
(($ $fun free cont)
(call-with-values (lambda () (compute-new-labels-and-vars fun)) (call-with-values (lambda () (compute-new-labels-and-vars fun))
(lambda (labels vars nlabels nvars) (lambda (labels vars nlabels nvars)
(define (relabel label) (vector-ref labels label)) (define (relabel label) (vector-ref labels label))
@ -266,4 +264,4 @@
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun free body)
($fun (map rename free) ,(must-visit-cont body))))) ($fun (map rename free) ,(must-visit-cont body)))))
(values (visit-fun fun) nlabels nvars)))))) (values (must-visit-cont fun) nlabels nvars))))

13
module/language/cps/self-references.scm
View file

@ -57,7 +57,8 @@
(define (visit-exp exp) (define (visit-exp exp)
(rewrite-cps-exp exp (rewrite-cps-exp exp
((or ($ $void) ($ $const) ($ $prim)) ,exp) ((or ($ $void) ($ $const) ($ $prim)) ,exp)
(($ $fun) ,(resolve-self-references exp env)) (($ $fun free body)
($fun free ,(resolve-self-references body env)))
(($ $call proc args) (($ $call proc args)
($call (subst proc) ,(map subst args))) ($call (subst proc) ,(map subst args)))
(($ $callk k proc args) (($ $callk k proc args)
@ -70,10 +71,8 @@
($prompt escape? (subst tag) handler)))) ($prompt escape? (subst tag) handler))))
(define (visit-recursive-fun fun var) (define (visit-recursive-fun fun var)
(match fun
(($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
(resolve-self-references fun (acons var self env)))))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free cont) (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
($fun (map subst free) ,(visit-cont cont))))) ($fun free ,(resolve-self-references cont (acons var self env))))))
(visit-cont fun))

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

@ -64,14 +64,12 @@
(match fun (match fun
(($ $fun free body) (($ $fun free body)
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-cont fun)
table)) table))
(define (eta-reduce fun) (define (eta-reduce fun)
(let ((table (compute-eta-reductions fun)) (let ((table (compute-eta-reductions fun))
(dfg (match fun (dfg (compute-dfg fun)))
(($ $fun free body)
(compute-dfg body)))))
(define (reduce* k scope values?) (define (reduce* k scope values?)
(match (hashq-ref table k) (match (hashq-ref table k)
(#f k) (#f k)
@ -119,7 +117,7 @@
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun free body)
($fun free ,(visit-cont body #f))))) ($fun free ,(visit-cont body #f)))))
(visit-fun fun))) (visit-cont fun #f)))
(define (compute-beta-reductions fun) (define (compute-beta-reductions fun)
;; A continuation's body can be inlined in place of a $values ;; A continuation's body can be inlined in place of a $values
@ -127,8 +125,7 @@
;; inlined if it is used only once, and not recursively. ;; inlined if it is used only once, and not recursively.
(let ((var-table (make-hash-table)) (let ((var-table (make-hash-table))
(k-table (make-hash-table)) (k-table (make-hash-table))
(dfg (match fun (dfg (compute-dfg fun)))
(($ $fun free body) (compute-dfg body)))))
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
@ -171,7 +168,7 @@
(match fun (match fun
(($ $fun free body) (($ $fun free body)
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-cont fun)
(values var-table k-table))) (values var-table k-table)))
(define (beta-reduce fun) (define (beta-reduce fun)
@ -235,7 +232,7 @@
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun free body)
($fun (map subst free) ,(must-visit-cont body))))) ($fun (map subst free) ,(must-visit-cont body)))))
(visit-fun fun))) (must-visit-cont fun)))
(define (simplify fun) (define (simplify fun)
;; Renumbering prunes continuations that are made unreachable by ;; Renumbering prunes continuations that are made unreachable by

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

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

5
module/language/tree-il/compile-cps.scm
View file

@ -603,15 +603,14 @@ integer."
(scope-counter 0)) (scope-counter 0))
(let ((src (tree-il-src exp))) (let ((src (tree-il-src exp)))
(let-fresh (kinit ktail kclause kbody) (init) (let-fresh (kinit ktail kclause kbody) (init)
(build-cps-exp (build-cps-cont
($fun '()
(kinit ($kfun src '() init (ktail ($ktail)) (kinit ($kfun src '() init (ktail ($ktail))
(kclause (kclause
($kclause ('() '() #f '() #f) ($kclause ('() '() #f '() #f)
(kbody ($kargs () () (kbody ($kargs () ()
,(convert exp ktail ,(convert exp ktail
(build-subst exp)))) (build-subst exp))))
,#f)))))))))) ,#f)))))))))
(define *comp-module* (make-fluid)) (define *comp-module* (make-fluid))