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

$prompt is now its own kind of CPS term.

Browse source 
* module/language/cps.scm ($prompt): Rework to be its own term kind.
  Now $continue always continues to a single continuation.  Adapt
  callers.
This commit is contained in:
Andy Wingo 2018-01-03 17:17:23 +01:00
parent 29fee39c2a
commit ee15ca1455
22 changed files with 198 additions and 195 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -34,6 +34,7 @@
(eval . (put '$letconst 'scheme-indent-function 1))
(eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$branch 'scheme-indent-function 3))
(eval . (put '$prompt 'scheme-indent-function 3))
(eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kfun 'scheme-indent-function 4))
(eval . (put '$letrec 'scheme-indent-function 3))

24
module/language/cps.scm
View file

@ -127,11 +127,11 @@
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
$continue $branch
$continue $branch $prompt
;; Expressions.
$const $prim $fun $rec $closure
$call $callk $primcall $values $prompt
$call $callk $primcall $values
;; Building macros.
build-cont build-term build-exp
@ -180,6 +180,7 @@
;; Terms.
(define-cps-type $continue k src exp)
(define-cps-type $branch kf kt src op param args)
(define-cps-type $prompt k kh src escape? tag)
;; Expressions.
(define-cps-type $const val)
@ -191,7 +192,6 @@
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name param args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
(define-syntax build-arity
(syntax-rules (unquote)
@ -229,12 +229,14 @@
((_ ($branch kf kt src op param (arg ...)))
(make-$branch kf kt src op param (list arg ...)))
((_ ($branch kf kt src op param args))
(make-$branch kf kt src op param args))))
(make-$branch kf kt src op param args))
((_ ($prompt k kh src escape? tag))
(make-$prompt k kh src escape? tag))))
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $closure
$call $callk $primcall $values $prompt)
$call $callk $primcall $values)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
@ -252,9 +254,7 @@
((_ ($primcall name param args)) (make-$primcall name param args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
((_ ($values args)) (make-$values args))))
(define-syntax-rule (rewrite-cont x (pat cont) ...)
(match x
@ -290,6 +290,8 @@
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('branch kf kt op param arg ...)
(build-term ($branch kf kt (src exp) op param arg)))
(('prompt k kh escape? tag)
(build-term ($prompt k kh (src exp) escape? tag)))
;; Expressions.
(('unspecified)
@ -312,8 +314,6 @@
(build-exp ($primcall name param arg)))
(('values arg ...)
(build-exp ($values arg)))
(('prompt escape? tag handler)
(build-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
@ -337,6 +337,8 @@
`(continue ,k ,(unparse-cps exp)))
(($ $branch kf kt src op param args)
`(branch ,kf ,kt ,op ,param ,@args))
(($ $prompt k kh src escape? tag)
`(prompt ,k ,kh ,escape? ,tag))
;; Expressions.
(($ $const val)
@ -361,7 +363,5 @@
`(primcall ,name ,param ,@args))
(($ $values args)
`(values ,@args))
(($ $prompt escape? tag handler)
`(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))

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

@ -90,11 +90,11 @@ conts."
(($ $call proc args)
(add-uses args uses))
(($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses))))
(add-uses args uses))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(add-uses args uses))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(add-use tag uses))
(_ uses)))
conts
empty-intset)))
@ -117,9 +117,9 @@ conts."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h))
(($ $kargs _ _ ($ $continue k)) (ref1 k))
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))))
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs _ _ ($ $prompt k kh)) (ref2 k kh))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@ -244,16 +244,16 @@ shared closures to use the appropriate 'self' variable, if possible."
(($ $primcall name param args)
($primcall name param ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))
($values ,(map subst args)))))
(define (visit-term term)
(rewrite-term term
(($ $continue k src exp)
($continue k src ,(visit-exp exp)))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))))
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
($prompt k kh src escape? (subst tag)))))
(define (visit-rec labels vars cps)
(define (compute-env label bound self rec-bound rec-labels env)
@ -374,11 +374,11 @@ references."
(($ $callk label proc args)
(add-use proc (add-uses args uses)))
(($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses))))
(add-uses args uses))))
(($ $branch kf kt src op param args)
(add-uses args uses)))))
(add-uses args uses))
(($ $prompt k kh src escape? tag)
(add-use tag uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
@ -726,13 +726,12 @@ bound to @var{var}, and continue to @var{k}."
(build-term
($continue k src ($values args)))))))
(($ $continue k src ($ $prompt escape? tag handler))
(($ $prompt k kh src escape? tag)
(convert-arg cps tag
(lambda (cps tag)
(with-cps cps
(build-term
($continue k src
($prompt escape? tag handler)))))))
($prompt k kh src escape? tag))))))
(($ $branch kf kt src op param args)
(convert-args cps args

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

@ -307,28 +307,6 @@
(define (compile-effect label exp k)
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-j asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (scope) (mod))
(emit-cache-current-module! asm (from-sp (slot mod)) scope))
(($ $primcall 'scm-set! annotation (obj idx val))
@ -428,6 +406,29 @@
(($ $primcall 'throw/value+data param (val))
(emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-prompt label k kh escape? tag)
(match (intmap-ref cps kh)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-j asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves kh allocation))
(emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body))))))
(define (compile-values label exp syms)
(match exp
(($ $values args)
@ -627,7 +628,11 @@
(emit-source asm src))
(compile-test label (skip-elided-conts (1+ label))
(forward-label kf) (forward-label kt)
op param args))))
op param args))
(($ $prompt k kh src escape? tag)
(when src
(emit-source asm src))
(compile-prompt label (skip-elided-conts k) kh escape? tag))))
(define (compile-cont label cont)
(match cont

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

@ -60,12 +60,9 @@ predecessor."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $branch kf kt))
(ref2 kf kt))
(($ $kargs names syms ($ $continue k src exp))
(match exp
(($ $prompt escape-only? tag handler) (ref2 k handler))
(_ (ref1 k))))))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
@ -192,11 +189,11 @@ $call, and are always called with a compatible arity."
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
(($ $primcall name param args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
(exclude-vars functions args))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(exclude-vars functions args))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(exclude-var functions tag))
(_ functions)))
(intmap-fold visit-cont conts functions)))
@ -459,7 +456,7 @@ function set."
(match term
(($ $continue k src exp)
(visit-exp cps k src exp))
(($ $branch)
((or ($ $branch) ($ $prompt))
(with-cps cps term))))
;; Renumbering is not strictly necessary but some passes may not be

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

