optimize var implementation

contrib/03.callcc/callcc.c

@@ -21,6 +21,8 @@ struct pic_fullcont {
 
   pic_code *ip;
 
+  pic_value ptable;
+
   struct pic_object **arena;
   size_t arena_size;
   int arena_idx;
@@ -83,6 +85,9 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
     mark(pic, pic_obj_value(cont->arena[i]));
   }
 
+  /* parameter table */
+  mark(pic, cont->ptable);
+
   /* result values */
   mark(pic, cont->results);
 }
@@ -144,6 +149,8 @@ save_cont(pic_state *pic, struct pic_fullcont **c)
 
   cont->ip = pic->ip;
 
+  cont->ptable = pic->ptable;
+
   cont->arena_idx = pic->arena_idx;
   cont->arena_size = pic->arena_size;
   cont->arena = pic_malloc(pic, sizeof(struct pic_object *) * pic->arena_size);
@@ -195,6 +202,8 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
 
   pic->ip = cont->ip;
 
+  pic->ptable = cont->ptable;
+
   pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
   memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
   pic->arena_size = cont->arena_size;

extlib/benz/boot.c

@@ -306,30 +306,15 @@ my $src = <<'EOL';
                             `(,(r 'begin) ,@(cdr clause)))
                        ,(loop (cdr clauses)))))))))))
 
-  (define (dynamic-bind parameters values body)
-    (let* ((old-bindings
-            (current-dynamic-environment))
-           (binding
-            (map (lambda (parameter value)
-                   (cons parameter (parameter value #f)))
-                 parameters
-                 values))
-           (new-bindings
-            (cons binding old-bindings)))
-      (dynamic-wind
-          (lambda () (current-dynamic-environment new-bindings))
-          body
-          (lambda () (current-dynamic-environment old-bindings)))))
-
   (define-syntax parameterize
     (er-macro-transformer
      (lambda (form r compare)
        (let ((formal (cadr form))
              (body (cddr form)))
-         `(,(r 'dynamic-bind)
+         `(,(r 'with-parameter)
-           (list ,@(map car formal))
+           (lambda ()
-           (list ,@(map cadr formal))
+             ,@formal
-           (,(r 'lambda) () ,@body))))))
+             ,@body))))))
 
   (define-syntax letrec-syntax
     (er-macro-transformer
@@ -538,26 +523,19 @@ const char pic_boot[][80] = {
 "      (car clause))))\n                       ,(if (compare (r '=>) (list-ref cla",
 "use 1))\n                            `(,(list-ref clause 2) ,(r 'key))\n          ",
 "                  `(,(r 'begin) ,@(cdr clause)))\n                       ,(loop (",
-"cdr clauses)))))))))))\n\n  (define (dynamic-bind parameters values body)\n    (let",
+"cdr clauses)))))))))))\n\n  (define-syntax parameterize\n    (er-macro-transformer\n",
-"* ((old-bindings\n            (current-dynamic-environment))\n           (binding\n",
+"     (lambda (form r compare)\n       (let ((formal (cadr form))\n             (bo",
-"            (map (lambda (parameter value)\n                   (cons parameter (p",
+"dy (cddr form)))\n         `(,(r 'with-parameter)\n           (lambda ()\n         ",
-"arameter value #f)))\n                 parameters\n                 values))\n     ",
+"    ,@formal\n             ,@body))))))\n\n  (define-syntax letrec-syntax\n    (er-m",
-"      (new-bindings\n            (cons binding old-bindings)))\n      (dynamic-win",
+"acro-transformer\n     (lambda (form r c)\n       (let ((formal (car (cdr form)))\n",
-"d\n          (lambda () (current-dynamic-environment new-bindings))\n          bod",
+"             (body   (cdr (cdr form))))\n         `(let ()\n            ,@(map (la",
-"y\n          (lambda () (current-dynamic-environment old-bindings)))))\n\n  (define",
+"mbda (x)\n                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n       ",
-"-syntax parameterize\n    (er-macro-transformer\n     (lambda (form r compare)\n   ",
+"            formal)\n            ,@body)))))\n\n  (define-syntax let-syntax\n    (er",
-"    (let ((formal (cadr form))\n             (body (cddr form)))\n         `(,(r '",
+"-macro-transformer\n     (lambda (form r c)\n       `(,(r 'letrec-syntax) ,@(cdr f",
-"dynamic-bind)\n           (list ,@(map car formal))\n           (list ,@(map cadr ",
+"orm)))))\n\n  (export let let* letrec letrec*\n          let-values let*-values def",
-"formal))\n           (,(r 'lambda) () ,@body))))))\n\n  (define-syntax letrec-synta",
+"ine-values\n          quasiquote unquote unquote-splicing\n          and or\n      ",
-"x\n    (er-macro-transformer\n     (lambda (form r c)\n       (let ((formal (car (c",
+"    cond case else =>\n          do when unless\n          parameterize\n          ",
-"dr form)))\n             (body   (cdr (cdr form))))\n         `(let ()\n           ",
+"let-syntax letrec-syntax\n          syntax-error))\n\n",
-" ,@(map (lambda (x)\n                     `(,(r 'define-syntax) ,(car x) ,(cadr x",
-")))\n                   formal)\n            ,@body)))))\n\n  (define-syntax let-syn",
-"tax\n    (er-macro-transformer\n     (lambda (form r c)\n       `(,(r 'letrec-synta",
-"x) ,@(cdr form)))))\n\n  (export let let* letrec letrec*\n          let-values let*",
-"-values define-values\n          quasiquote unquote unquote-splicing\n          an",
-"d or\n          cond case else =>\n          do when unless\n          parameterize",
-"\n          let-syntax letrec-syntax\n          syntax-error))\n\n",
 "",
 ""
 };

extlib/benz/cont.c

@@ -61,6 +61,7 @@ pic_save_point(pic_state *pic, struct pic_cont *cont)
   cont->xp_offset = pic->xp - pic->xpbase;
   cont->arena_idx = pic->arena_idx;
   cont->ip = pic->ip;
+  cont->ptable = pic->ptable;
 
   cont->results = pic_undef_value();
 }
@@ -88,6 +89,7 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
   pic->xp = pic->xpbase + cont->xp_offset;
   pic->arena_idx = cont->arena_idx;
   pic->ip = cont->ip;
+  pic->ptable = cont->ptable;
 }
 
 static pic_value

extlib/benz/gc.c

@@ -598,6 +598,9 @@ gc_mark_phase(pic_state *pic)
     gc_mark_object(pic, (struct pic_object *)pic->xSTDERR);
   }
 
