vm: bugfix: global lexicals looked up dynamically.

The getlx and setlx VM instructions are using dynamic lookup
for uncached bindings, due to using the same lookup_fun
search function. They should use lookup_global_fun.
That doesn't have an environment parameter though, so the
type is not right. However, the VM never uses the environment
parameter; it's always passing nil. We will get rid of the
environment parameter in the lookup_fn callback and introduce
a few wrappers.

* eval.c, eval.h (lookup_global_fun, lookup_dynamic_var,
lookup_dynamic_sym_lisp1): New functions.

* vm.c (vm_stab_slowpath, vm_get_binding): lookup_fn argument
loses environment parameter, and so we don't have to pass nil.
(vm_gcall, vm_gapply): Use pass lookup_global_fun to
to vm_stab.
(vm_getsym, vm_getbind, vm_setsym, vm_gettab, vm_settab):
lookup_fn argument loses environment parameter.
(vm_execute): lookup functions replaced with the appropriate
one-argument ones. GETLX and SETLX see a behavior change,
due to using lookup_global_var which doesn't search the
dynamic environment.

3 files changed, 42 insertions, 23 deletions

diff --git a/eval.c b/eval.c
index 3c8d83f5..ab54586e 100644
--- a/eval.c
+++ b/eval.c
@@ -530,6 +530,11 @@ val lookup_global_var(val sym)
              if2(autoload_try_var(sym), gethash(top_vb, sym)));
 }
 
