mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Rename $kentry to $kfun

Browse source 
* module/language/cps.scm ($kfun): Rename from $kentry.

* 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/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt users.
This commit is contained in:
Andy Wingo 2014-04-10 12:11:35 +02:00
parent 24b611e81c
commit 8320f50431
22 changed files with 102 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.dir-locals.el
View file

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

36
module/language/cps.scm
View file

@ -57,11 +57,11 @@
;;; but which truncates them to some number of required values,
;;; possibly with a rest list.
;;;
;;; - $kentry labels an entry point for a $fun (a function), and
;;; - $kfun labels an entry point for a $fun (a function), and
;;; contains a $ktail representing the formal argument which is the
;;; function's continuation.
;;;
;;; - $kentry also contain a $kclause continuation, corresponding to
;;; - $kfun also contain a $kclause continuation, corresponding to
;;; the first case-lambda clause of the function. $kclause actually
;;; contains the clause body, and the subsequent clause (if any).
;;; This is because the $kclause logically matches or doesn't match
@ -72,14 +72,14 @@
;;;
;;; (match f
;;; (($ $fun free
;;; ($ $cont kentry
;;; ($ $kentry src meta self ($ $cont ktail ($ $ktail))
;;; ($ $cont kfun
;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
;;; ($ $kclause arity
;;; ($ $cont kbody ($ $kargs names syms body))
;;; alternate))))
;;; #t))
;;;
;;; A $continue to ktail is in tail position. $kentry, $kclause,
;;; A $continue to ktail is in tail position. $kfun, $kclause,
;;; and $ktail will never be seen elsewhere in a CPS term.
;;;
;;; - $prompt continues to the body of the prompt, having pushed on a
@ -119,7 +119,7 @@
$cont
;; Continuation bodies.
$kif $kreceive $kargs $kentry $ktail $kclause
$kif $kreceive $kargs $kfun $ktail $kclause
;; Expressions.
$void $const $prim $fun $call $callk $primcall $values $prompt
@ -179,7 +179,7 @@
(define-cps-type $kif kt kf)
(define-cps-type $kreceive arity k)
(define-cps-type $kargs names syms body)
(define-cps-type $kentry src meta self tail clause)
(define-cps-type $kfun src meta self tail clause)
(define-cps-type $ktail)
(define-cps-type $kclause arity cont alternate)
@ -229,7 +229,7 @@
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body
(syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
(syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kif kt kf))
@ -242,8 +242,8 @@
(make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-cps-term body)))
((_ ($kentry src meta self tail clause))
(make-$kentry src meta self (build-cps-cont tail) (build-cps-cont clause)))
((_ ($kfun src meta self tail clause))
(make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity cont alternate))
@ -344,9 +344,9 @@
(build-cont-body ($kreceive req rest k)))
(('kargs names syms body)
(build-cont-body ($kargs names syms ,(parse-cps body))))
(('kentry src meta self tail clause)
(('kfun src meta self tail clause)
(build-cont-body
($kentry (src exp) meta self ,(parse-cps tail)
($kfun (src exp) meta self ,(parse-cps tail)
,(and=> clause parse-cps))))
(('ktail)
(build-cont-body
@ -413,8 +413,8 @@
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
(($ $kentry src meta self tail clause)
`(kentry ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
(($ $kfun src meta self tail clause)
`(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
@ -466,7 +466,7 @@
(($ $kargs names syms body)
(term-folder body seed ...))
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(let-values (((seed ...) (cont-folder tail seed ...)))
(if clause
(cont-folder clause seed ...)
@ -519,7 +519,7 @@
(($ $letrec names vars funs body)
(lp body (fold max max-var vars)))
(_ max-var))))
(($ $kentry src meta self)
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
fun
@ -552,8 +552,8 @@
(($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
(($ $kentry src meta self tail ($ $cont clause)) (proc clause))
(($ $kfun src meta self tail ($ $cont clause)) (proc clause))
(($ $kentry src meta self tail #f) (proc))
(($ $kfun src meta self tail #f) (proc))
(($ $ktail) (proc))))

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

@ -35,7 +35,7 @@
(define (fix-clause-arities clause dfg)
(let ((ktail (match clause
(($ $cont _
($ $kentry src meta _ ($ $cont ktail) _)) ktail))))
($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
@ -182,8 +182,8 @@
,cont)))
(rewrite-cps-cont clause
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause))))))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
(define (fix-arities* fun dfg)
(rewrite-cps-exp fun

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

@ -128,11 +128,11 @@ convert functions to flat closures."
(values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
(($ $cont sym ($ $kentry src meta self tail clause))
(($ $cont sym ($ $kfun src meta self tail clause))
(receive (clause free) (if clause
(cc clause self (list self))
(values #f '()))
(values (build-cps-cont (sym ($kentry src meta self ,tail ,clause)))
(values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
free)))
(($ $cont sym ($ $kclause arity body alternate))
@ -159,7 +159,7 @@ convert functions to flat closures."
(match in
(() (values (bindings body) free))
(((name sym ($ $fun () (and fun-body
($ $cont _ ($ $kentry src))))) . in)
($ $cont _ ($ $kfun src))))) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
@ -269,8 +269,8 @@ convert functions to flat closures."
,cont)))
(rewrite-cps-cont body
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},

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

@ -116,7 +116,7 @@
(define (compile-entry)
(let ((label (dfg-min-label dfg)))
(match (lookup-cont label dfg)
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(when src
(emit-source asm src))
(emit-begin-program asm label meta)
@ -471,7 +471,7 @@
(emit-call-label asm proc-slot nargs k))))))
(match f
(($ $fun free ($ $cont k ($ $kentry src meta self tail clause)))
(($ $fun free ($ $cont k ($ $kfun src meta self tail clause)))
(compile-entry)))))
(define (visit-funs proc exp)
@ -495,7 +495,7 @@
(when alternate
(visit-funs proc alternate)))
(($ $cont sym ($ $kentry src meta self tail clause))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause
(visit-funs proc clause)))

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

@ -34,8 +34,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))

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

@ -187,7 +187,7 @@
(if (scope-contains? k-scope term-k)
term-k
(match (lookup-cont k-scope dfg)
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
;; K is the tail of some function. If that function
;; has just one clause, return that clause. Otherwise
;; bail.
@ -225,7 +225,7 @@
(match cont
(($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
(($ $cont sym ($ $kentry src meta self tail clause))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@ -251,9 +251,9 @@
(if (null? rec)
'()
(list rec)))
(((and elt (n s ($ $fun free ($ $cont kentry))))
(((and elt (n s ($ $fun free ($ $cont kfun))))
. nsf)
(if (recursive? kentry)
(if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
(define (extract-arities+bodies clauses)
@ -265,7 +265,7 @@
(match fun
((($ $fun free
($ $cont fun-k
($ $kentry src meta self ($ $cont tail-k ($ $ktail))
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
clause)))
...)
(call-with-values (lambda () (extract-arities+bodies clause))
@ -280,7 +280,7 @@
(match exp
(($ $fun free
($ $cont fun-k
($ $kentry src meta self ($ $cont tail-k ($ $ktail)) clause)))
($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k)
(lambda (sym)
(contify-fun term-k sym self tail-k
@ -350,8 +350,8 @@
,#f)
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))

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

@ -222,14 +222,14 @@ be that both true and false proofs are available."
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kif) '())
(($ $kentry src meta self) (list self))
(($ $kfun src meta self) (list self))
(($ $ktail) '())))
(lp (1+ n))))
defs))
(define (compute-label-and-var-ranges fun)
(match fun
(($ $fun free ($ $cont kentry ($ $kentry src meta self)))
(($ $fun free ($ $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))
@ -246,11 +246,11 @@ be that both true and false proofs are available."
(+ var-count (length vars))))
(($ $letk conts body) (lp body min-var var-count))
(_ (values min-label label-count min-var var-count)))))
(($ $kentry src meta self)
(($ $kfun src meta self)
(values min-label label-count (min self min-var) (1+ var-count)))
(_
(values min-label label-count min-var var-count)))))
fun kentry 0 self 0))))
fun kfun 0 self 0))))
(define (compute-idoms dfg min-label label-count)
(define (label->idx label) (- label min-label))
@ -423,16 +423,16 @@ be that both true and false proofs are available."
(vector-ref var-substs idx)
var)))
(define (visit-entry-cont cont)
(define (visit-fun-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body label))))
(($ $cont label ($ $kentry src meta self tail clause))
(label ($kentry src meta self ,tail
,(and clause (visit-entry-cont clause)))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-fun-cont clause)))))
(($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
(label ($kclause ,arity ,(visit-cont kbody body)
,(and alternate (visit-entry-cont alternate)))))))
,(and alternate (visit-fun-cont alternate)))))))
(define (visit-cont label cont)
(rewrite-cps-cont cont
@ -513,7 +513,7 @@ be that both true and false proofs are available."
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map subst-var free) ,(visit-entry-cont body)))))
($fun (map subst-var free) ,(visit-fun-cont body)))))
(define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))

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

