summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-23 12:02:53 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-23 12:11:22 +0100
commit711077586b6ebe3479bac54f59ceb8c24603acd0 (patch)
tree8808004e2a19ab2705f00a45551d7258dfc18423 /module/language
parent4118f090304739c01b9204323a17ba30d3f00403 (diff)
downloadguile-711077586b6ebe3479bac54f59ceb8c24603acd0.tar.gz
peval avoids introducing 'throw
* module/language/tree-il/peval.scm (peval): Introduce raise-type-error for dynwind unwinder thunk check. * module/language/tree-il/compile-cps.scm (raise-type-error): * module/language/tree-il/compile-bytecode.scm (canonicalize): Handle raise-type-error, as it can be in Tree-IL now.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/tree-il/compile-bytecode.scm7
-rw-r--r--module/language/tree-il/compile-cps.scm17
-rw-r--r--module/language/tree-il/peval.scm11
3 files changed, 27 insertions, 8 deletions
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm
index d98c40fe9..8418f089a 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -446,6 +446,13 @@
(make-primcall src 'throw
(list key (make-primcall #f 'list args))))
+ (($ <primcall> src 'raise-type-error (($ <const> _ #(subr pos what)) x))
+ (define msg
+ (format #f "Wrong type argument in position ~a (expecting ~a): ~~S"
+ pos what))
+ (make-primcall src 'throw/value+data
+ (list x (make-const #f `#(wrong-type-arg ,subr ,msg)))))
+
;; Now that we handled special cases, ensure remaining primcalls
;; are understood by the code generator, and if not, reify them
;; as calls.
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 5ef590e35..58e4ab9b7 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1513,6 +1513,23 @@ use as the proc slot."
(build-term
($throw src 'raise-exception #f (exn)))))))))
+(define-custom-primcall-converter (raise-type-error cps src args convert-args k)
+ (match args
+ ((($ <const> _ #((? string? proc-name)
+ (? exact-integer? pos)
+ (? string? what)))
+ val)
+ ;; 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 (list val)
+ (lambda (cps vals)
+ (with-cps cps
+ (build-term
+ ($throw src 'raise-type-error (vector proc-name pos what)
+ vals))))))))
+
(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/peval.scm b/module/language/tree-il/peval.scm
index 1abb0f08d..c39069f69 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1270,14 +1270,9 @@ top-level bindings from ENV and return the resulting expression."
;; fixme: introduce logic to fold thunk?
(make-primcall src 'thunk? (list u))
(make-call src w '())
- (make-primcall
- src 'throw
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "dynamic-wind")
- (make-const #f "Wrong type (expecting thunk): ~S")
- (make-primcall #f 'list (list u))
- (make-primcall #f 'list (list u)))))
+ (make-primcall src 'raise-type-error
+ (list (make-const #f #("dynamic-wind" 3 "thunk"))
+ u)))
(make-primcall src 'wind (list w u)))
(make-begin0 src
(make-call src thunk '())