[Guile-commits] 03/04: Top-level lookups raise exceptions in run-time

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 85124b0d690ca2f4e1e73e32ff8ec65803b756de
Author: Andy Wingo <address@hidden>
AuthorDate: Mon May 11 10:22:56 2020 +0200

    Top-level lookups raise exceptions in run-time
    
    * module/language/cps/reify-primitives.scm (reify-lookup):
    * module/language/tree-il/compile-cps.scm (toplevel-box): Instead of
      checking that the result of module-variable is a variable, and
      possibly checking that it's bound, we just call intrinsics that throw
      exceptions if the variable isn't bound.  This reduces useless inlining
      that can't inform CPS optimizations, as they are tangled in diamond
      control flow.
---
 module/language/cps/reify-primitives.scm | 32 ++++++--------------------------
 module/language/tree-il/compile-cps.scm  | 28 ++++------------------------
 2 files changed, 10 insertions(+), 50 deletions(-)

diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 98cf85d..5fc86cc 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -201,34 +201,14 @@
   (wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a))
 
 (define (reify-lookup cps src mod-var name assert-bound? have-var)
-  (define (%lookup cps kbad k src mod-var name-var var assert-bound?)
-    (if assert-bound?
-        (with-cps cps
-          (letv val)
-          (letk kcheck
-                ($kargs ('val) (val)
-                  ($branch k kbad src 'undefined? #f (val))))
-          (letk kref
-                ($kargs () ()
-                  ($continue kcheck src
-                    ($primcall 'scm-ref/immediate '(box . 1) (var)))))
-          ($ (%lookup kbad kref src mod-var name-var var #f)))
-        (with-cps cps
-          (letk kres
-                ($kargs ('var) (var)
-                  ($branch kbad k src 'heap-object? #f (var))))
-          (build-term
-            ($continue kres src
-              ($primcall 'module-variable #f (mod-var name-var)))))))
-  (define %unbound
-    #(unbound-variable #f "Unbound variable: ~S"))
   (with-cps cps
     (letv name-var var)
-    (let$ good (have-var var))
-    (letk kgood ($kargs () () ,good))
-    (letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
-    (let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?))
-    (letk klookup ($kargs ('name) (name-var) ,body))
+    (let$ body (have-var var))
+    (letk kres ($kargs ('var) (var) ,body))
+    (letk klookup ($kargs ('name) (name-var)
+                    ($continue kres src
+                      ($primcall (if assert-bound? 'lookup-bound 'lookup) #f
+                                 (mod-var name-var)))))
     (build-term ($continue klookup src ($const name)))))
 
 (define (reify-resolve-module cps k src module public?)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index d75807d..703e9fd 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1401,36 +1401,16 @@
     scope-id))
 
 (define (toplevel-box cps src name bound? have-var)
-  (define %unbound
-    #(unbound-variable #f "Unbound variable: ~S"))
   (match (current-topbox-scope)
     (#f
      (with-cps cps
        (letv mod name-var box)
-       (letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
-       (let$ body
-             ((if bound?
-                  (lambda (cps)
-                    (with-cps cps
-                      (letv val)
-                      (let$ body (have-var box))
-                      (letk kdef ($kargs () () ,body))
-                      (letk ktest ($kargs ('val) (val)
-                                    ($branch kdef kbad src
-                                      'undefined? #f (val))))
-                      (build-term
-                        ($continue ktest src
-                          ($primcall 'scm-ref/immediate
-                                     '(box . 1) (box))))))
-                  (lambda (cps)
-                    (with-cps cps
-                      ($ (have-var box)))))))
-       (letk ktest ($kargs () () ,body))
-       (letk kbox ($kargs ('box) (box)
-                    ($branch kbad ktest src 'heap-object? #f (box))))
+       (let$ body (have-var box))
+       (letk kbox ($kargs ('box) (box) ,body))
        (letk kname ($kargs ('name) (name-var)
                      ($continue kbox src
-                       ($primcall 'module-variable #f (mod name-var)))))
+                       ($primcall (if bound? 'lookup-bound 'lookup) #f
+                                  (mod name-var)))))
        (letk kmod ($kargs ('mod) (mod)
                     ($continue kname src ($const name))))
        (build-term