From 85124b0d690ca2f4e1e73e32ff8ec65803b756de Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 11 May 2020 10:22:56 +0200
Subject: [PATCH] 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 98cf85d1a..5fc86ccf5 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 d75807dec..703e9fd5f 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