summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-03 17:17:23 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-03 17:32:43 +0100
commitee15ca1455806b04f4785655ec8a2fd9dda6c01c (patch)
tree532b7604609085928a652af8330a333c360ca240 /module
parent29fee39c2aafc13245fb5fd48bcf6db195251282 (diff)
downloadguile-ee15ca1455806b04f4785655ec8a2fd9dda6c01c.tar.gz
$prompt is now its own kind of CPS term.
* module/language/cps.scm ($prompt): Rework to be its own term kind. Now $continue always continues to a single continuation. Adapt callers.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps.scm24
-rw-r--r--module/language/cps/closure-conversion.scm31
-rw-r--r--module/language/cps/compile-bytecode.scm51
-rw-r--r--module/language/cps/contification.scm17
-rw-r--r--module/language/cps/cse.scm25
-rw-r--r--module/language/cps/dce.scm12
-rw-r--r--module/language/cps/devirtualize-integers.scm8
-rw-r--r--module/language/cps/effects-analysis.scm10
-rw-r--r--module/language/cps/licm.scm22
-rw-r--r--module/language/cps/peel-loops.scm9
-rw-r--r--module/language/cps/renumber.scm21
-rw-r--r--module/language/cps/rotate-loops.scm10
-rw-r--r--module/language/cps/self-references.scm8
-rw-r--r--module/language/cps/simplify.scm23
-rw-r--r--module/language/cps/slot-allocation.scm28
-rw-r--r--module/language/cps/specialize-numbers.scm8
-rw-r--r--module/language/cps/split-rec.scm8
-rw-r--r--module/language/cps/types.scm12
-rw-r--r--module/language/cps/utils.scm24
-rw-r--r--module/language/cps/verify.scm35
-rw-r--r--module/language/tree-il/compile-cps.scm6
21 files changed, 197 insertions, 195 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm
index ddd4102ab..771d65649 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -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))))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index b15bb632a..32472f19d 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -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
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 0bef330f5..552f0a41b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index ca1a292ac..8266a2383 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -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
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 8f4ae6d23..3591485aa 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -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)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 829ab3613..7fdbfcfa8 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -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)
diff --git a/module/language/cps/devirtualize-integers.scm b/module/language/cps/devirtualize-integers.scm
index 9ebe6fc84..350e2ae8e 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -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))))
+ (add-uses use-counts args))))
(($ $branch kf kt src op param args)
- (add-uses use-counts args))))
+ (add-uses use-counts args))
+ (($ $prompt k kh src escape? tag)
+ (add-use use-counts tag))))
(_ use-counts)))
cps
(transient-intmap))))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 854bd11b8..62cefa0d2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index b016b3b41..b1af1c831 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -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))))
@@ -217,6 +208,16 @@
(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)
(values cps cont loop-vars loop-effects pre-header-label
@@ -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)))
diff --git a/module/language/cps/peel-loops.scm b/module/language/cps/peel-loops.scm
index 0f2345130..e8144fdd8 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.scm
@@ -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)))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index ba565c1c1..8adbba93a 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -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)
diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm
index dbc2f9e5e..4c330f90a 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -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,
diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm
index f1ffc4afd..10fcb7f53 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -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)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index f546583d4..a1ac5c9cd 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -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
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 8abb0eafb..106496a1a 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -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)))))
(_
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index 73fd00427..9c0b89548 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -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)
diff --git a/module/language/cps/split-rec.scm b/module/language/cps/split-rec.scm
index 2f60b9948..a38a889d8 100644
--- a/module/language/cps/split-rec.scm
+++ b/module/language/cps/split-rec.scm
@@ -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))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index bb3462463..ec74e6700 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -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)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index cc153c2b9..d8e47e12f 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -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))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 1e0537046..9020c5efc 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -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)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index ae02113f2..dbdc45cef 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -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))