@ -116,11 +116,9 @@ false. It could be that both true and false proofs are available."
(match (intmap-ref conts label)
(($ $kargs names vars term)
(match term
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $branch kf kt) (propagate-branch kf kt))))
(($ $continue k) (propagate1 k))
(($ $branch kf kt) (propagate-branch kf kt))
(($ $prompt k kh) (propagate2 k kh))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@ -168,7 +166,7 @@ false. It could be that both true and false proofs are available."
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))
(($ $branch)
((or ($ $branch) ($ $prompt))
'())))))
(compute-function-body conts kfun)))
@ -218,10 +216,10 @@ false. It could be that both true and false proofs are available."
(($ $callk k proc args) #f)
(($ $primcall name param args)
(cons* name param (subst-vars var-substs args)))
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(($ $values args) #f)))
(($ $branch kf kt src op param args)
(cons* op param (subst-vars var-substs args)))))
(cons* op param (subst-vars var-substs args)))
(($ $prompt) #f)))
(define (add-auxiliary-definitions! label var-substs term-key)
(let ((defs (and=> (intmap-ref defs label)
@ -377,9 +375,7 @@ false. It could be that both true and false proofs are available."
(($ $primcall name param args)
($primcall name param ,(map subst-var args)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
($values ,(map subst-var args)))))
(define (visit-term label term)
(match term
@ -403,7 +399,10 @@ false. It could be that both true and false proofs are available."
(build-term ($continue k src ($values vars))))
(#f
(build-term
($continue k src ,(visit-exp exp))))))))
($continue k src ,(visit-exp exp))))))
(($ $prompt k kh src escape? tag)
(build-term
($prompt k kh src escape? (subst-var tag))))))
(intmap-map
(lambda (label cont)

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

@ -84,6 +84,9 @@ sites."
;; Branches pass no values to their
;; continuations.
(values known unknown))
(($ $kargs _ _ ($ $prompt))
;; Likewise for prompts.
(values known unknown))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
@ -239,6 +242,11 @@ sites."
(visit-exp label k exp live-labels live-vars))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(visit-branch label kf kt args live-labels live-vars))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
;; Prompts need special elision passes that would contify
;; aborts and remove corresponding "unwind" primcalls.
(values (intset-add live-labels label)
(adjoin-var tag live-vars)))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
@ -346,7 +354,9 @@ sites."
(values cps term)
;; Dead branches continue to the same continuation
;; (eventually).
(values cps (build-term ($continue kf src ($values ()))))))))
(values cps (build-term ($continue kf src ($values ()))))))
(($ $prompt)
(values cps term))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)

