Add "mod" field to tree-il toplevel ref, set, define

Add "mod" field to <toplevel-ref>, <toplevel-set>, and
<toplevel-define>, indicating the expander's idea of what the current
module is when a toplevel variable is accessed or created.  This will
help in later optimizations.

* libguile/expand.c (TOPLEVEL_REF, TOPLEVEL_SET, TOPLEVEL_DEFINE)
  (expand, expand_define, expand_set_x, convert_assignment):
* libguile/expand.h (SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_REF, SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_SET, SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE):
* module/ice-9/compile-psyntax.scm (translate-literal-syntax-objects):
* module/ice-9/psyntax-pp.scm:
* module/ice-9/psyntax.scm:
* module/language/tree-il.scm:
* module/language/tree-il.scm (parse-tree-il, make-tree-il-folder):
(pre-post-order):
* module/language/tree-il/analyze.scm (goops-toplevel-definition):
(macro-use-before-definition-analysis, proc-ref?, format-analysis):
* module/language/tree-il/compile-cps.scm (convert):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/fix-letrec.scm (free-variables):
* module/language/tree-il/peval.scm (peval):
* test-suite/tests/tree-il.test: Adapt uses.

13 files changed, 182 insertions, 156 deletions

diff --git a/libguile/expand.c b/libguile/expand.c
index dd6eab0fe..11e43c2b9 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -74,12 +74,12 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
   SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
 #define MODULE_SET(src, mod, name, public, exp) \
   SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
-#define TOPLEVEL_REF(src, name) \
-  SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
-#define TOPLEVEL_SET(src, name, exp) \
-  SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
-#define TOPLEVEL_DEFINE(src, name, exp) \
-  SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
+#define TOPLEVEL_REF(src, mod, name) \
+  SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name)
+#define TOPLEVEL_SET(src, mod, name, exp) \
+  SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp)
+#define TOPLEVEL_DEFINE(src, mod, name, exp) \
+  SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp)
 #define CONDITIONAL(src, test, consequent, alternate) \
   SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
 #define PRIMCALL(src, name, exps) \
@@ -377,7 +377,7 @@ expand (SCM exp, SCM env)
       if (scm_is_true (gensym))
         return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
       else
-        return TOPLEVEL_REF (SCM_BOOL_F, exp);
+        return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp);
     }
   else
     return CONST_ (SCM_BOOL_F, exp);
@@ -552,13 +552,14 @@ expand_define (SCM expr, SCM env)
       ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
       return TOPLEVEL_DEFINE
         (scm_source_properties (expr),
+         SCM_BOOL_F,
          CAR (variable),
          expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
                         env));
     }
   ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
   ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
-  return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
+  return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable,
                           expand (CAR (body), env));
 }
 
@@ -1143,6 +1144,7 @@ expand_set_x (SCM expr, SCM env)
                           expand (CADDR (expr), env));
     case SCM_EXPANDED_TOPLEVEL_REF:
       return TOPLEVEL_SET (scm_source_properties (expr),
+                           SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
                            SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
                            expand (CADDR (expr), env));
     case SCM_EXPANDED_MODULE_REF:
@@ -1371,12 +1373,14 @@ convert_assignment (SCM exp, SCM assigned)
     case SCM_EXPANDED_TOPLEVEL_SET:
       return TOPLEVEL_SET
 	 (REF (exp, TOPLEVEL_SET, SRC),
+          REF (exp, TOPLEVEL_SET, MOD),
           REF (exp, TOPLEVEL_SET, NAME),
           convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
 
     case SCM_EXPANDED_TOPLEVEL_DEFINE:
       return TOPLEVEL_DEFINE
         (REF (exp, TOPLEVEL_DEFINE, SRC),
+         REF (exp, TOPLEVEL_DEFINE, MOD),
          REF (exp, TOPLEVEL_DEFINE, NAME),
          convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
                              assigned));
diff --git a/libguile/expand.h b/libguile/expand.h
index 86054a5f4..06abd9fbb 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -175,41 +175,44 @@ enum
 
 #define SCM_EXPANDED_TOPLEVEL_REF_TYPE_NAME "toplevel-ref"
 #define SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES   \
-  { "src", "name", }
+  { "src", "mod", "name", }
 enum
   {
     SCM_EXPANDED_TOPLEVEL_REF_SRC,
+    SCM_EXPANDED_TOPLEVEL_REF_MOD,
     SCM_EXPANDED_TOPLEVEL_REF_NAME,
     SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS,
   };
-#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) \
-  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) \
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name))
 
 #define SCM_EXPANDED_TOPLEVEL_SET_TYPE_NAME "toplevel-set"
 #define SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES   \
