diff options
author | Andy Wingo <wingo@pobox.com> | 2018-01-03 18:25:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-01-03 21:25:55 +0100 |
commit | ad55ee83c341dc54c3f38bb39004973d0ebbb4ab (patch) | |
tree | d77a529ef71eb44189532617d379d889da343870 /module/language/cps/compile-bytecode.scm | |
parent | de5c81b1d14e29799e7ba957f5db1db1231207e2 (diff) | |
download | guile-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.scm | 21 |
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 |