diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-23 12:02:53 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-23 12:11:22 +0100 |
commit | 711077586b6ebe3479bac54f59ceb8c24603acd0 (patch) | |
tree | 8808004e2a19ab2705f00a45551d7258dfc18423 /module/language | |
parent | 4118f090304739c01b9204323a17ba30d3f00403 (diff) | |
download | guile-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.scm | 7 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 17 | ||||
-rw-r--r-- | 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 '()) |