summaryrefslogtreecommitdiff
path: root/module/language/cps/compile-bytecode.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-03 18:25:42 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-03 21:25:55 +0100
commitad55ee83c341dc54c3f38bb39004973d0ebbb4ab (patch)
treed77a529ef71eb44189532617d379d889da343870 /module/language/cps/compile-bytecode.scm
parentde5c81b1d14e29799e7ba957f5db1db1231207e2 (diff)
downloadguile-ad55ee83c341dc54c3f38bb39004973d0ebbb4ab.tar.gz
$throw is a new kind of CPS term
* module/language/cps.scm ($throw): New term type that doesn't have a continuation. Adapt all callers. Remove now-unneeded "prune-bailouts" pass.
Diffstat (limited to 'module/language/cps/compile-bytecode.scm')
-rw-r--r--module/language/cps/compile-bytecode.scm21
1 files changed, 13 insertions, 8 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 552f0a41b..79459cf0e 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -125,9 +125,7 @@
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
- (emit-return-values asm (1+ (length args))))
- (($ $primcall (or 'throw 'throw/value 'throw/value+data))
- (compile-effect label exp #f))))
+ (emit-return-values asm (1+ (length args))))))
(define (compile-value label exp dst)
(match exp
@@ -398,12 +396,15 @@
(($ $primcall 'atomic-box-set! #f (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts #f ())
- (emit-handle-interrupts asm))
- (($ $primcall 'throw #f (key args))
+ (emit-handle-interrupts asm))))
+
+ (define (compile-throw op param args)
+ (match (vector op param args)
+ (#('throw #f (key args))
(emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
- (($ $primcall 'throw/value param (val))
+ (#('throw/value param (val))
(emit-throw/value asm (from-sp (slot val)) param))
- (($ $primcall 'throw/value+data param (val))
+ (#('throw/value+data param (val))
(emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-prompt label k kh escape? tag)
@@ -632,7 +633,11 @@
(($ $prompt k kh src escape? tag)
(when src
(emit-source asm src))
- (compile-prompt label (skip-elided-conts k) kh escape? tag))))
+ (compile-prompt label (skip-elided-conts k) kh escape? tag))
+ (($ $throw src op param args)
+ (when src
+ (emit-source asm src))
+ (compile-throw op param args))))
(define (compile-cont label cont)
(match cont