-  { "src", "name", "exp", }
+  { "src", "mod", "name", "exp", }
 enum
   {
     SCM_EXPANDED_TOPLEVEL_SET_SRC,
+    SCM_EXPANDED_TOPLEVEL_SET_MOD,
     SCM_EXPANDED_TOPLEVEL_SET_NAME,
     SCM_EXPANDED_TOPLEVEL_SET_EXP,
     SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS,
   };
-#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) \
-  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) \
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (exp))
 
 #define SCM_EXPANDED_TOPLEVEL_DEFINE_TYPE_NAME "toplevel-define"
 #define SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES        \
-  { "src", "name", "exp", }
+  { "src", "mod", "name", "exp", }
 enum
   {
     SCM_EXPANDED_TOPLEVEL_DEFINE_SRC,
+    SCM_EXPANDED_TOPLEVEL_DEFINE_MOD,
     SCM_EXPANDED_TOPLEVEL_DEFINE_NAME,
     SCM_EXPANDED_TOPLEVEL_DEFINE_EXP,
     SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS,
   };
-#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) \
-  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) \
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (exp))
 
 #define SCM_EXPANDED_CONDITIONAL_TYPE_NAME "conditional"
 #define SCM_EXPANDED_CONDITIONAL_FIELD_NAMES    \
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 44cdbbe9b..8a0b5cc0d 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -139,11 +139,12 @@
         (translate-literal-syntax-objects
          (make-toplevel-define
           (toplevel-define-src x)
+          (toplevel-define-mod x)
           (toplevel-define-name x)
           (make-let (toplevel-define-src x)
                     (list 'make-syntax)
                     (list (module-gensym))
-                    (list (make-toplevel-ref #f 'make-syntax))
+                    (list (make-toplevel-ref #f #f 'make-syntax))
                     (toplevel-define-exp x))))))))
 
 ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 151bf8e5b..6cd767640 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -45,14 +45,24 @@
            public?
            exp)))
      (make-toplevel-ref
-       (lambda (src name)
-         (make-struct/simple (vector-ref %expanded-vtables 7) src name)))
+       (lambda (src mod name)
+         (make-struct/simple (vector-ref %expanded-vtables 7) src mod name)))
      (make-toplevel-set
-       (lambda (src name exp)
-         (make-struct/simple (vector-ref %expanded-vtables 8) src name exp)))
+       (lambda (src mod name exp)
+         (make-struct/simple
+           (vector-ref %expanded-vtables 8)
+           src
+           mod
+           name
+           exp)))
      (make-toplevel-define
-       (lambda (src name exp)
-         (make-struct/simple (vector-ref %expanded-vtables 9) src name exp)))
+       (lambda (src mod name exp)
+         (make-struct/simple
+           (vector-ref %expanded-vtables 9)
+           src
+           mod
+           name
+           exp)))
      (make-conditional
        (lambda (src test consequent alternate)
          (make-struct/simple
@@ -143,20 +153,20 @@
      (analyze-variable
        (lambda (mod var modref-cont bare-cont)
          (if (not mod)
-           (bare-cont var)
+           (bare-cont #f var)
            (let ((kind (car mod)) (mod (cdr mod)))
              (let ((key kind))
                (cond ((memv key '(public)) (modref-cont mod var #t))
                      ((memv key '(private))
-                      (if (not (equal? mod (module-name (current-module))))
-                        (modref-cont mod var #f)
-                        (bare-cont var)))
+                      (if (equal? mod (module-name (current-module)))
+                        (bare-cont mod var)
+                        (modref-cont mod var #f)))
                      ((memv key '(bare)) (bare-cont var))
                      ((memv key '(hygiene))
                       (if (and (not (equal? mod (module-name (current-module))))
                                (module-variable (resolve-module mod) var))
                         (modref-cont mod var #f)
-                        (bare-cont var)))
+                        (bare-cont mod var)))
                      ((memv key '(primitive))
                       (syntax-violation #f "primitive not in operator position" var))
                      (else (syntax-violation #f "bad module kind" var mod))))))))
@@ -166,7 +176,7 @@
            mod
            var
            (lambda (mod var public?) (make-module-ref source mod var public?))
-           (lambda (var) (make-toplevel-ref source var)))))
+           (lambda (mod var) (make-toplevel-ref source mod var)))))
      (build-global-assignment
        (lambda (source var exp mod)
          (maybe-name-value! var exp)
@@ -175,11 +185,11 @@
            var
            (lambda (mod var public?)
              (make-module-set source mod var public? exp))
-           (lambda (var) (make-toplevel-set source var exp)))))
+           (lambda (mod var) (make-toplevel-set source mod var exp)))))
      (build-global-definition
-       (lambda (source var exp)
+       (lambda (source mod var exp)
          (maybe-name-value! var exp)
-         (make-toplevel-define source var exp)))
+         (make-toplevel-define source (and mod (cdr mod)) var exp)))
      (build-simple-lambda
        (lambda (src req rest vars meta exp)
          (make-lambda
@@ -583,7 +593,7 @@
                                                (syntax-expression id))))
                                    (record-definition! id var)
                                    (list (if (eq? m 'c&e)
-                                           (let ((x (build-global-definition s var (expand e r w mod))))
+                                           (let ((x (build-global-definition s mod var (expand e r w mod))))
                                              (top-level-eval-hook x mod)
                                              (lambda () x))
                                            (call-with-values
@@ -591,9 +601,9 @@
                                              (lambda (type* value* mod*)
                                                (if (eq? type* 'macro)
                                                  (top-level-eval-hook
-                                                   (build-global-definition s var (build-void s))
+                                                   (build-global-definition s mod var (build-void s))
                                                    mod))
-                                               (lambda () (build-global-definition s var (expand e r w mod)))))))))
+                                               (lambda () (build-global-definition s mod var (expand e r w mod)))))))))
                                 ((memv key '(define-syntax-form define-syntax-parameter-form))
                                  (let* ((id (wrap value w mod))
                                         (label (gen-label))
@@ -604,21 +614,21 @@
                                    (let ((key m))
                                      (cond ((memv key '(c))
                                             (cond ((memq 'compile esew)
-                                                   (let ((e (expand-install-global var type (expand e r w mod))))
+                                                   (let ((e (expand-install-global mod var type (expand e r w mod))))
                                                      (top-level-eval-hook e mod)
                                                      (if (memq 'load esew) (list (lambda () e)) '())))
                                                   ((memq 'load esew)
                                                    (list (lambda ()
-                                                           (expand-install-global var type (expand e r w mod)))))
+                                                           (expand-install-global mod var type (expand e r w mod)))))
                                                   (else '())))
                                            ((memv key '(c&e))
-                                            (let ((e (expand-install-global var type (expand e r w mod))))
+                                            (let ((e (expand-install-global mod var type (expand e r w mod))))
                                               (top-level-eval-hook e mod)
                                               (list (lambda () e))))
                                            (else
                                             (if (memq 'eval esew)
                                               (top-level-eval-hook
-                                                (expand-install-global var type (expand e r w mod))
+                                                (expand-install-global mod var type (expand e r w mod))
                                                 mod))
                                             '())))))
                                 ((memv key '(begin-form))
@@ -683,9 +693,10 @@
              (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
                (if (null? exps) (build-void s) (build-sequence s exps)))))))
      (expand-install-global
-       (lambda (name type e)
+       (lambda (mod name type e)
          (build-global-definition
            #f
+           mod
            name
            (build-primcall
              #f
@@ -976,11 +987,11 @@
                          (source-wrap e w (cdr w) mod)
                          x))
                       (else (decorate-source x s))))))
-           (let* ((t-680b775fb37a463-7b8 transformer-environment)
-                  (t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod))))
+           (let* ((t-680b775fb37a463-7c8 transformer-environment)
+                  (t-680b775fb37a463-7c9 (lambda (k) (k e r w s rib mod))))
              (with-fluid*
-               t-680b775fb37a463-7b8
-               t-680b775fb37a463-7b9
+               t-680b775fb37a463-7c8
+               t-680b775fb37a463-7c9
                (lambda ()
                  (rebuild-macro-output
                    (p (source-wrap e (anti-mark w) s mod))
@@ -1513,11 +1524,11 @@
                                           s
                                           mod
                                           get-formals
-                                          (map (lambda (tmp-680b775fb37a463-aa9
-                                                        tmp-680b775fb37a463-aa8
-                                                        tmp-680b775fb37a463-aa7)
-                                                 (cons tmp-680b775fb37a463-aa7
-                                                       (cons tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9)))
+                                          (map (lambda (tmp-680b775fb37a463-ab9
+                                                        tmp-680b775fb37a463-ab8
+                                                        tmp-680b775fb37a463-ab7)
+                                                 (cons tmp-680b775fb37a463-ab7
+                                                       (cons tmp-680b775fb37a463-ab8 tmp-680b775fb37a463-ab9)))
                                                e2*
                                                e1*
                                                args*)))
@@ -1815,11 +1826,11 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-c76
-                                       tmp-680b775fb37a463-c75
-                                       tmp-680b775fb37a463-c74)
-                                (cons tmp-680b775fb37a463-c74
-                                      (cons tmp-680b775fb37a463-c75 tmp-680b775fb37a463-c76)))
+                         (map (lambda (tmp-680b775fb37a463-c86
+                                       tmp-680b775fb37a463-c85
+                                       tmp-680b775fb37a463-c84)
+                                (cons tmp-680b775fb37a463-c84
+                                      (cons tmp-680b775fb37a463-c85 tmp-680b775fb37a463-c86)))
                               e2
                               e1
                               args)))
@@ -1831,11 +1842,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-c8c
-                                           tmp-680b775fb37a463-c8b
-                                           tmp-680b775fb37a463-c8a)
-                                    (cons tmp-680b775fb37a463-c8a
-                                          (cons tmp-680b775fb37a463-c8b tmp-680b775fb37a463-c8c)))
+                             (map (lambda (tmp-680b775fb37a463-c9c
+                                           tmp-680b775fb37a463-c9b
+                                           tmp-680b775fb37a463-c9a)
+                                    (cons tmp-680b775fb37a463-c9a
+                                          (cons tmp-680b775fb37a463-c9b tmp-680b775fb37a463-c9c)))
                                   e2
                                   e1
                                   args)))
@@ -1858,11 +1869,11 @@
               (apply (lambda (args e1 e2)
                        (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-cac
-                                       tmp-680b775fb37a463-cab
-                                       tmp-680b775fb37a463-caa)
-                                (cons tmp-680b775fb37a463-caa
-                                      (cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac)))
+                         (map (lambda (tmp-680b775fb37a463-cbc
+                                       tmp-680b775fb37a463-cbb
+                                       tmp-680b775fb37a463-cba)
+                                (cons tmp-680b775fb37a463-cba
+                                      (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc)))
                               e2
                               e1
                               args)))
@@ -1874,11 +1885,11 @@
                   (apply (lambda (docstring args e1 e2)
                            (build-it
                              (list (cons 'documentation (syntax->datum docstring)))
-                             (map (lambda (tmp-680b775fb37a463-cc2
-                                           tmp-680b775fb37a463-cc1
-                                           tmp-680b775fb37a463-cc0)
-                                    (cons tmp-680b775fb37a463-cc0
-                                          (cons tmp-680b775fb37a463-cc1 tmp-680b775fb37a463-cc2)))
+                             (map (lambda (tmp-680b775fb37a463-cd2
+                                           tmp-680b775fb37a463-cd1
+                                           tmp-680b775fb37a463-cd0)
+                                    (cons tmp-680b775fb37a463-cd0
+                                          (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2)))
                                   e2
                                   e1
                                   args)))
@@ -2803,9 +2814,9 @@
                                k
                                (list docstring)
                                (map (lambda (tmp-680b775fb37a463
-                                             tmp-680b775fb37a463-112f
-                                             tmp-680b775fb37a463-112e)
-                                      (list (cons tmp-680b775fb37a463-112e tmp-680b775fb37a463-112f)
+                                             tmp-680b775fb37a463-113f
+                                             tmp-680b775fb37a463-113e)
+                                      (list (cons tmp-680b775fb37a463-113e tmp-680b775fb37a463-113f)
                                             tmp-680b775fb37a463))
                                     template
                                     pattern
@@ -2989,8 +3000,8 @@
                                                (apply (lambda (p)
                                                         (if (= lev 0)
                                                           (quasilist*
-                                                            (map (lambda (tmp-680b775fb37a463-11d3)
-                                                                   (list "value" tmp-680b775fb37a463-11d3))
+                                                            (map (lambda (tmp-680b775fb37a463-11e3)
+                                                                   (list "value" tmp-680b775fb37a463-11e3))
                                                                  p)
                                                             (quasi q lev))
                                                           (quasicons
@@ -3013,8 +3024,8 @@
                                                    (apply (lambda (p)
                                                             (if (= lev 0)
                                                               (quasiappend
-                                                                (map (lambda (tmp-680b775fb37a463-11d8)
-                                                                       (list "value" tmp-680b775fb37a463-11d8))
+                                                                (map (lambda (tmp-680b775fb37a463-11e8)
+                                                                       (list "value" tmp-680b775fb37a463-11e8))
                                                                      p)
                                                                 (quasi q lev))
                                                               (quasicons
@@ -3048,8 +3059,8 @@
                                   (apply (lambda (p)
                                            (if (= lev 0)
                                              (quasilist*
-                                               (map (lambda (tmp-680b775fb37a463-11ee)
-                                                      (list "value" tmp-680b775fb37a463-11ee))
+                                               (map (lambda (tmp-680b775fb37a463-11fe)
+                                                      (list "value" tmp-680b775fb37a463-11fe))
                                                     p)
                                                (vquasi q lev))
                                              (quasicons
@@ -3068,8 +3079,8 @@
                                       (apply (lambda (p)
                                                (if (= lev 0)
                                                  (quasiappend
-                                                   (map (lambda (tmp-680b775fb37a463-11f3)
-                                                          (list "value" tmp-680b775fb37a463-11f3))
+                                                   (map (lambda (tmp-680b775fb37a463)
+                                                          (list "value" tmp-680b775fb37a463))
                                                         p)
                                                    (vquasi q lev))
                                                  (quasicons
@@ -3159,8 +3170,8 @@
                                 (let ((tmp-1 ls))
                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                     (if tmp
-                                      (apply (lambda (t-680b775fb37a463-123c)
-                                               (cons "vector" t-680b775fb37a463-123c))
+                                      (apply (lambda (t-680b775fb37a463-124c)
+                                               (cons "vector" t-680b775fb37a463-124c))
                                              tmp)
                                       (syntax-violation
                                         #f
@@ -3213,9 +3224,9 @@
                                             (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
                                               (let ((tmp ($sc-dispatch tmp-1 '(any any))))
                                                 (if tmp
-                                                  (apply (lambda (t-680b775fb37a463-127a t-680b775fb37a463)
+                                                  (apply (lambda (t-680b775fb37a463-128a t-680b775fb37a463)
                                                            (list (make-syntax 'cons '((top)) '(hygiene guile))
-                                                                 t-680b775fb37a463-127a
+                                                                 t-680b775fb37a463-128a
                                                                  t-680b775fb37a463))
                                                          tmp)
                                                   (syntax-violation
@@ -3244,9 +3255,9 @@
                                                 (let ((tmp-1 (map emit x)))
                                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                     (if tmp
-                                                      (apply (lambda (t-680b775fb37a463)
+                                                      (apply (lambda (t-680b775fb37a463-12a2)
                                                                (cons (make-syntax 'vector '((top)) '(hygiene guile))
-                                                                     t-680b775fb37a463))
+                                                                     t-680b775fb37a463-12a2))
                                                              tmp)
                                                       (syntax-violation
                                                         #f
@@ -3257,9 +3268,9 @@
                                          (if tmp-1
                                            (apply (lambda (x)
                                                     (let ((tmp (emit x)))
-                                                      (let ((t-680b775fb37a463-129e tmp))
+                                                      (let ((t-680b775fb37a463-12ae tmp))
                                                         (list (make-syntax 'list->vector '((top)) '(hygiene guile))
-                                                              t-680b775fb37a463-129e))))
+                                                              t-680b775fb37a463-12ae))))
                                                   tmp-1)
                                            (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
                                              (if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0cad97769..3cd87c8e3 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -329,19 +329,19 @@
   
     (define (analyze-variable mod var modref-cont bare-cont)
       (if (not mod)
-          (bare-cont var)
+          (bare-cont #f var)
           (let ((kind (car mod))
                 (mod (cdr mod)))
             (case kind
               ((public) (modref-cont mod var #t))
-              ((private) (if (not (equal? mod (module-name (current-module))))
-                             (modref-cont mod var #f)
-                             (bare-cont var)))
+              ((private) (if (equal? mod (module-name (current-module)))
+                             (bare-cont mod var)
+                             (modref-cont mod var #f)))
               ((bare) (bare-cont var))
               ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
                                   (module-variable (resolve-module mod) var))
                              (modref-cont mod var #f)
-                             (bare-cont var)))
+                             (bare-cont mod var)))
               ((primitive)
                (syntax-violation #f "primitive not in operator position" var))
               (else (syntax-violation #f "bad module kind" var mod))))))
@@ -352,8 +352,8 @@
          mod var
          (lambda (mod var public?) 
            (make-module-ref source mod var public?))
-         (lambda (var)
-           (make-toplevel-ref source var)))))
+         (lambda (mod var)
+           (make-toplevel-ref source mod var)))))
 
     (define build-global-assignment
       (lambda (source var exp mod)
@@ -362,13 +362,13 @@
          mod var
          (lambda (mod var public?) 
            (make-module-set source mod var public? exp))
-         (lambda (var)
-           (make-toplevel-set source var exp)))))
+         (lambda (mod var)
+           (make-toplevel-set source mod var exp)))))
 
     (define build-global-definition
-      (lambda (source var exp)
+      (lambda (source mod var exp)
         (maybe-name-value! var exp)
-        (make-toplevel-define source var exp)))
+        (make-toplevel-define source (and mod (cdr mod)) var exp)))
 
     (define build-simple-lambda
       (lambda (src req rest vars meta exp)
@@ -1142,7 +1142,7 @@
                      (record-definition! id var)
                      (list
                       (if (eq? m 'c&e)
-                          (let ((x (build-global-definition s var (expand e r w mod))))
+                          (let ((x (build-global-definition s mod var (expand e r w mod))))
                             (top-level-eval-hook x mod)
                             (lambda () x))
                           (call-with-values
@@ -1152,10 +1152,10 @@
                               ;; macro, then immediately discard that binding.
                               (if (eq? type* 'macro)
                                   (top-level-eval-hook (build-global-definition
-                                                        s var (build-void s))
+                                                        s mod var (build-void s))
                                                        mod))
                               (lambda ()
-                                (build-global-definition s var (expand e r w mod)))))))))
+                                (build-global-definition s mod var (expand e r w mod)))))))))
                   ((define-syntax-form define-syntax-parameter-form)
                    (let* ((id (wrap value w mod))
                           (label (gen-label))
@@ -1167,23 +1167,23 @@
                        ((c)
                         (cond
                          ((memq 'compile esew)
-                          (let ((e (expand-install-global var type (expand e r w mod))))
+                          (let ((e (expand-install-global mod var type (expand e r w mod))))
                             (top-level-eval-hook e mod)
                             (if (memq 'load esew)
                                 (list (lambda () e))
                                 '())))
                          ((memq 'load esew)
                           (list (lambda ()
-                                  (expand-install-global var type (expand e r w mod)))))
+                                  (expand-install-global mod var type (expand e r w mod)))))
                          (else '())))
                        ((c&e)
-                        (let ((e (expand-install-global var type (expand e r w mod))))
+                        (let ((e (expand-install-global mod var type (expand e r w mod))))
                           (top-level-eval-hook e mod)
                           (list (lambda () e))))
                        (else
                         (if (memq 'eval esew)
                             (top-level-eval-hook
-                             (expand-install-global var type (expand e r w mod))
+                             (expand-install-global mod var type (expand e r w mod))
                              mod))
                         '()))))
                   ((begin-form)
@@ -1244,9 +1244,10 @@
                 (build-sequence s exps))))))
     
     (define expand-install-global
-      (lambda (name type e)
+      (lambda (mod name type e)
         (build-global-definition
          no-source
+         mod
          name
          (build-primcall
           no-source
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 5cb4710f2..77d6f2394 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 2009-2014, 2017-2018 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009-2014, 2017-2019 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -30,9 +30,9 @@
             <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
             <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
             <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
-            <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
-            <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
-            <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
+            <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-mod toplevel-ref-name
+            <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-mod toplevel-set-name toplevel-set-exp
+            <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-mod toplevel-define-name toplevel-define-exp
             <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
             <call> call? make-call call-src call-proc call-args
             <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
@@ -117,9 +117,9 @@
   ;; (<lexical-set> name gensym exp)
   ;; (<module-ref> mod name public?)
   ;; (<module-set> mod name public? exp)
-  ;; (<toplevel-ref> name)
-  ;; (<toplevel-set> name exp)
-  ;; (<toplevel-define> name exp)
+  ;; (<toplevel-ref> mod name)
+  ;; (<toplevel-set> mod name exp)
+  ;; (<toplevel-define> mod name exp)
   ;; (<conditional> test consequent alternate)
   ;; (<call> proc args)
   ;; (<primcall> name args)
@@ -197,13 +197,13 @@
       (make-module-set loc mod name #f (retrans exp)))
 
      (('toplevel (and name (? symbol?)))
-      (make-toplevel-ref loc name))
+      (make-toplevel-ref loc #f name))
 
      (('set! ('toplevel (and name (? symbol?))) exp)
-      (make-toplevel-set loc name (retrans exp)))
+      (make-toplevel-set loc #f name (retrans exp)))
 
      (('define (and name (? symbol?)) exp)
-      (make-toplevel-define loc name (retrans exp)))
+      (make-toplevel-define loc #f name (retrans exp)))
 
      (('lambda meta body)
       (make-lambda loc meta (retrans body)))
@@ -286,13 +286,13 @@
     (($ <module-set> src mod name public? exp)
      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 
-    (($ <toplevel-ref> src name)
+    (($ <toplevel-ref> src mod name)
      `(toplevel ,name))
 
-    (($ <toplevel-set> src name exp)
+    (($ <toplevel-set> src mod name exp)
      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 
-    (($ <toplevel-define> src name exp)
+    (($ <toplevel-define> src mod name exp)
      `(define ,name ,(unparse-tree-il exp)))
 
     (($ <lambda> src meta body)
@@ -356,9 +356,9 @@
                (foldts exp seed ...))
               (($ <module-set> src mod name public? exp)
                (foldts exp seed ...))
-              (($ <toplevel-set> src name exp)
+              (($ <toplevel-set> src mod name exp)
                (foldts exp seed ...))
-              (($ <toplevel-define> src name exp)
+              (($ <toplevel-define> src mod name exp)
                (foldts exp seed ...))
               (($ <conditional> src test consequent alternate)
                (let*-values (((seed ...) (foldts test seed ...))
@@ -449,17 +449,17 @@ This is an implementation of `foldts' as described by Andy Wingo in
                 x
                 (make-module-set src mod name public? exp*))))
 
-         (($ <toplevel-set> src name exp)
+         (($ <toplevel-set> src mod name exp)
           (let ((exp* (lp exp)))
             (if (eq? exp exp*)
                 x
-                (make-toplevel-set src name exp*))))
+                (make-toplevel-set src mod name exp*))))
 
-         (($ <toplevel-define> src name exp)
+         (($ <toplevel-define> src mod name exp)
           (let ((exp* (lp exp)))
             (if (eq? exp exp*)
                 x
-                (make-toplevel-define src name exp*))))
+                (make-toplevel-define src mod name exp*))))
 
          (($ <conditional> src test consequent alternate)
           (let ((test* (lp test))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 62632fd3c..eb83a8ea5 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -873,7 +873,7 @@ given `tree-il' element."
   (match proc
     (($ <module-ref> _ '(oop goops) 'toplevel-define! #f)
      (toplevel-define-arg args))
-    (($ <toplevel-ref> _ 'toplevel-define!)
+    (($ <toplevel-ref> _ _ 'toplevel-define!)
      ;; This may be the result of expanding one of the GOOPS macros within
      ;; `oop/goops.scm'.
      (and (eq? env (resolve-module '(oop goops)))
@@ -972,11 +972,11 @@ given `tree-il' element."
          (($ <primcall> _ 'make-syntax-transformer) #t)
          (_ #f)))
      (match x
-       (($ <toplevel-ref> src name)
+       (($ <toplevel-ref> src mod name)
         (add-use name (nearest-loc src)))
-       (($ <toplevel-set> src name)
+       (($ <toplevel-set> src mod name)
         (add-use name (nearest-loc src)))
-       (($ <toplevel-define> src name (? macro?))
+       (($ <toplevel-define> src mod name (? macro?))
         (add-def name (nearest-loc src)))
        (_ info)))
 
@@ -1421,10 +1421,10 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
     (cut eq? <> special-name))
 
   (match exp
-    (($ <toplevel-ref> _ (? special?))
+    (($ <toplevel-ref> _ _ (? special?))
      ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
      #t)
-    (($ <toplevel-ref> _ name)
+    (($ <toplevel-ref> _ _ name)
      (let ((var (module-variable env name)))
        (and var (variable-bound? var)
             (eq? (variable-ref var) proc))))
@@ -1464,7 +1464,7 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
 (define format-analysis
   ;; Report arity mismatches in the given tree.
   (make-tree-analysis
-   (lambda (x _ env locs)
+   (lambda (x res env locs)
      ;; Down into X.
      (define (check-format-args args loc)
        (pmatch args
@@ -1539,7 +1539,7 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
             (false-if-exception (module-ref env name))))
 
      (match x
-       (($ <call> src ($ <toplevel-ref> _ name) args)
+       (($ <call> src ($ <toplevel-ref> _ _ name) args)
         (let ((proc (resolve-toplevel name)))
           (if (or (and (eq? proc (@ (guile) simple-format))
                        (check-simple-format-args args
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 6c8884add..d97ead911 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2019 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1849,7 +1849,7 @@
                 ($continue k src
                   ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
 
-    (($ <toplevel-ref> src name)
+    (($ <toplevel-ref> src mod name)
      (toplevel-box
       cps src name #t
       (lambda (cps box)
@@ -1859,7 +1859,7 @@
             ($continue k src
               ($primcall 'scm-ref/immediate '(box . 1) (box))))))))
 
-    (($ <toplevel-set> src name exp)
+    (($ <toplevel-set> src mod name exp)
      (convert-arg cps exp
        (lambda (cps val)
          (toplevel-box
@@ -1871,7 +1871,7 @@
                 ($continue k src
                   ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
 
-    (($ <toplevel-define> src name exp)
+    (($ <toplevel-define> src modname name exp)
      (convert-arg cps exp
        (lambda (cps val)
          (with-cps cps
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 613dc2ea6..3878fb526 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL verifier
 
-;; Copyright (C) 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2013, 2019 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -170,8 +170,10 @@
          (visit body env))))
       (($ <const> src val) #t)
       (($ <void> src) #t)
-      (($ <toplevel-ref> src name)
+      (($ <toplevel-ref> src mod name)
        (cond
+        ((and mod (not (and (list? mod) (and-map symbol? mod))))
+         (error "module name should be #f or list of symbols" mod))
         ((not (symbol? name))
          (error "name should be a symbol" name))))
       (($ <module-ref> src mod name public?)
@@ -184,14 +186,18 @@
        (cond
         ((not (symbol? name))
          (error "name should be symbol" exp))))
-      (($ <toplevel-set> src name exp)
+      (($ <toplevel-set> src mod name exp)
        (cond
+        ((and mod (not (and (list? mod) (and-map symbol? mod))))
+         (error "module name should be #f or list of symbols" mod))
         ((not (symbol? name))
          (error "name should be a symbol" name))
         (else
          (visit exp env))))
-      (($ <toplevel-define> src name exp)
+      (($ <toplevel-define> src mod name exp)
        (cond
+        ((and mod (not (and (list? mod) (and-map symbol? mod))))
+         (error "module name should be #f or list of symbols" mod))
         ((not (symbol? name))
          (error "name should be a symbol" name))
         (else
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index a133e3269..05016a3a1 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -294,10 +294,10 @@ of an expression."
            (logior (cause &toplevel)
                    (cause &type-check)
                    (compute-effects exp)))
-          (($ <toplevel-define> _ name exp)
+          (($ <toplevel-define> _ _ name exp)
            (logior (cause &toplevel)
                    (compute-effects exp)))
-          (($ <toplevel-set> _ name exp)
+          (($ <toplevel-set> _ _ name exp)
            (logior (cause &toplevel)
                    (compute-effects exp)))
           (($ <primitive-ref>)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 227bbfb38..afc9b8e21 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -87,9 +87,9 @@
        (adjoin gensym (recurse exp)))
       (($ <module-set> src mod name public? exp)
        (recurse exp))
-      (($ <toplevel-set> src name exp)
+      (($ <toplevel-set> src mod name exp)
        (recurse exp))
-      (($ <toplevel-define> src name exp)
+      (($ <toplevel-define> src mod name exp)
        (recurse exp))
       (($ <conditional> src test consequent alternate)
        (union (recurse test)
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index e1938e6bf..f11640fa5 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -387,7 +387,7 @@ top-level bindings from ENV and return the resulting expression."
     (let ()
       (define (env-folder x env)
         (match x
-          (($ <toplevel-define> _ name)
+          (($ <toplevel-define> _ _ name)
            (vhash-consq name #t env))
           (($ <seq> _ head tail)
            (env-folder tail (env-folder head env)))
@@ -1020,7 +1020,7 @@ top-level bindings from ENV and return the resulting expression."
                    (else #f))))
                (_ #f))
              (make-let-values lv-src producer (for-tail consumer)))))
-      (($ <toplevel-ref> src (? effect-free-primitive? name))
+      (($ <toplevel-ref> src mod (? effect-free-primitive? name))
        exp)
       (($ <toplevel-ref>)
        ;; todo: open private local bindings.
@@ -1038,10 +1038,10 @@ top-level bindings from ENV and return the resulting expression."
        exp)
       (($ <module-set> src mod name public? exp)
        (make-module-set src mod name public? (for-value exp)))
-      (($ <toplevel-define> src name exp)
-       (make-toplevel-define src name (for-value exp)))
-      (($ <toplevel-set> src name exp)
-       (make-toplevel-set src name (for-value exp)))
+      (($ <toplevel-define> src mod name exp)
+       (make-toplevel-define src mod name (for-value exp)))
+      (($ <toplevel-set> src mod name exp)
+       (make-toplevel-set src mod name (for-value exp)))
       (($ <primitive-ref>)
        (case ctx
          ((effect) (make-void #f))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index bba2f6fe7..46729ef88 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014,2018-2019 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -188,11 +188,11 @@
                     x))
       (and (= result 12)
            (equal? (map strip-source (list-head (reverse ups) 3))
-                   (list (make-toplevel-ref #f '+)
+                   (list (make-toplevel-ref #f #f '+)
                          (make-lexical-ref #f 'x 'x1)
                          (make-lexical-ref #f 'y 'y1)))
            (equal? (map strip-source (reverse (list-head downs 3)))
-                   (list (make-toplevel-ref #f '+)
+                   (list (make-toplevel-ref #f #f '+)
                          (make-lexical-ref #f 'x 'x1)
                          (make-lexical-ref #f 'y 'y1)))))))