use xhash to manage scopes during codegin

Makefile

@@ -11,7 +11,7 @@ build-lib:
 	cd src; \
 	yacc -d parse.y; \
 	lex scan.l
-	 $(CC) -Wall -shared -o lib/libpicrin.so -I./include src/*.c
+	 $(CC) -Wall -shared -o lib/libpicrin.so -I./include -I./extlib src/*.c
 
 clean:
 	rm -f src/y.tab.c src/y.tab.h src/lex.yy.c

extlib/xhash/xhash.h

@@ -0,0 +1,104 @@
+#ifndef XHASH_H__
+#define XHASH_H__
+
+/*
+ * Copyright (c) 2013 by Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
+ */
+
+#include <stdlib.h>
+#include <string.h>
+
+/* simple string to int hash table */
+
+#define XHASH_INIT_SIZE 11
+
+struct xh_entry {
+  struct xh_entry *next;
+  const char *key;
+  int val;
+};
+
+struct xhash {
+  struct xh_entry **buckets;
+  size_t size;
+};
+
+static inline struct xhash *
+xh_new()
+{
+  struct xhash *x;
+
+  x = (struct xhash *)malloc(sizeof(struct xhash));
+  x->size = XHASH_INIT_SIZE;
+  x->buckets = (struct xh_entry **)calloc(XHASH_INIT_SIZE, sizeof(struct xh_entry *));
+  return x;
+}
+
+static int
+xh_hash(const char *str)
+{
+  int hash = 0;
+
+  while (*str) {
+    hash = hash * 31 + *str++;
+  }
+  return hash;
+}
+
+static inline struct xh_entry *
+xh_get(struct xhash *x, const char *key)
+{
+  int idx;
+  struct xh_entry *e;
+
+  idx = xh_hash(key) % x->size;
+  for (e = x->buckets[idx]; e; e = e->next) {
+    if (! strcmp(key, e->key))
+      return e;
+  }
+  return NULL;
+}
+
+static inline struct xh_entry *
+xh_put(struct xhash *x, const char *key, int val)
+{
+  int idx, len;
+  char *new_key;
+  struct xh_entry *e;
+
+  if ((e = xh_get(x, key))) {
+    e->val = val;
+    return e;
+  }
+
+  len = strlen(key);
+  new_key = (char *)malloc(len+1);
+  strcpy(new_key, key);
+
+  idx = xh_hash(key) % x->size;
+  e = (struct xh_entry *)malloc(sizeof(struct xh_entry));
+  e->next = x->buckets[idx];
+  e->key = new_key;
+  e->val = val;
+
+  return x->buckets[idx] = e;
+}
+
+static inline void
+xh_destory(struct xhash *x)
+{
+  int i;
+  struct xh_entry *e;
+
+  for (i = 0; i < x->size; ++i) {
+    e = x->buckets[i];
+    while (e) {
+      e = e->next;
+      free((void*)e->key);
+      free(e);
+    }
+  }
+  free(x);
+}
+
+#endif

include/picrin.h