@ -71,7 +71,7 @@
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kif) #f)
(($ $kentry src meta self) (list self))
(($ $kfun src meta self) (list self))
(($ $ktail) #f)))
(lp (1+ n))))
defs))
@ -163,7 +163,7 @@
(($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms))
(($ $kentry src meta self)
(($ $kfun src meta self)
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
@ -209,10 +209,10 @@
(build-cps-cont
(label ($kargs names syms
,(visit-term body label))))))))
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(list
(build-cps-cont
(label ($kentry src meta self ,tail
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))))
(($ $kclause arity body alternate)
(list

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

@ -326,7 +326,7 @@ body continuation in the prompt."
(match fun
(($ $fun free
($ $cont kentry ($ $kentry src meta self ($ $cont ktail tail))))
($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail))))
(call-with-values
(lambda ()
(compute-reverse-control-flow-order ktail dfg))
@ -822,13 +822,13 @@ body continuation in the prompt."
(match fun
(($ $fun free
($ $cont kentry
($ $cont kfun
(and entry
($ $kentry src meta self ($ $cont ktail tail) clause))))
(declare-block! kentry entry #f 0)
(add-def! self kentry)
($ $kfun src meta self ($ $cont ktail tail) clause))))
(declare-block! kfun entry #f 0)
(add-def! self kfun)
(declare-block! ktail tail kentry)
(declare-block! ktail tail kfun)
(let lp ((clause clause))
(match clause
@ -836,8 +836,8 @@ body continuation in the prompt."
(($ $cont kclause
(and clause ($ $kclause arity ($ $cont kbody body)
alternate)))
(declare-block! kclause clause kentry)
(link-blocks! kentry kclause)
(declare-block! kclause clause kfun)
(link-blocks! kfun kclause)
(declare-block! kbody body kclause)
(link-blocks! kclause kbody)
@ -883,7 +883,7 @@ body continuation in the prompt."
(else min-var))
(fold max max-var vars)
(+ var-count (length vars))))))
(($ $kentry src meta self)
(($ $kfun src meta self)
(values min-label max-label (1+ label-count)
(min* self min-var) (max self max-var) (1+ var-count)))
(_ (values min-label max-label (1+ label-count)

2
module/language/cps/effects-analysis.scm
View file

@ -487,7 +487,7 @@
(($ $arity _ () _ () #f) (logior (cause &allocation)
(cause &type-check)))))
(($ $kif) &no-effects)
(($ $kentry) (cause &type-check))
(($ $kfun) (cause &type-check))
(($ $kclause) (cause &type-check))
(($ $ktail) &no-effects)))
(lp (1+ n))))

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

