summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-08-28 12:03:17 +0200
committerAndy Wingo <wingo@pobox.com>2023-08-28 12:11:19 +0200
commitc2cba86785a34351788f52ea4fccf9f10f3a1dee (patch)
tree863e975d9d2728e52d242de954b96a5d71c4a668 /module/language
parenta52c9cf7c3eefe05da23cd3233e1f9119eb14862 (diff)
downloadguile-c2cba86785a34351788f52ea4fccf9f10f3a1dee.tar.gz
Better compilation of calls to `raise-exception`
Recognize `raise-exception` in the same way we recognize `throw`, though it is a bit less optimized and the boot story is not as complicated. * doc/ref/vm.texi (Non-Local Control Flow Instructions): * libguile/jit.c (compile_unreachable): (compile_unreachable_slow): * libguile/vm-engine.c (VM_NAME): * module/language/cps/compile-bytecode.scm (compile-function): * module/system/vm/assembler.scm (emit-unreachable): Add new "unreachable" instruction, inserted after a call to non-continuable `raise-exception`. * module/language/tree-il/compile-cps.scm (raise-exception): * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Recognize raise-exception, and if it is called with just one argument, prune that branch of the control-flow graph.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/compile-bytecode.scm4
-rw-r--r--module/language/tree-il/compile-cps.scm27
-rw-r--r--module/language/tree-il/primitives.scm2
3 files changed, 31 insertions, 2 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index d6d1737b3..ad5e0024d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -417,7 +417,9 @@
(#('throw/value param (val))
(emit-throw/value asm (from-sp (slot val)) param))
(#('throw/value+data param (val))
- (emit-throw/value+data asm (from-sp (slot val)) param))))
+ (emit-throw/value+data asm (from-sp (slot val)) param))
+ (#('unreachable #f ())
+ (emit-unreachable asm))))
(define (compile-prompt label k kh escape? tag)
(let ((receive-args (gensym "handler"))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index ff22fa5ca..9ebdb72a3 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1478,6 +1478,33 @@ use as the proc slot."
(_ (fallback)))))
(_ (fallback))))
+(define-custom-primcall-converter (raise-exception cps src args convert-args k)
+ ;; When called with just one arg, we know that raise-exception is
+ ;; non-continuing, and so we can prune the graph at its continuation.
+ ;; This improves flow analysis, because the path that leads to the
+ ;; raise-exception doesn't rejoin the graph.
+ (convert-args cps args
+ (lambda (cps args)
+ (define (maybe-prune-graph cps k)
+ (match args
+ ((_)
+ (with-cps cps
+ (letv vals)
+ (letk kunreachable ($kargs (#f) (vals)
+ ($throw src 'unreachable #f ())))
+ (letk kret ($kreceive '() 'rest kunreachable))
+ kret))
+ (_
+ (with-cps cps
+ k))))
+ (with-cps cps
+ (letv prim)
+ (let$ k (maybe-prune-graph k))
+ (letk kcall ($kargs ('prim) (prim)
+ ($continue k src ($call prim args))))
+ (build-term
+ ($continue kcall src ($prim 'raise-exception)))))))
+
(define-custom-primcall-converter (values cps src args convert-args k)
(convert-args cps args
(lambda (cps args)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index ef883ec9c..bcd2a1c05 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -95,7 +95,7 @@
abort-to-prompt* abort-to-prompt
make-prompt-tag
- throw error scm-error
+ throw error scm-error raise-exception
string-length string-ref string-set!