@@ -29,12 +29,13 @@ typedef struct {
   pic_value sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE;
   pic_value sCONS, sCAR, sCDR, sNILP;
   pic_value sADD, sSUB, sMUL, sDIV;
-  struct pic_env *global_env;
 
   struct sym_tbl *sym_tbl;
 
+  struct xhash *global_tbl;
   pic_value *globals;
   size_t glen, gcapa;
+
   struct pic_irep **irep;
   size_t ilen, icapa;
   pic_value *pool;
@@ -74,9 +75,8 @@ pic_value pic_str_new_cstr(pic_state *, const char *);
 
 bool pic_parse(pic_state *, const char *, pic_value *);
 
-pic_value pic_eval(pic_state *, pic_value, struct pic_env *);
 pic_value pic_run(pic_state *, struct pic_proc *, pic_value);
-struct pic_proc *pic_codegen(pic_state *, pic_value, struct pic_env *);
+struct pic_proc *pic_codegen(pic_state *, pic_value);
 
 void pic_abort(pic_state *, const char *);
 void pic_raise(pic_state *, pic_value);

include/picrin/proc.h

@@ -1,11 +1,6 @@
 #ifndef PROC_H__
 #define PROC_H__
 
-struct pic_env {
-  pic_value assoc;
-  struct pic_env *parent;
-};
-
 struct pic_proc {
   PIC_OBJECT_HEADER
   bool cfunc_p;

src/codegen.c

@@ -4,28 +4,81 @@
 #include "picrin/pair.h"
 #include "picrin/irep.h"
 #include "picrin/proc.h"
+#include "xhash/xhash.h"
+
+struct pic_scope {
+  struct pic_scope *up;
+
+  struct xhash *local_tbl;
+  size_t localc;
+};
+
+static struct pic_scope *
+new_global_scope(pic_state *pic)
+{
+  struct pic_scope *scope;
+
+  scope = (struct pic_scope *)pic_alloc(pic, sizeof(struct pic_scope));
+  scope->up = NULL;
+  scope->local_tbl = pic->global_tbl;
+  scope->localc = -1;
+  return scope;
+}
+
+static struct pic_scope *
+new_local_scope(pic_state *pic, pic_value args, struct pic_scope *scope)
+{
+  struct pic_scope *new_scope;
+  pic_value v;
+  int i;
+  struct xhash *x;
+
+  new_scope = (struct pic_scope *)pic_alloc(pic, sizeof(struct pic_scope));
+  new_scope->up = scope;
+  new_scope->local_tbl = x = xh_new();
+
+  i = -1;
+  for (v = args; ! pic_nil_p(v); v = pic_cdr(pic, v)) {
+    pic_value sym;
+
+    sym = pic_car(pic, v);
+    xh_put(x, pic_symbol_ptr(sym)->name, i--);
+  }
+  new_scope->localc = -1-i;
+
+  return new_scope;
+}
+
+static void
+destory_scope(pic_state *pic, struct pic_scope *scope)
+{
+  if (scope->up) {
+    xh_destory(scope->local_tbl);
+  }
+  pic_free(pic, scope);
+}
 
 static bool
-env_lookup(pic_state *pic, pic_value sym, struct pic_env *env, int *depth, int *idx)
+scope_lookup(pic_state *pic, const char *key, struct pic_scope *scope, int *depth, int *idx)
 {
-  pic_value v;
+  struct xh_entry *e;
   int d = 0;
 
  enter:
 
-  v = pic_assq(pic, sym, env->assoc);
+  e = xh_get(scope->local_tbl, key);
-  if (! pic_nil_p(v)) {
+  if (e) {
-    if (env->parent == NULL) {		/* global */
+    if (scope->up == NULL) {	/* global */
       *depth = -1;
     }
     else {			/* non-global */
       *depth = d;
     }
-    *idx = (int)pic_float(pic_pair_ptr(v)->cdr);
+    *idx = e->val;
     return true;
   }
-  if (env->parent) {
+  if (scope->up) {
-    env = env->parent;
+    scope = scope->up;
     ++d;
     goto enter;
   }
@@ -33,42 +86,18 @@ env_lookup(pic_state *pic, pic_value sym, struct pic_env *env, int *depth, int *
 }
 
 static int
-env_global_define(pic_state *pic, pic_value sym)
+scope_global_define(pic_state *pic, const char *name)
 {
-  pic_value f;
+  struct xh_entry *e;
-  int d, idx;
 
-  if (env_lookup(pic, sym, pic->global_env, &d, &idx)) {
+  if ((e = xh_get(pic->global_tbl, name))) {
-    return idx;
+    return e->val;
   }
-
+  e = xh_put(pic->global_tbl, name, pic->glen++);
-  idx = pic->glen++;
+  if (pic->glen >= pic->gcapa) {
-  f = pic_float_value(idx);
+    pic_error(pic, "global table overflow");
-  pic->global_env->assoc = pic_acons(pic, sym, f, pic->global_env->assoc);
-
-  return idx;
   }
-
+  return e->val;
-static struct pic_env *
-env_new(pic_state *pic, pic_value args, struct pic_env *env)
-{
-  struct pic_env *inner_env;
-  pic_value v, f;
-  int i;
-
-  inner_env = (struct pic_env *)pic_alloc(pic, sizeof(struct pic_env));
-  inner_env->assoc = pic_nil_value();
-  inner_env->parent = env;
-
-  i = -1;
-  for (v = args; ! pic_nil_p(v); v = pic_cdr(pic, v)) {
-    pic_value sym = pic_car(pic, v);
-
-    f = pic_float_value(i--);
-    inner_env->assoc = pic_acons(pic, sym, f, inner_env->assoc);
-  }
-
-  return inner_env;
 }
 
 void
@@ -78,7 +107,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
   int idx;
 
   proc = pic_proc_new_cfunc(pic, cfunc, pic_undef_value());
-  idx = env_global_define(pic, pic_intern_cstr(pic, name));
+  idx = scope_global_define(pic, name);
   pic->globals[idx] = pic_obj_value(proc);
 }
 
@@ -177,11 +206,11 @@ new_irep(pic_state *pic)
   return irep;
 }
 
-static void pic_gen_call(pic_state *, struct pic_irep *, pic_value, struct pic_env *);
+static void pic_gen_call(pic_state *, struct pic_irep *, pic_value, struct pic_scope *);
-static struct pic_irep *pic_gen_lambda(pic_state *, pic_value, struct pic_env *);
+static struct pic_irep *pic_gen_lambda(pic_state *, pic_value, struct pic_scope *);
 
 static void
-pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *env)
+pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_scope *scope)
 {
   pic_value sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE;
   pic_value sCONS, sCAR, sCDR, sNILP;
@@ -205,8 +234,10 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
   case PIC_TT_SYMBOL: {
     bool b;
     int depth, idx;
+    const char *name;
 
-    b = env_lookup(pic, obj, env, &depth, &idx);
+    name = pic_symbol_ptr(obj)->name;
+    b = scope_lookup(pic, name, scope, &depth, &idx);
     if (! b) {
       pic_error(pic, "unbound variable");
     }
@@ -232,10 +263,12 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
     proc = pic_car(pic, obj);
     if (pic_eq_p(pic, proc, sDEFINE)) {
       int idx;
+      const char *name;
 
-      idx = env_global_define(pic, pic_car(pic, pic_cdr(pic, obj)));
+      name = pic_symbol_ptr(pic_car(pic, pic_cdr(pic, obj)))->name;
+      idx = scope_global_define(pic, name);
 
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
 
       irep->code[irep->clen].insn = OP_GSET;
       irep->code[irep->clen].u.i = idx;
@@ -249,26 +282,26 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
       irep->code[irep->clen].u.i = pic->ilen;
       irep->clen++;
 
-      pic->irep[pic->ilen++] = pic_gen_lambda(pic, obj, env);
+      pic->irep[pic->ilen++] = pic_gen_lambda(pic, obj, scope);
       break;
     }
     else if (pic_eq_p(pic, proc, sIF)) {
       int s,t;
 
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
 
       irep->code[irep->clen].insn = OP_JMPIF;
       s = irep->clen++;
 
       /* if false branch */
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, pic_cdr(pic, obj)))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, pic_cdr(pic, obj)))), scope);
       irep->code[irep->clen].insn = OP_JMP;
       t = irep->clen++;
 
       irep->code[s].u.i = irep->clen - s;
 
       /* if true branch */
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
       irep->code[t].u.i = irep->clen - t;
       break;
     }