@ -40,8 +40,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))

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

@ -50,8 +50,8 @@
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body ktail))))
(($ $cont label ($ $kentry src meta self tail clause))
(label ($kentry src meta self ,tail
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause ktail)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body ktail)
@ -88,10 +88,10 @@
(rewrite-cps-exp fun
(($ $fun free
($ $cont kentry
($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
($ $cont kfun
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
($fun free
(kentry ($kentry src meta self (ktail ($ktail))
(kfun ($kfun src meta self (ktail ($ktail))
,(and clause (visit-cont clause ktail))))))))
(define (prune-bailouts fun)

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

@ -41,7 +41,7 @@
(hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body))
(visit-term body))
(($ $cont k ($ $kentry src meta self tail clause))
(($ $cont k ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont k ($ $kclause arity body alternate))
(visit-cont body)
@ -94,8 +94,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))

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

@ -117,11 +117,11 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry src meta self (and tail ($ $cont ktail)) #f))
(($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
;; A case-lambda with no clauses. Reify a clause.
(sym ($kentry src meta self ,tail ,(reify-clause ktail))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail ,(visit-cont 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)))))

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

@ -92,7 +92,7 @@
(match cont
(($ $kargs names vars body)
(visit-term body))
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(visit-cont tail)
(when clause
(visit-cont clause)))
@ -131,7 +131,7 @@
(when reachable?
(for-each rename! vars))
(visit-term body reachable?))
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(unless reachable? (error "entry should be reachable"))
(rename! self)
(visit-cont tail)
@ -168,8 +168,8 @@
(collect-conts fun)
(match fun
(($ $fun free (and entry ($ $cont kentry)))
(set! next-label (sort-conts kentry labels next-label))
(($ $fun free (and entry ($ $cont kfun)))
(set! next-label (sort-conts kfun labels next-label))
(visit-cont entry)
(for-each compute-names-in-fun (reverse queue)))))
@ -211,9 +211,9 @@
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kentry src meta self tail clause)
(($ $kfun src meta self tail clause)
(label
($kentry src meta (rename self) ,(must-visit-cont tail)
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))

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

@ -35,8 +35,8 @@
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kentry src meta self tail clause))
(label ($kentry src meta self ,tail
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
@ -71,7 +71,7 @@
(define (visit-recursive-fun fun var)
(match fun
(($ $fun free (and cont ($ $cont _ ($ $kentry src meta self))))
(($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
(resolve-self-references fun (acons var self env)))))
(rewrite-cps-exp fun

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

@ -39,7 +39,7 @@
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body sym syms))
(($ $cont sym ($ $kentry src meta self tail clause))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@ -89,8 +89,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail
,(and clause (visit-cont clause sym)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body sym)
@ -130,7 +130,7 @@
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body))
(($ $cont sym ($ $kentry src meta self tail clause))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@ -186,8 +186,8 @@
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
(($ $kentry src meta self tail clause)
(sym ($kentry src meta self ,tail
(($ $kfun src meta self tail clause)
(sym ($kfun src meta self ,tail
,(and clause (must-visit-cont clause)))))
(($ $kclause arity body alternate)
(sym ($kclause ,arity ,(must-visit-cont body)

4
module/language/cps/slot-allocation.scm
View file

@ -337,7 +337,7 @@ are comparable with eqv?. A tmp slot may be used."
(let lp ((n 0))
(when (< n (vector-length usev))
(match (lookup-cont (idx->label n) dfg)
(($ $kentry src meta self)
(($ $kfun src meta self)
(vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body)
(vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
@ -671,7 +671,7 @@ are comparable with eqv?. A tmp slot may be used."
(error "Unexpected clause order"))))
(visit-clauses next live))))))
(match (lookup-cont (idx->label 0) dfg)
(($ $kentry src meta self)
(($ $kfun src meta self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
(compute-constants!)

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

@ -41,8 +41,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry src meta self ,tail
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)

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

@ -82,7 +82,7 @@
(error "name and sym lengths don't match" name sym))
(visit-term body k-env (add-vars sym v-env)))
(_
;; $kclause, $kentry, and $ktail are only ever seen in $fun.
;; $kclause, $kfun, and $ktail are only ever seen in $fun.
(error "unexpected cont body" cont))))
(define (visit-clause clause k-env v-env)
@ -117,7 +117,7 @@
(match fun
(($ $fun (free ...)
($ $cont kbody
($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free)

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

@ -294,11 +294,11 @@
arity gensyms inits)))
,(convert-clauses alternate ktail))))))))))
(if (current-topbox-scope)
(let-fresh (kentry ktail) (self)
(let-fresh (kfun ktail) (self)
(build-cps-term
($continue k fun-src
($fun '()
(kentry ($kentry fun-src meta self (ktail ($ktail))
(kfun ($kfun fun-src meta self (ktail ($ktail))
,(convert-clauses body ktail)))))))
(let ((scope-id (fresh-scope-id)))
(let-fresh (kscope) ()
@ -605,7 +605,7 @@ integer."
(let-fresh (kinit ktail kclause kbody) (init)
(build-cps-exp
($fun '()
(kinit ($kentry src '() init (ktail ($ktail))
(kinit ($kfun src '() init (ktail ($ktail))
(kclause
($kclause ('() '() #f '() #f)
(kbody ($kargs () ()