bind all module-level variables lazily

comments in ghil-lookup are pertinent.

* module/system/il/compile.scm (make-glil-var): Require that ghil vars
  have environments. Remove the 'unresolved case -- we'll treat all
  module-level variables as late bound.

* module/system/il/ghil.scm (ghil-lookup): Treat all module level vars as
  late bound.

* module/system/vm/assemble.scm: Instead of vlink and vlate-bound, have
  vlink-now and vlink-later.
  (codegen): Add a bunch of crap to get the various cases right.
  (object-assoc, dump-object!): Handle the new cases, remove the old
  cases.

* src/vm_loader.c (link-now, link-later): Change from link and lazy-bind.
  Include the module in which the link is to be done, so that callers
  from other modules get the right behavior.

* src/vm_system.c (late-variable-ref, late-variable-set): Instead of a
  sym, the unbound representation is a module name / symbol pair.

* testsuite/run-vm-tests.scm (run-vm-tests): Remove some debugging.

module/system/il/compile.scm

@@ -101,10 +101,8 @@
 	  (make-glil-external op depth (ghil-var-index var)))))
     ((module)
      (let ((env (ghil-var-env var)))
-       (make-glil-module op (and env (ghil-mod-module (ghil-env-mod env)))
+       (make-glil-module op (ghil-mod-module (ghil-env-mod env))
                          (ghil-var-name var))))
-    ((unresolved)
-     (make-glil-late-bound op (ghil-var-name var)))
     (else (error "Unknown kind of variable:" var))))
 
 (define (codegen ghil)

module/system/il/ghil.scm

@@ -185,11 +185,6 @@
 ;;; Public interface
 ;;;
 
-(define (module-lookup module sym)
-  (let ((iface (module-import-interface module sym)))
-    (and iface
-         (make-ghil-env (make-ghil-mod iface)))))
-
 (define (fix-ghil-mod! mod for-sym)
   ;;; So, these warnings happen for all instances of define-module.
   ;;; Rather than fixing the problem, I'm going to suppress the common
@@ -219,13 +214,13 @@
                   (fix-ghil-mod! e sym)
                   (loop e))
                  ((assq-ref table sym)) ;; when does this hit?
-                 ((module-lookup module sym)
-                  => (lambda (found-env)
-                       (make-ghil-var found-env sym 'module)))
                  (else
-                  ;; a free variable that we have not resolved
+                  ;; although we could bind the variable here, in
-                  (warn "unresolved variable during compilation:" sym)
+                  ;; practice further toplevel definitions in this
-                  (let ((var (make-ghil-var #f sym 'unresolved)))
+                  ;; compilation unit could change how we would resolve
+                  ;; this binding, so punt and memoize the lookup at
+                  ;; runtime always.
+                  (let ((var (make-ghil-var (make-ghil-env e) sym 'module)))
                     (apush! sym var table)
                     var))))
           ((<ghil-env> mod parent table variables)

module/system/vm/assemble.scm

@@ -43,8 +43,8 @@
 (define-record (<vm-asm> venv glil body))
 (define-record (<venv> parent nexts closure?))
 (define-record (<vmod> id))
-(define-record (<vlink> module name))
+(define-record (<vlink-now> module name))
-(define-record (<vlate-bound> name))
+(define-record (<vlink-later> module name))
 (define-record (<vdefine> module name))
 (define-record (<bytespec> vars bytes meta objs closure?))
 
@@ -149,29 +149,28 @@
 
 	   ((<glil-module> op module name)
             (case op
-              ((ref)
+              ((ref set)
-               (push-object! (make-vlink :module module :name name))
+               (cond
-               (push-code! '(variable-ref)))
+                (toplevel
-              ((set)
+                 (push-object! (make-vlink-now :module module :name name))
-               (push-object! (make-vlink :module module :name name))
+                 (push-code! (case op
-               (push-code! '(variable-set)))
+                               ((ref) '(variable-ref))
-              ((define)
+                               ((set) '(variable-set)))))
-               (push-object! (make-vdefine :module module :name name))
+                (else
-               (push-code! '(variable-set)))))
+                 (let* ((var (make-vlink-later :module module :name name))
-
-	   ((<glil-late-bound> op name)
-            (let* ((var (make-vlate-bound :name name))
                         (i (cond ((object-assoc var object-alist) => cdr)
                                  (else
                                   (let ((i (length object-alist)))
                                     (set! object-alist (acons var i object-alist))
                                     i)))))
-              (case op
+                   (push-code! (case op
-                ((ref)
+                                 ((ref) `(late-variable-ref ,i))
-                 (push-code! `(late-variable-ref ,i)))
+                                 ((set) `(late-variable-set ,i))))))))
-                ((set)
+              ((define)
-                 (push-code! `(late-variable-set ,i)))
+               (push-object! (make-vdefine :module module :name name))
-                (else (error "unknown late bound" op name)))))
+               (push-code! '(variable-set)))
+              (else
+               (error "unknown toplevel var kind" op name))))
 
 	   ((<glil-label> label)
 	    (set! label-alist (assq-set! label-alist label (current-address))))
@@ -208,7 +207,8 @@
 
 (define (object-assoc x alist)
   (record-case x
-    ((<vlink>) (assoc x alist))
+    ((<vlink-now>) (assoc x alist))
+    ((<vlink-later>) (assoc x alist))
     (else        (assq x alist))))
 
 (define (stack->bytes stack label-alist)
@@ -271,15 +271,17 @@
 	 (if meta (dump! meta))
 	 ;; dump bytecode
 	 (push-code! `(load-program ,bytes)))
-	((<vlink> module name)
+	((<vlink-later> module name)
-         (dump! (and=> module module-name))
+         (dump! (module-name module))
          (dump! name)
-	 (push-code! '(link)))
+	 (push-code! '(link-later)))
+	((<vlink-now> module name)
+         (dump! (module-name module))
+         (dump! name)
+	 (push-code! '(link-now)))
 	((<vdefine> module name)
 	 ;; FIXME: dump module
 	 (push-code! `(define ,(symbol->string name))))
-	((<vlate-bound> name)
-	 (push-code! `(late-bind ,(symbol->string name))))
 	((<vmod> id)
 	 (push-code! `(load-module ,id)))
         (else

src/vm_loader.c

@@ -176,29 +176,21 @@ VM_DEFINE_LOADER (load_program, "load-program")
   NEXT;
 }
 
-/* this seems to be a bit too much processing for one instruction.. */
+VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 2, 1)
-VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
 {
-  SCM modname, mod, sym;
+  SCM modname, sym;
   POP (sym);
   POP (modname);
-  if (SCM_NFALSEP (modname)) 
+  PUSH (scm_module_lookup (scm_resolve_module (modname), sym)); /* might longjmp */
-    {
+  NEXT;
-      mod = scm_resolve_module (modname);
-
-      if (mod != scm_current_module ()) 
-        {
-          mod = scm_c_module_lookup (mod, "%module-public-interface");
-          if (SCM_FALSEP (mod))
-            SCM_MISC_ERROR ("Could not load module", SCM_LIST1 (modname));
-          mod = SCM_VARIABLE_REF (mod);
 }
 
-      PUSH (scm_module_lookup (mod, sym));
+VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
-    }
+{
-  else
+  SCM modname, sym;
-    PUSH (scm_lookup (sym));
+  POP (sym);
-  
+  POP (modname);
+  PUSH (scm_cons (modname, sym));
   NEXT;
 }
 

src/vm_system.c

@@ -259,23 +259,25 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
 
 VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
 {
-  register unsigned objnum = FETCH ();
+  unsigned objnum = FETCH ();
-  SCM x;
+  SCM pair_or_var;
   CHECK_OBJECT (objnum);
-  x = OBJECT_REF (objnum);
+  pair_or_var = OBJECT_REF (objnum);
 
-  if (!SCM_VARIABLEP (x)) 
+  if (!SCM_VARIABLEP (pair_or_var)) 
     {
-      x = scm_lookup (x); /* might longjmp */
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
-      OBJECT_SET (objnum, x);
+      /* module_lookup might longjmp */
-      if (!VARIABLE_BOUNDP (x))
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+      OBJECT_SET (objnum, pair_or_var);
+      if (!VARIABLE_BOUNDP (pair_or_var))
         {
-          err_args = SCM_LIST1 (x);
+          err_args = SCM_LIST1 (pair_or_var);
           goto vm_error_unbound;
         }
     }
 
-  PUSH (VARIABLE_REF (x));
+  PUSH (VARIABLE_REF (pair_or_var));
   NEXT;
 }
 
@@ -313,23 +315,20 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 
 VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
 {
-  register unsigned objnum = FETCH ();
+  unsigned objnum = FETCH ();
-  SCM x;
+  SCM pair_or_var;
   CHECK_OBJECT (objnum);
-  x = OBJECT_REF (objnum);
+  pair_or_var = OBJECT_REF (objnum);
 
-  if (!SCM_VARIABLEP (x)) 
+  if (!SCM_VARIABLEP (pair_or_var)) 
     {
-      x = scm_lookup (x); /* might longjmp */
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
-      OBJECT_SET (objnum, x);
+      /* module_lookup might longjmp */
-      if (!VARIABLE_BOUNDP (x))
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
-        {
+      OBJECT_SET (objnum, pair_or_var);
-          err_args = SCM_LIST1 (x);
-          goto vm_error_unbound;
-        }
     }
 
-  VARIABLE_SET (x, *sp);
+  VARIABLE_SET (pair_or_var, *sp);
   DROP ();
   NEXT;
 }

testsuite/run-vm-tests.scm

@@ -74,9 +74,9 @@ equal in the sense of @var{equal?}."
 		     (format #t "running `~a'...  " file)
 		     (if (catch #t
 				(lambda ()
-				  (equal? (pk (compile/run-test-from-file file))
+				  (equal? (compile/run-test-from-file file)
-					  (pk (eval (fetch-sexp-from-file file)
+					  (eval (fetch-sexp-from-file file)
-						(interaction-environment)))))
+						(interaction-environment))))
 				(lambda (key . args)
 				  (format #t "[~a/~a] " key args)
 				  #f))