@@ -277,7 +310,7 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
 
       seq = pic_cdr(pic, obj);
       for (v = seq; ! pic_nil_p(v); v = pic_cdr(pic, v)) {
-	pic_gen(pic, irep, pic_car(pic, v), env);
+	pic_gen(pic, irep, pic_car(pic, v), scope);
 	irep->code[irep->clen].insn = OP_POP;
 	irep->clen++;
       }
@@ -294,60 +327,60 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
       break;
     }
     else if (pic_eq_p(pic, proc, sCONS)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_CONS;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sCAR)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_CAR;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sCDR)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_CDR;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sNILP)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_NILP;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sADD)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_ADD;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sSUB)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_SUB;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sMUL)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_MUL;
       irep->clen++;
       break;
     }
     else if (pic_eq_p(pic, proc, sDIV)) {
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), scope);
-      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env);
+      pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), scope);
       irep->code[irep->clen].insn = OP_DIV;
       irep->clen++;
       break;
     }
     else {
-      pic_gen_call(pic, irep, obj, env);
+      pic_gen_call(pic, irep, obj, scope);
       break;
     }
   }
@@ -391,7 +424,7 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en
 }
 
 static void
-pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *env)
+pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_scope *scope)
 {
   pic_value seq;
   int i = 0;
@@ -401,7 +434,7 @@ pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_en
     pic_value v;
 
     v = pic_car(pic, seq);
-    pic_gen(pic, irep, v, env);
+    pic_gen(pic, irep, v, scope);
     ++i;
   }
   irep->code[irep->clen].insn = OP_CALL;
@@ -410,9 +443,9 @@ pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_en
 }
 
 static struct pic_irep *
-pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_env *env)
+pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_scope *scope)
 {
-  struct pic_env *inner_env;
+  struct pic_scope *new_scope;
   pic_value args, body, v;
   struct pic_irep *irep;
 
@@ -420,19 +453,20 @@ pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_env *env)
 
   /* arguments */
   args = pic_car(pic, pic_cdr(pic, obj));