8
module/language/cps/devirtualize-integers.scm
View file

@ -72,11 +72,11 @@
(($ $callk kfun proc args)
(add-uses (add-use use-counts proc) args))
(($ $primcall name param args)
(add-uses use-counts args))
(($ $prompt escape? tag handler)
(add-use use-counts tag))))
(($ $branch kf kt src op param args)
(add-uses use-counts args))))
(($ $branch kf kt src op param args)
(add-uses use-counts args))
(($ $prompt k kh src escape? tag)
(add-use use-counts tag))))
(_ use-counts)))
cps
(transient-intmap))))

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

@ -596,11 +596,6 @@ the LABELS that are clobbered by the effects of LABEL."
&no-effects)
((or ($ $fun) ($ $rec) ($ $closure))
(&allocate &unknown-memory-kinds))
(($ $prompt)
;; Although the "main" path just writes &prompt, we don't know what
;; nonlocal predecessors of the handler do, so we conservatively
;; assume &all-effects.
&all-effects)
((or ($ $call) ($ $callk))
&all-effects)
(($ $primcall name param args)
@ -614,6 +609,11 @@ the LABELS that are clobbered by the effects of LABEL."
(expression-effects exp))
(($ $kargs names syms ($ $branch kf kt src op param args))
(primitive-effects param op args))
(($ $kargs names syms ($ $prompt))
;; Although the "main" path just writes &prompt, we don't know
;; what nonlocal predecessors of the handler do, so we
;; conservatively assume &all-effects.
&all-effects)
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)

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