+  /* parameter table */
+  gc_mark(pic, pic->ptable);
+
   /* attributes */
   do {
     j = 0;

extlib/benz/include/picrin.h

@@ -130,6 +130,9 @@ typedef struct {
   pic_value libs;
   xhash attrs;
 
+  pic_value ptable;
+  size_t pnum;
+
   struct pic_reader *reader;
 
   bool gc_enable;

extlib/benz/include/picrin/cont.h

@@ -21,6 +21,8 @@ struct pic_cont {
 
   pic_code *ip;
 
+  pic_value ptable;
+
   pic_value results;
 };
 

extlib/benz/include/picrin/proc.h

@@ -50,6 +50,7 @@ struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_c
 
 pic_sym *pic_proc_name(struct pic_proc *);
 struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *);
+bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *);
 pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *);
 void pic_proc_env_set(pic_state *, struct pic_proc *, const char *, pic_value);
 

extlib/benz/proc.c

@@ -57,6 +57,12 @@ pic_proc_env(pic_state *pic, struct pic_proc *proc)
   return proc->u.f.env;
 }
 
+bool
+pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key)
+{
+  return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key));
+}
+
 pic_value
 pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key)
 {

extlib/benz/state.c

@@ -230,6 +230,10 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   pic->xSTDOUT = NULL;
   pic->xSTDERR = NULL;
 
+  /* parameter table */
+  pic->ptable = pic_nil_value();
+  pic->pnum = 0;
+
   /* native stack marker */
   pic->native_stack_start = &t;
 
@@ -342,6 +346,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
   pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
   pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);
 
+  /* parameter table */
+  pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
+
   /* standard libraries */
   pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)"));
   pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));

extlib/benz/var.c

@@ -5,84 +5,79 @@
 #include "picrin.h"
 
 static pic_value
-var_lookup(pic_state *pic, struct pic_proc *var)
+var_conv(pic_state *pic, struct pic_proc *var, pic_value val)
 {
-  pic_value val, env, binding;
+  if (pic_proc_env_has(pic, var, "conv") != 0) {
-  pic_value key = pic_obj_value(var);
+    return pic_apply1(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), val);
-
-  val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment");
-  if (pic_eq_p(val, key)) {
-    return pic_false_value();
   }
+  return val;
+}
 