-  inner_env = env_new(pic, args, env);
+  new_scope = new_local_scope(pic, args, scope);
 
   /* body */
   body = pic_cdr(pic, pic_cdr(pic, obj));
   for (v = body; ! pic_nil_p(v); v = pic_cdr(pic, v)) {
-    pic_gen(pic, irep, pic_car(pic, v), inner_env);
+    pic_gen(pic, irep, pic_car(pic, v), scope);
     irep->code[irep->clen].insn = OP_POP;
     irep->clen++;
   }
   irep->clen--;
   irep->code[irep->clen].insn = OP_RET;
   irep->clen++;
-  pic_free(pic, inner_env);
+
+  destory_scope(pic, new_scope);
 
 #if VM_DEBUG
   printf("LAMBDA_%zd:\n", pic->ilen);
@@ -444,11 +478,14 @@ pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_env *env)
 }
 
 struct pic_proc *
-pic_codegen(pic_state *pic, pic_value obj, struct pic_env *env)
+pic_codegen(pic_state *pic, pic_value obj)
 {
+  struct pic_scope *global_scope;
   struct pic_proc *proc;
   struct pic_irep *irep;
 
+  global_scope = new_global_scope(pic);
+
   irep = new_irep(pic);
   proc = pic_proc_new(pic, irep);
 
@@ -464,10 +501,12 @@ pic_codegen(pic_state *pic, pic_value obj, struct pic_env *env)
       return NULL;
     }
   }
-  pic_gen(pic, irep, obj, env);
+  pic_gen(pic, irep, obj, global_scope);
   irep->code[irep->clen].insn = OP_STOP;
   irep->clen++;
 
+  destory_scope(pic, global_scope);
+
 #if VM_DEBUG
   print_irep(pic, irep);
 #endif

src/gc.c

@@ -181,7 +181,6 @@ static void
 gc_mark_phase(pic_state *pic)
 {
   pic_value *stack;
-  struct pic_env *env;
   int i;
 
   /* stack */
@@ -195,12 +194,6 @@ gc_mark_phase(pic_state *pic)
     gc_mark_object(pic, pic->arena[i]);
   }
 
-  /* global env */
-  env = pic->global_env;
-  do {
-    gc_mark(pic, env->assoc);
-  } while ((env = env->parent) != NULL);
-
   /* globals */
   for (i = 0; i < pic->glen; ++i) {
     gc_mark(pic, pic->globals[i]);

src/state.c

@@ -4,18 +4,7 @@
 #include "picrin/gc.h"
 #include "picrin/proc.h"
 #include "picrin/symbol.h"
-
+#include "xhash/xhash.h"
-static struct pic_env *
-new_empty_env()
-{
-  struct pic_env *env;
-
-  env = (struct pic_env *)malloc(sizeof(struct pic_env));
-  env->assoc = pic_nil_value();
-  env->parent = NULL;
-
-  return env;
-}
 
 struct sym_tbl *
 sym_tbl_new()
@@ -68,6 +57,7 @@ pic_open(int argc, char *argv[], char **envp)
   pic->icapa = PIC_IREP_SIZE;
 
   /* globals */
+  pic->global_tbl = xh_new();
   pic->globals = (pic_value *)malloc(sizeof(pic_value) * PIC_GLOBALS_SIZE);
   pic->glen = 0;
   pic->gcapa = PIC_GLOBALS_SIZE;
@@ -84,10 +74,6 @@ pic_open(int argc, char *argv[], char **envp)
   /* GC arena */
   pic->arena_idx = 0;
 
-  /* global environment */
-  pic->global_env = new_empty_env();
-  pic_init_core(pic);
-
   ai = pic_gc_arena_preserve(pic);
   pic->sDEFINE = pic_intern_cstr(pic, "define");
   pic->sLAMBDA = pic_intern_cstr(pic, "lambda");
@@ -104,6 +90,8 @@ pic_open(int argc, char *argv[], char **envp)
   pic->sDIV = pic_intern_cstr(pic, "/");
   pic_gc_arena_restore(pic, ai);
 
+  pic_init_core(pic);
+
   return pic;
 }
 

tools/main.c

@@ -80,7 +80,7 @@ main(int argc, char *argv[], char **envp)
 #endif
 
     /* eval */
-    proc = pic_codegen(pic, v, pic->global_env);
+    proc = pic_codegen(pic, v);
     if (proc == NULL) {
       printf("compilation error: %s\n", pic->errmsg);
       pic->errmsg = NULL;