@ -68,7 +68,6 @@
loop-effects #t))
(match exp
((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ?
(($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))
@ -137,14 +136,6 @@
((not (loop-invariant? label exp loop-vars loop-effects
always-reached?))
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
(loop-vars (match exp
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive arity kargs)
(match (intmap-ref cps kargs)
(($ $kargs names vars)
(adjoin-loop-vars loop-vars vars))))))
(_ loop-vars)))
(cont (build-cont
($kargs names vars
($continue k src ,exp))))
@ -216,6 +207,16 @@
(($ $branch)
(let* ((cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?)))
(($ $prompt k kh src escape? tag)
(let* ((loop-vars (match (intmap-ref cps kh)
(($ $kreceive arity kargs)
(match (intmap-ref cps kargs)
(($ $kargs names vars)
(adjoin-loop-vars loop-vars vars))))))
(cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?))))))
(($ $kreceive ($ $arity req () rest) kargs)
@ -259,6 +260,9 @@
(($ $kargs names vars ($ $branch kf kt src op param args))
($kargs names vars
($branch (rename kf) (rename kt) src op param args)))
(($ $kargs names vars ($ $prompt k kh src escape? tag))
($kargs names vars
($prompt (rename k) (rename kh) src escape? tag)))
(($ $kargs names vars ($ $continue k src exp))
($kargs names vars
($continue (rename k) src ,exp)))

9
module/language/cps/peel-loops.scm
View file

@ -142,16 +142,17 @@
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
($primcall name param ,(map rename-var args)))))
(define (rename-term term)
(rewrite-term term
(($ $continue k src exp)
($continue (rename-label k) src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch (rename-label kf) (rename-label kt) src
op param ,(map rename-var args)))))
op param ,(map rename-var args)))
(($ $prompt k kh src escape? tag)
($prompt (rename-label k) (rename-label kh) src
escape? (rename-var tag)))))
(rewrite-cont cont
(($ $kargs names vars term)
($kargs names (map rename-var vars) ,(rename-term term)))

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

@ -87,16 +87,14 @@
(match (intmap-ref conts k)
(($ $kargs names syms term)
(match term
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler)
(visit2 k handler order visited))
(_
(visit k order visited))))
(($ $continue k)
(visit k order visited))
(($ $branch kf kt)
(if (visit-kf-first? kf kt)
(visit2 kf kt order visited)
(visit2 kt kf order visited)))))
(visit2 kt kf order visited)))
(($ $prompt k kh)
(visit2 k kh order visited))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
@ -180,9 +178,7 @@
(($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
($primcall name param ,(map rename-var args)))))
(define (rename-arity arity)
(match arity
(($ $arity req opt rest () aok?)
@ -207,7 +203,10 @@
($continue (rename-label k) src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch (rename-label kf) (rename-label kt) src
op param ,(map rename-var args))))))
op param ,(map rename-var args)))
(($ $prompt k kh src escape? tag)
($prompt (rename-label k) (rename-label kh) src
escape? (rename-var tag))))))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k)))
(($ $ktail)

10
module/language/cps/rotate-loops.scm
View file

@ -118,11 +118,11 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
(($ $callk k proc args)
($callk k (rename proc) ,(rename* args)))
(($ $primcall name param args)
($primcall name param ,(rename* args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename tag) handler)))))
($primcall name param ,(rename* args))))))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(rename* args)))))
($branch kf kt src op param ,(rename* args)))
(($ $prompt k kh src escape? tag)
($prompt k kh src escape? (rename tag)))))
(define (attach-trampoline cps label src names vars args)
(with-cps cps
(letk ktramp-out ,(make-trampoline join-label src args))
@ -211,7 +211,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
(trivial-intset (loop-successors scc succs))
(match (intmap-ref cps entry)
;; Can't rotate $prompt out of loop header.
(($ $kargs _ _ ($ $continue _ _ ($ $prompt))) #f)
(($ $kargs _ _ ($ $prompt)) #f)
(_ #t)))
;; Loop header is an exit, and there is only one
;; exit continuation. Loop header isn't a prompt,

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

@ -46,16 +46,16 @@
(($ $primcall name param args)
($primcall name param ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))
($values ,(map subst args)))))
(define (rename-term term)
(rewrite-term term
(($ $continue k src exp)
($continue k src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))))
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
($prompt k kh src escape? (subst tag)))))
(define (visit-label label cps)
(match (intmap-ref cps label)

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

@ -77,11 +77,11 @@
(($ $primcall name param args)
(ref* args))
(($ $values args)
(ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
(ref* args))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(ref* args))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(ref tag))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
@ -188,12 +188,9 @@
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(match exp
(($ $prompt _ _ handler) (ref2 k handler))
(_ (ref1 k))))
(($ $kargs names syms ($ $branch kf kt))
(ref2 kf kt))))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@ -259,11 +256,11 @@
(($ $primcall name param args)
($primcall name param ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))
($values ,(map subst args))))))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args))))))
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
($prompt k kh src escape? (subst tag))))))
(transform-conts
(lambda (label cont)
(rewrite-cont cont

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

@ -57,7 +57,7 @@
(representations allocation-representations)
;; A map of LABEL to /call allocs/, for expressions that continue to
;; $kreceive continuations: non-tail calls and $prompt expressions.
;; $kreceive continuations: non-tail calls and $prompt terms.
;;
;; A call alloc contains two pieces of information: the call's /proc
;; slot/ and a /dead slot map/. The proc slot indicates the slot of a
@ -155,11 +155,11 @@ by a label, respectively."
(($ $primcall name param args)
(return (get-defs k) (vars->intset args)))
(($ $values args)
(return (get-defs k) (vars->intset args)))
(($ $prompt escape? tag handler)
(return empty-intset (intset tag)))))
(return (get-defs k) (vars->intset args)))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(return empty-intset (vars->intset args)))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(return empty-intset (intset tag)))
(($ $kclause arity body alt)
(return (get-defs body) empty-intset))
(($ $kreceive arity kargs)
@ -231,11 +231,10 @@ body continuation in the prompt."
(let ((labels (intset-add! labels label)))
(match cont
(($ $kreceive arity k) (visit-cont k level labels))
(($ $kargs names syms ($ $prompt k kh src escape? tag))
(visit-cont kh level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
(visit-cont k (1+ level) labels))
(($ $kargs names syms
($ $continue k src ($ $prompt escape? tag handler)))
(visit-cont handler level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
(visit-cont k (1- level) labels))
(($ $kargs names syms ($ $continue k src exp))
@ -261,9 +260,8 @@ body continuation in the prompt."
(intmap-fold
(lambda (label cont succs)
(match cont
(($ $kargs _ _
($ $continue k _ ($ $prompt escape? tag handler)))
(visit-prompt k handler succs))
(($ $kargs _ _ ($ $prompt k kh))
(visit-prompt k kh succs))
(_ succs)))
conts
succs))
@ -596,9 +594,9 @@ are comparable with eqv?. A tmp slot may be used."
(add-call-shuffles label k (cons proc args) shuffles))
(($ $values args)
(add-values-shuffles label k args shuffles))
(($ $prompt escape? tag handler)
(add-prompt-shuffles label k handler shuffles))
(_ shuffles)))
(($ $kargs names vars ($ $prompt k kh src escape? tag))
(add-prompt-shuffles label k kh shuffles))
(_ shuffles)))
(persistent-intmap
@ -746,6 +744,8 @@ are comparable with eqv?. A tmp slot may be used."
(match cont
(($ $kargs _ _ ($ $branch))
representations)
(($ $kargs _ _ ($ $prompt))
representations)
(($ $kargs _ _ ($ $continue k _ exp))
(match (get-defs k)
(() representations)
@ -981,8 +981,8 @@ are comparable with eqv?. A tmp slot may be used."
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $continue k src ($ $values args))
(allocate-values label k args slots call-allocs))
(($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler slots call-allocs))
(($ $prompt k kh src escape? tag)
(allocate-prompt label k kh slots call-allocs))
(_
(values slots call-allocs)))))
(_

8
module/language/cps/specialize-numbers.scm
View file

@ -335,11 +335,11 @@ BITS indicating the significant bits needed for a variable. BITS may be
(match (intmap-ref cps k)
(($ $kargs _ defs)
(h label types out param args defs)))
(add-unknown-uses out args))))
(($ $prompt escape? tag handler)
(add-unknown-use out tag))))
(add-unknown-uses out args))))))
(($ $branch kf kt src op param args)
(add-unknown-uses out args)))))
(add-unknown-uses out args))
(($ $prompt k kh src escape? tag)
(add-unknown-use out tag)))))
(_ out)))))))))
(define (specialize-operations cps)

8
module/language/cps/split-rec.scm
View file

@ -90,11 +90,11 @@ references."
(($ $call proc args)
(add-use proc (add-uses args uses)))
(($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses))))
(add-uses args uses))))
(($ $branch kf kt src op param args)
(add-uses args uses)))))
(add-uses args uses))
(($ $prompt k kh src escape? tag)
(add-use tag uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))

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

