Merge branch 'lazy-tearoff'

include/picrin.h

@@ -51,6 +51,9 @@ typedef struct {
   pic_code *ip;
   pic_value *fp;
   struct pic_env *env;
+  int regc;
+  pic_value *regs;
+  struct pic_env *up;
 } pic_callinfo;
 
 typedef struct pic_block {

include/picrin/proc.h

@@ -17,8 +17,8 @@ struct pic_func {
 
 struct pic_env {
   PIC_OBJECT_HEADER
-  pic_value *values;
+  pic_value *regs;
-  int valuec;
+  int regc;
   struct pic_env *up;
   pic_value storage[];
 };

src/cont.c

@@ -208,7 +208,7 @@ cont_call(pic_state *pic)
   proc = pic_get_proc(pic);
   pic_get_args(pic, "*", &argc, &argv);
 
-  cont = (struct pic_cont *)pic_ptr(proc->env->values[0]);
+  cont = (struct pic_cont *)pic_ptr(pic_proc_cv_ref(pic, proc, 0));
   cont->results = pic_list_by_array(pic, argc, argv);
 
   /* execute guard handlers */

src/gc.c

@@ -362,8 +362,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     struct pic_env *env = (struct pic_env *)obj;
     int i;
 
-    for (i = 0; i < env->valuec; ++i) {
+    for (i = 0; i < env->regc; ++i) {
-      gc_mark(pic, env->values[i]);
+      gc_mark(pic, env->regs[i]);
     }
     if (env->up) {
       gc_mark_object(pic, (struct pic_object *)env->up);

src/proc.c

@@ -41,8 +41,8 @@ pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
     pic_error(pic, "env slot already in use");
   }
   env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
-  env->valuec = cv_size;
+  env->regc = cv_size;
-  env->values = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value));
+  env->regs = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value));
   env->up = NULL;
 
   proc->env = env;
@@ -52,7 +52,7 @@ int
 pic_proc_cv_size(pic_state *pic, struct pic_proc *proc)
 {
   UNUSED(pic);
-  return proc->env ? proc->env->valuec : 0;
+  return proc->env ? proc->env->regc : 0;
 }
 
 pic_value
@@ -61,7 +61,7 @@ pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
   if (proc->env == NULL) {
     pic_error(pic, "no closed env");
   }
-  return proc->env->values[i];
+  return proc->env->regs[i];
 }
 
 void
@@ -70,7 +70,7 @@ pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
   if (proc->env == NULL) {
     pic_error(pic, "no closed env");
   }
-  proc->env->values[i] = v;
+  proc->env->regs[i] = v;
 }
 
 static pic_value

src/var.c

@@ -80,11 +80,11 @@ var_call(pic_state *pic)
 
   c = pic_get_args(pic, "|o", &v);
   if (c == 0) {
-    var = pic_var_ptr(proc->env->values[0]);
+    var = pic_var_ptr(proc->env->regs[0]);
     return pic_var_ref(pic, var);
   }
   else if (c == 1) {
-    var = pic_var_ptr(proc->env->values[0]);
+    var = pic_var_ptr(proc->env->regs[0]);
 
     pic_var_set(pic, var, v);
     return pic_none_value();

src/vm.c

@@ -424,17 +424,30 @@ pic_defvar(pic_state *pic, const char *name, pic_value init)
   pic_define(pic, name, pic_obj_value(pic_wrap_var(pic, var)));
 }
 
+static void
+vm_push_env(pic_state *pic)
+{
+  pic_callinfo *ci = pic->ci;
+
+  ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * ci->regc, PIC_TT_ENV);
+  ci->env->up = ci->up;
+  ci->env->regc = ci->regc;
+  ci->env->regs = ci->regs;
+}
+
 static void
 vm_tear_off(pic_state *pic)
 {
   struct pic_env *env;
   int i;
 
+  assert(pic->ci->env != NULL);
+
   env = pic->ci->env;
-  for (i = 0; i < env->valuec; ++i) {
+  for (i = 0; i < env->regc; ++i) {
-    env->storage[i] = env->values[i];
+    env->storage[i] = env->regs[i];
   }
-  env->values = env->storage;
+  env->regs = env->storage;
 }
 
 pic_value
@@ -596,22 +609,22 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       int depth = c.u.r.depth;
       struct pic_env *env;
 
-      env = pic->ci->env;
+      env = pic->ci->up;
-      while (depth--) {
+      while (--depth) {
 	env = env->up;
       }
-      PUSH(env->values[c.u.r.idx]);
+      PUSH(env->regs[c.u.r.idx]);
       NEXT;
     }
     CASE(OP_CSET) {
       int depth = c.u.r.depth;
       struct pic_env *env;
 
-      env = pic->ci->env;
+      env = pic->ci->up;
-      while (depth--) {
+      while (--depth) {
 	env = env->up;
       }
-      env->values[c.u.r.idx] = POP();
+      env->regs[c.u.r.idx] = POP();
       NEXT;
     }
     CASE(OP_JMP) {
@@ -720,10 +733,9 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 	}
 
 	/* prepare env */
-        ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * irep->capturec, PIC_TT_ENV);
+        ci->up = proc->env;
-        ci->env->up = proc->env;
+        ci->regc = irep->capturec;
-        ci->env->valuec = irep->capturec;
+        ci->regs = ci->fp + irep->argc + irep->localc;
-        ci->env->values = ci->fp + irep->argc + irep->localc;
 
 	pic->ip = irep->code;
 	pic_gc_arena_restore(pic, ai);
@@ -735,7 +747,9 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       pic_value *argv;
       pic_callinfo *ci;
 
-      vm_tear_off(pic);
+      if (pic->ci->env != NULL) {
+        vm_tear_off(pic);
+      }
 
       if (c.u.i == -1) {
         pic->sp += pic->ci[1].retc - 1;
@@ -765,7 +779,9 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 	goto L_STOP;
       }
 
-      vm_tear_off(pic);
+      if (pic->ci->env != NULL) {
+        vm_tear_off(pic);
+      }
 
       pic->ci->retc = c.u.i;
 
@@ -797,6 +813,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
       if (! pic_proc_irep_p(pic_proc_ptr(self))) {
         pic_error(pic, "logic flaw");
       }
+
+      if (pic->ci->env == NULL) {
+        vm_push_env(pic);
+      }
+
       proc = pic_proc_new_irep(pic, irep->irep[c.u.i], pic->ci->env);
       PUSH(pic_obj_value(proc));
       pic_gc_arena_restore(pic, ai);