wingo pushed a commit to branch main
in repository guile.
commit 711077586b6ebe3479bac54f59ceb8c24603acd0
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Thu Nov 23 12:02:53 2023 +0100
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.
---
module/language/tree-il/compile-bytecode.scm | 7 +++++++
module/language/tree-il/compile-cps.scm | 17 +++++++++++++++++
module/language/tree-il/peval.scm | 11 +++--------
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 '())
