[Guile-commits] 03/03: Allow targets to preclude unbound variables

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 5ef0ea30faf9fa980681e3b6e24eb9a3884ec83d
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Nov 23 12:31:38 2023 +0100

    Allow targets to preclude unbound variables
    
    Allowing variables to hold an unbound value and requiring a check on
    each load is suboptimal; the fixing letrec boolean check is better.  So
    other runtimes (hoot) might preclude unbound variables by construction.
    Allow them to do so.
    
    * module/language/cps/guile-vm.scm (target-has-unbound-boxes?): New
    definition.
    * module/language/tree-il/compile-cps.scm (target-has-unbound-boxes?):
    (%box-ref): Only residualize an unbound check if the target has unbound
    boxes.
---
 module/language/cps/guile-vm.scm        |  5 ++++-
 module/language/tree-il/compile-cps.scm | 40 +++++++++++++++++++++++----------
 2 files changed, 32 insertions(+), 13 deletions(-)

diff --git a/module/language/cps/guile-vm.scm b/module/language/cps/guile-vm.scm
index 772783349..193907f2b 100644
--- a/module/language/cps/guile-vm.scm
+++ b/module/language/cps/guile-vm.scm
@@ -31,7 +31,8 @@
   #:export (make-lowerer
             available-optimizations
             target-symbol-hash
-            target-symbol-hash-bits))
+            target-symbol-hash-bits
+            target-has-unbound-boxes?))
 
 ;; This hash function is originally from
 ;; http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
@@ -107,3 +108,5 @@
 
 (define (available-optimizations)
   '())
+
+(define target-has-unbound-boxes? #t)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 58e4ab9b7..8f638fd53 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -486,20 +486,36 @@
            ($continue k src
              ($primcall 'set-cdr! #f (pair val)))))))))
 
+(define target-has-unbound-boxes?
+  (let ((cache (make-hash-table)))
+    (lambda ()
+      (let ((rt (target-runtime)))
+        (match (hashq-get-handle cache rt)
+          ((k . v) v)
+          (#f (let ((iface (resolve-interface `(language cps ,rt))))
+                (define v (module-ref iface 'target-has-unbound-boxes?))
+                (hashq-set! cache rt v)
+                v)))))))
+
 (define-primcall-converter %box-ref
   (lambda (cps k src op param box)
-    (define unbound
-      #(misc-error "variable-ref" "Unbound variable: ~S"))
-    (with-cps cps
-      (letv val)
-      (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box))))
-      (letk kbound ($kargs () () ($continue k src ($values (val)))))
-      (letk ktest
-            ($kargs ('val) (val)
-              ($branch kbound kunbound src 'undefined? #f (val))))
-      (build-term
-        ($continue ktest src
-          ($primcall 'box-ref #f (box)))))))
+    (cond
+     ((target-has-unbound-boxes?)
+      (define unbound
+        #(misc-error "variable-ref" "Unbound variable: ~S"))
+      (with-cps cps
+        (letv val)
+        (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box))))
+        (letk kbound ($kargs () () ($continue k src ($values (val)))))
+        (letk ktest
+              ($kargs ('val) (val)
+                ($branch kbound kunbound src 'undefined? #f (val))))
+        (build-term
+          ($continue ktest src
+            ($primcall 'box-ref #f (box))))))
+     (else
+      (with-cps cps
+        ($continue k src ($primcall 'box-ref #f (box))))))))
 
 (define-primcall-converter %box-set!
   (lambda (cps k src op param box val)