[Guile-commits] 01/03: peval avoids introducing 'throw

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 711077586b6ebe3479bac54f59ceb8c24603acd0
Author: Andy Wingo <wingo@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 '())