-  env = pic_apply0(pic, pic_proc_ptr(val));
+static pic_value
-  while (! pic_nil_p(env)) {
+var_get(pic_state *pic, struct pic_proc *var)
-    binding = pic_car(pic, env);
+{
+  pic_value elem, it;
+  pic_sym *id;
+  struct pic_dict *dict;
 
-    while (! pic_nil_p(binding)) {
+  id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
-      if (pic_eq_p(pic_caar(pic, binding), key)) {
+
-        return pic_car(pic, binding);
+  pic_for_each (elem, pic->ptable, it) {
-      }
+    dict = pic_dict_ptr(elem);
-      binding = pic_cdr(pic, binding);
+    if (pic_dict_has(pic, dict, id)) {
+      return pic_dict_ref(pic, dict, id);
     }
-    env = pic_cdr(pic, env);
   }
+  pic_panic(pic, "logic flaw");
+}
 
-  return pic_false_value();
+static pic_value
+var_set(pic_state *pic, struct pic_proc *var, pic_value val)
+{
+  pic_sym *id;
+  struct pic_dict *dict;
+
+  id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
+
+  dict = pic_dict_ptr(pic_car(pic, pic->ptable));
+
+  pic_dict_set(pic, dict, id, var_conv(pic, var, val));
+
+  return pic_none_value();
 }
 
 static pic_value
 var_call(pic_state *pic)
 {
   struct pic_proc *self = pic_get_proc(pic);
-  pic_value val, tmp, box, conv;
+  pic_value val;
   int n;
 
-  n = pic_get_args(pic, "|oo", &val, &tmp);
+  n = pic_get_args(pic, "|o", &val);
 
-  box = var_lookup(pic, self);
+  if (n == 0) {
-  if (! pic_test(box)) {
+    return var_get(pic, self);
-    box = pic_proc_env_ref(pic, self, "box");
+  } else {
+    return var_set(pic, self, val);
   }
-
-  switch (n) {
-  case 0:
-    return pic_cdr(pic, box);
-
-  case 1:
-    conv = pic_proc_env_ref(pic, self, "conv");
-    if (pic_test(conv)) {
-      pic_assert_type(pic, conv, proc);
-
-      val = pic_apply1(pic, pic_proc_ptr(conv), val);
-    }
-    pic_set_cdr(pic, box, val);
-
-    return pic_none_value();
-
-  case 2:
-    assert(pic_false_p(tmp));
-
-    conv = pic_proc_env_ref(pic, self, "conv");
-    if (pic_test(conv)) {
-      pic_assert_type(pic, conv, proc);
-
-      return pic_apply1(pic, pic_proc_ptr(conv), val);
-    } else {
-      return val;
-    }
-  }
-  PIC_UNREACHABLE();
 }
 
 struct pic_proc *
 pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
 {
   struct pic_proc *var;
+  pic_value converter = conv ? pic_obj_value(conv) : pic_false_value();
+  pic_sym *id;
 
   var = pic_make_proc(pic, var_call, "<var-call>");
-  pic_proc_env_set(pic, var, "box", pic_cons(pic, pic_false_value(), init));
+
-  pic_proc_env_set(pic, var, "conv", conv ? pic_obj_value(conv) : pic_false_value());
+  if (conv != NULL) {
+    pic_proc_env_set(pic, var, "conv", converter);
+  }
+  id = pic_intern(pic, pic_format(pic, "%d", pic->pnum++));
+  pic_proc_env_set(pic, var, "id", pic_obj_value(id));
+
+  pic_apply1(pic, var, init);
 
   return var;
 }
@@ -98,12 +93,26 @@ pic_var_make_parameter(pic_state *pic)
   return pic_obj_value(pic_make_var(pic, init, conv));
 }
 
+static pic_value
+pic_var_with_parameter(pic_state *pic)
+{
+  struct pic_proc *body;
+  pic_value val;
+
+  pic_get_args(pic, "l", &body);
+
+  pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
+
+  val = pic_apply0(pic, body);
+
+  pic->ptable = pic_cdr(pic, pic->ptable);
+
+  return val;
+}
+
 void
 pic_init_var(pic_state *pic)
 {
-  pic_define_noexport(pic, "current-dynamic-environment", pic_false_value());
-
   pic_defun(pic, "make-parameter", pic_var_make_parameter);
-
+  pic_defun(pic, "with-parameter", pic_var_with_parameter);
-  pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL)));
 }