@ -1775,11 +1775,9 @@ minimum, and maximum."
(define (successor-count cont)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(match exp
(($ $prompt) 2)
(_ 1)))
(($ $kargs _ _ ($ $continue)) 1)
(($ $kargs _ _ ($ $branch)) 2)
(($ $kargs _ _ ($ $prompt)) 2)
(($ $kfun src meta self tail clause) (if clause 1 0))
(($ $kclause arity body alt) (if alt 2 1))
(($ $kreceive) 1)
@ -1916,9 +1914,6 @@ maximum, where type is a bitset as a fixnum."
(values (append changed0 changed1) typev)))
;; Each of these branches must propagate to its successors.
(match exp
(($ $prompt escape? tag handler)
;; The "normal" continuation enters the prompt.
(propagate2 k types handler types))
(($ $primcall name param args)
(propagate1 k
(match (intmap-ref conts k)
@ -1979,6 +1974,9 @@ maximum, where type is a bitset as a fixnum."
;; The "normal" continuation is the #f branch.
(propagate2 kf (infer-primcall types 0 op param args #f)
kt (infer-primcall types 1 op param args #f)))
(($ $kargs names vars ($ $prompt k kh src escape? tag))
;; The "normal" continuation enters the prompt.
(propagate2 k types kh types))
(($ $kreceive arity k)
(match (intmap-ref conts k)
(($ $kargs names vars)

24
module/language/cps/utils.scm
View file

@ -200,12 +200,12 @@ disjoint, an error will be signalled."
(visit-cont kbody labels)))
(($ $kargs names syms term)
(match term
(($ $continue k src ($ $prompt escape? tag handler))
(visit-cont k (visit-cont handler labels)))
(($ $continue k)
(visit-cont k labels))
(($ $branch kf kt)
(visit-cont kf (visit-cont kt labels))))))))))))
(visit-cont kf (visit-cont kt labels)))
(($ $prompt k kh)
(visit-cont k (visit-cont kh labels))))))))))))
(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
@ -260,11 +260,9 @@ intset."
(match (intmap-ref conts label)
(($ $kargs names vars term)
(match term
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $branch kf kt) (propagate2 kf kt))))
(($ $continue k) (propagate1 k))
(($ $branch kf kt) (propagate2 kf kt))
(($ $prompt k kh) (propagate2 k kh))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@ -296,13 +294,9 @@ intset."
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
(($ $kargs names syms term)
(match term
(($ $continue k src exp)
(add-pred k
(match exp
(($ $prompt _ _ k) (add-pred k preds))
(_ preds))))
(($ $branch kf kt)
(add-pred kf (add-pred kt preds)))))))
(($ $continue k) (add-pred k preds))
(($ $branch kf kt) (add-pred kf (add-pred kt preds)))
(($ $prompt k kh) (add-pred k (add-pred kh preds)))))))
(persistent-intmap
(intset-fold add-preds labels
(intset->intmap (lambda (label) '()) labels))))

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

@ -102,12 +102,12 @@ definitions that are available at LABEL."
(($ $kargs names vars term)
(let ((out (fold1 adjoin-def vars in)))
(match term
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (propagate2 k handler out))
(_ (propagate1 k out))))
(($ $continue k)
(propagate1 k out))
(($ $branch kf kt)
(propagate2 kf kt out)))))
(propagate2 kf kt out))
(($ $prompt k kh)
(propagate2 k kh out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
@ -164,9 +164,6 @@ definitions that are available at LABEL."
(visit-first-order kfun))
(($ $primcall name param args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
(define (visit-term term bound first-order)
(define (check-use var)
@ -203,12 +200,12 @@ definitions that are available at LABEL."
(visit-first-order kfun))
(($ $primcall name param args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
(($ $branch kf kt src name param args)
(for-each check-use args)
first-order)
(($ $prompt k kh src escape? tag)
(check-use tag)
first-order)))
(intmap-fold
(lambda (label bound first-order)
@ -285,12 +282,7 @@ definitions that are available at LABEL."
(($ $kreceive) #t)
(($ $ktail)
(unless (memv name '(throw throw/value throw/value+data))
(error "primitive should continue to $kargs, not $ktail" name)))))
(($ $prompt escape? tag handler)
(assert-nullary)
(match (intmap-ref conts handler)
(($ $kreceive) #t)
(cont (error "bad handler" cont))))))
(error "primitive should continue to $kargs, not $ktail" name)))))))
(define (check-term term)
(match term
(($ $continue k src exp)
@ -301,7 +293,14 @@ definitions that are available at LABEL."
(cont (error "bad kf" cont)))
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))))
(cont (error "bad kt" cont))))
(($ $prompt k kh src escape? tag)
(match (intmap-ref conts k)
(($ $kargs () ()) #t)
(cont (error "bad prompt body" cont)))
(match (intmap-ref conts kh)
(($ $kreceive) #t)
(cont (error "bad prompt handler" cont))))))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)

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

@ -853,7 +853,7 @@
(with-cps cps
(let$ body (convert body krest subst))
(letk kbody ($kargs () () ,body))
(build-term ($continue kbody src ($prompt #t tag khargs))))
(build-term ($prompt kbody khargs src #t tag)))
(convert-arg cps body
(lambda (cps thunk)
(with-cps cps
@ -861,8 +861,8 @@
($continue krest (tree-il-src body)
($primcall 'call-thunk/no-inline #f
(thunk)))))
(build-term ($continue kbody (tree-il-src body)
($prompt #f tag khargs))))))))
(build-term ($prompt kbody khargs (tree-il-src body)
#f tag)))))))
(with-cps cps
(letv prim vals apply)
(let$ hbody (convert hbody k subst))