+val lookup_global_fun(val sym)
+{
+  return lookup_fun(nil, sym);
+}
+
 val lookup_var(val env, val sym)
 {
   if (env) {
@@ -593,6 +598,16 @@ loc lookup_var_l(val env, val sym)
   uw_throwf(error_s, lit("variable ~s unexpectedly unbound"), sym, nao);
 }
 
+val lookup_dynamic_var(val sym)
+{
+  return lookup_var(nil, sym);
+}
+
+val lookup_dynamic_sym_lisp1(val sym)
+{
+  return lookup_sym_lisp1(nil, sym);
+}
+
 static val lookup_mac(val menv, val sym);
 
 val lookup_fun(val env, val sym)
diff --git a/eval.h b/eval.h
index a927666f..26f30e5f 100644
--- a/eval.h
+++ b/eval.h
@@ -54,7 +54,10 @@ val deep_copy_env(val oenv);
 val env_fbind(val env, val sym, val fun);
 val env_vbind(val env, val sym, val obj);
 val lookup_var(val env, val sym);
+val lookup_dynamic_var(val sym);
+val lookup_dynamic_sym_lisp1(val sym);
 val lookup_global_var(val sym);
+val lookup_global_fun(val sym);
 loc lookup_var_l(val env, val sym);
 val lookup_fun(val env, val sym);
 val lookup_sym_lisp1(val env, val sym);
diff --git a/vm.c b/vm.c
index 262ef934..080109d7 100644
--- a/vm.c
+++ b/vm.c
@@ -522,13 +522,13 @@ NOINLINE static void vm_apply(struct vm *vm, vm_word_t insn)
 
 
 NOINLINE static loc vm_stab_slowpath(struct vm *vm, unsigned fun,
-                                     val (*lookup_fn)(val env, val sym),
+                                     val (*lookup_fn)(val sym),
                                      val kind_str)
 {
   struct vm_desc *vd = vm->vd;
   struct vm_stent *fe = &vd->stab[fun];
 
-  if (nilp(fe->bind = lookup_fn(nil, vecref(vd->symvec, num_fast(fun)))))
+  if (nilp(fe->bind = lookup_fn(vecref(vd->symvec, num_fast(fun)))))
     eval_error(vd->bytecode,
                lit("~a ~s is not defined"), kind_str,
                vecref(vd->symvec, num(fun)), nao);
@@ -538,7 +538,7 @@ NOINLINE static loc vm_stab_slowpath(struct vm *vm, unsigned fun,
 }
 
 INLINE loc vm_stab(struct vm *vm, unsigned fun,
-                   val (*lookup_fn)(val env, val sym), val kind_str)
+                   val (*lookup_fn)(val sym), val kind_str)
 {
   struct vm_desc *vd = vm->vd;
   struct vm_stent *fe = &vd->stab[fun];
@@ -556,7 +556,8 @@ NOINLINE static void vm_gcall(struct vm *vm, vm_word_t insn)
   unsigned dest = vm_insn_operand(insn);
   vm_word_t argw = vm->code[vm->ip++];
   unsigned funidx = vm_arg_operand_lo(argw);
-  val fun = deref(vm_stab(vm, funidx, lookup_fun, lit("function")));
+  val fun = deref(vm_stab(vm, funidx,
+                          lookup_global_fun, lit("function")));
   val result;
 
   switch (nargs) {
@@ -648,7 +649,7 @@ NOINLINE static void vm_gapply(struct vm *vm, vm_word_t insn)
     }
   }
 
-  result = applyv(deref(vm_stab(vm, fun, lookup_fun,
+  result = applyv(deref(vm_stab(vm, fun, lookup_global_fun,
                                 lit("function"))), args);
   vm_set(vm->dspl, dest, result);
 }
@@ -860,11 +861,11 @@ NOINLINE static void vm_handle(struct vm *vm, vm_word_t insn)
 }
 
 static val vm_get_binding(struct vm *vm, vm_word_t insn,
-                          val (*lookup_fn)(val env, val sym),
+                          val (*lookup_fn)(val sym),
                           val kind_str)
 {
   val sym = vm_sm_get(vm->dspl, vm_insn_extra(insn));
-  val binding = lookup_fn(nil, sym);
+  val binding = lookup_fn(sym);
 
   if (nilp(binding))
     eval_error(vm->vd->bytecode, lit("unbound ~a ~s"), kind_str, sym, nao);
@@ -873,7 +874,7 @@ static val vm_get_binding(struct vm *vm, vm_word_t insn,
 }
 
 NOINLINE static void vm_getsym(struct vm *vm, vm_word_t insn,
-                               val (*lookup_fn)(val env, val sym),
+                               val (*lookup_fn)(val sym),
                                val kind_str)
 {
   val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -882,7 +883,7 @@ NOINLINE static void vm_getsym(struct vm *vm, vm_word_t insn,
 }
 
 NOINLINE static void vm_getbind(struct vm *vm, vm_word_t insn,
-                                val (*lookup_fn)(val env, val sym),
+                                val (*lookup_fn)(val sym),
                                 val kind_str)
 {
   val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -891,7 +892,7 @@ NOINLINE static void vm_getbind(struct vm *vm, vm_word_t insn,
 }
 
 NOINLINE static void vm_setsym(struct vm *vm, vm_word_t insn,
-                               val (*lookup_fn)(val env, val sym),
+                               val (*lookup_fn)(val sym),
                                val kind_str)
 {
   val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -912,7 +913,7 @@ NOINLINE static void vm_bindv(struct vm *vm, vm_word_t insn)
 }
 
 NOINLINE static void vm_gettab(struct vm *vm, vm_word_t insn,
-                               val (*lookup_fn)(val env, val sym),
+                               val (*lookup_fn)(val sym),
                                val kind_str)
 {
   unsigned idx = vm_insn_operand(insn);
@@ -921,7 +922,7 @@ NOINLINE static void vm_gettab(struct vm *vm, vm_word_t insn,
 }
 
 NOINLINE static void vm_settab(struct vm *vm, vm_word_t insn,
-                               val (*lookup_fn)(val env, val sym),
+                               val (*lookup_fn)(val sym),
                                val kind_str)
 {
   unsigned idx = vm_insn_operand(insn);
@@ -1035,28 +1036,28 @@ NOINLINE static val vm_execute(struct vm *vm)
       vm_handle(vm, insn);
       break;
     case GETV:
-      vm_getsym(vm, insn, lookup_var, lit("variable"));
+      vm_getsym(vm, insn, lookup_dynamic_var, lit("variable"));
       break;
     case OLDGETF:
-      vm_getsym(vm, insn, lookup_fun, lit("function"));
+      vm_getsym(vm, insn, lookup_global_fun, lit("function"));
       break;
     case GETL1:
-      vm_getsym(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+      vm_getsym(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
       break;
     case GETVB:
-      vm_getbind(vm, insn, lookup_var, lit("variable"));
+      vm_getbind(vm, insn, lookup_dynamic_var, lit("variable"));
       break;
     case GETFB:
-      vm_getbind(vm, insn, lookup_fun, lit("function"));
+      vm_getbind(vm, insn, lookup_global_fun, lit("function"));
       break;
     case GETL1B:
-      vm_getbind(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+      vm_getbind(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
       break;
     case SETV:
-      vm_setsym(vm, insn, lookup_var, lit("variable"));
+      vm_setsym(vm, insn, lookup_dynamic_var, lit("variable"));
       break;
     case SETL1:
-      vm_setsym(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+      vm_setsym(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
       break;
     case BINDV:
       vm_bindv(vm, insn);
@@ -1065,13 +1066,13 @@ NOINLINE static val vm_execute(struct vm *vm)
       vm_close(vm, insn);
       break;
     case GETLX:
-      vm_gettab(vm, insn, lookup_var, lit("variable"));
+      vm_gettab(vm, insn, lookup_global_var, lit("variable"));
       break;
     case SETLX:
-      vm_settab(vm, insn, lookup_var, lit("variable"));
+      vm_settab(vm, insn, lookup_global_var, lit("variable"));
       break;
     case GETF:
-      vm_gettab(vm, insn, lookup_fun, lit("function"));
+      vm_gettab(vm, insn, lookup_global_fun, lit("function"));
       break;
     default:
       uw_throwf(error_s, lit("invalid opcode ~s"), num_fast(opcode), nao);