Status note

Closes https://github.com/picrin-scheme/picrin/issues/355

Signed-off-by: Masanori Ogino <167209+omasanori@users.noreply.github.com>

.gitignore

@@ -1,6 +1,10 @@
 *.o
-src/load_piclib.c
+bin/
+lib/libpicrin.a
+lib/mini-picrin
 src/init_contrib.c
+src/init_lib.c
+src/load_piclib.c
 docs/contrib.rst
 .dir-locals.el
 GPATH

README.md

@@ -1,5 +1,7 @@
 <img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img>
 
+# The project is in hiatus and being archived soon...
+
 [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin)
 [![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)
 

docs/intro.rst

@@ -26,11 +26,6 @@ Documentation
 
 See http://picrin.readthedocs.org/
 
-IRC
----
-
-There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/
-
 LICENSE
 -------
 

lib/dict.c

@@ -242,39 +242,6 @@ pic_dict_alist_to_dictionary(pic_state *pic)
   return dict;
 }
 
-static pic_value
-pic_dict_dictionary_to_plist(pic_state *pic)
-{
-  pic_value dict, key, val, plist = pic_nil_value(pic);
-  int it = 0;
-
-  pic_get_args(pic, "d", &dict);
-
-  while (pic_dict_next(pic, dict, &it, &key, &val)) {
-    pic_push(pic, val, plist);
-    pic_push(pic, key, plist);
-  }
-
-  return plist;
-}
-
-static pic_value
-pic_dict_plist_to_dictionary(pic_state *pic)
-{
-  pic_value dict, plist, e;
-
-  pic_get_args(pic, "o", &plist);
-
-  dict = pic_make_dict(pic);
-
-  for (e = pic_reverse(pic, plist); ! pic_nil_p(pic, e); e = pic_cddr(pic, e)) {
-    TYPE_CHECK(pic, pic_cadr(pic, e), sym);
-    pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e));
-  }
-
-  return dict;
-}
-
 void
 pic_init_dict(pic_state *pic)
 {
@@ -290,6 +257,4 @@ pic_init_dict(pic_state *pic)
   pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);
   pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist);
   pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary);
-  pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist);
-  pic_defun(pic, "plist->dictionary", pic_dict_plist_to_dictionary);
 }

lib/ext/cont.c

@@ -17,7 +17,7 @@
 static pic_value
 pic_cont_reset(pic_state *pic)
 {
-  pic_value thunk;
+  pic_value thunk, prev = pic_ref(pic, "__picrin_dynenv__");
   struct context cxt;
 
   pic_get_args(pic, "l", &thunk);
@@ -25,21 +25,23 @@ pic_cont_reset(pic_state *pic)
   CONTEXT_INITK(pic, &cxt, thunk, pic->halt, 0, (pic_value *) NULL);
   cxt.reset = 1;
   pic_vm(pic, &cxt);
+  pic_set(pic, "__picrin_dynenv__", prev);
   return pic_protect(pic, cxt.fp->regs[1]);
 }
 
 static pic_value
 shift_call(pic_state *pic)
 {
-  pic_value x;
+  pic_value x, prev = pic_ref(pic, "__picrin_dynenv__");
   struct context cxt;
 
   pic_get_args(pic, "o", &x);
 
   CONTEXT_INIT(pic, &cxt, pic_closure_ref(pic, 0), 1, &x);
   cxt.reset = 1;
-  pic->dyn_env = pic_closure_ref(pic, 1);
+  pic_set(pic, "__picrin_dynenv__", pic_closure_ref(pic, 1));
   pic_vm(pic, &cxt);
+  pic_set(pic, "__picrin_dynenv__", prev);
   return pic_protect(pic, cxt.fp->regs[1]);
 }
 
@@ -54,7 +56,7 @@ pic_cont_shift(pic_state *pic)
     pic_error(pic, "c function call interleaved in delimited continuation", 0);
   }
 
-  k = pic_lambda(pic, shift_call, 2, pic->cxt->fp->regs[1], pic->dyn_env);
+  k = pic_lambda(pic, shift_call, 2, pic->cxt->fp->regs[1], pic_ref(pic, "__picrin_dynenv__"));
   CONTEXT_INITK(pic, pic->cxt, f, pic->halt, 1, &k);
   return pic_invalid_value(pic);
 }
@@ -85,7 +87,7 @@ cont_call(pic_state *pic)
     }
     pic->cxt = pic->cxt->prev;
   }
-  pic->dyn_env = dyn_env;
+  pic_set(pic, "__picrin_dynenv__", dyn_env);
 
   longjmp(cxt->jmp, 1);
   PIC_UNREACHABLE();
@@ -96,7 +98,7 @@ pic_make_cont(pic_state *pic, pic_value k)
 {
   static const pic_data_type cxt_type = { "cxt", NULL };
   pic_value c;
-  c = pic_lambda(pic, cont_call, 4, pic_true_value(pic), pic_data_value(pic, pic->cxt, &cxt_type), k, pic->dyn_env);
+  c = pic_lambda(pic, cont_call, 4, pic_true_value(pic), pic_data_value(pic, pic->cxt, &cxt_type), k, pic_ref(pic, "__picrin_dynenv__"));
   pic->cxt->conts = pic_cons(pic, c, pic->cxt->conts);
   return c;
 }

lib/ext/error.c

@@ -52,7 +52,7 @@ pic_enter_try(pic_state *pic)
   var = pic_exc(pic);
   env = pic_make_attr(pic);
   pic_attr_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
-  pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
+  pic_set(pic, "__picrin_dynenv__", pic_cons(pic, env, pic_ref(pic, "__picrin_dynenv__")));
 
   pic_leave(pic, pic->cxt->ai);
 }
@@ -62,7 +62,7 @@ pic_exit_try(pic_state *pic)
 {
   struct context *cxt = pic->cxt;
   pic_value c, it;
-  pic->dyn_env = pic_cdr(pic, pic->dyn_env);
+  pic_set(pic, "__picrin_dynenv__", pic_cdr(pic, pic_ref(pic, "__picrin_dynenv__")));
   pic_for_each (c, cxt->conts, it) {
     proc_ptr(pic, c)->env->regs[0] = pic_false_value(pic);
   }

lib/gc.c

@@ -7,85 +7,6 @@
 #include "object.h"
 #include "state.h"
 
-#define PAGE_UNITS ((PIC_HEAP_PAGE_SIZE - offsetof(struct heap_page, u)) / sizeof(union header))
-
-#define alignof(type) offsetof(struct { char c; type m; }, m)
-#define roundup(n,unit) (((n) + (unit) - 1) / (unit) * (unit))
-
-struct object {
-  union {
-    struct basic basic;
-    struct symbol sym;
-    struct string str;
-    struct blob blob;
-    struct pair pair;
-    struct vector vec;
-    struct dict dict;
-    struct attr attr;
-    struct data data;
-    struct record rec;
-    struct proc proc;
-    struct frame frame;
-    struct irep irep;
-  } u;
-};
-
-struct free_region {
-  union header *ptr;
-  size_t size;
-};
-
-union header {
-  struct free_region s;
-  char alignment[roundup(sizeof(struct free_region), alignof(struct object))];
-};
-
-struct heap_page {
-  struct heap_page *next;
-  union {
-    union header basep[1];
-    struct object alignment;
-  } u;
-};
-
-struct heap {
-  union header base, *freep;
-  struct heap_page *pages;
-  struct attr *attrs;           /* weak map chain */
-};
-
-#define unitsof(type) ((type2size(type) + sizeof(union header) - 1) / sizeof(union header))
-
-struct heap *
-pic_heap_open(pic_state *pic)
-{
-  struct heap *heap;
-
-  heap = pic_malloc(pic, sizeof(struct heap));
-
-  heap->base.s.ptr = &heap->base;
-  heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
-  heap->freep = &heap->base;
-
-  heap->pages = NULL;
-  heap->attrs = NULL;
-
-  return heap;
-}
-
-void
-pic_heap_close(pic_state *pic, struct heap *heap)
-{
-  struct heap_page *page;
-
-  while (heap->pages) {
-    page = heap->pages;
-    heap->pages = heap->pages->next;
-    pic_free(pic, page);
-  }
-  pic_free(pic, heap);
-}
-
 #if PIC_USE_LIBC
 void *
 pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size)
@@ -99,44 +20,30 @@ pic_default_allocf(void *PIC_UNUSED(userdata), void *ptr, size_t size)
 #endif
 
 void *
-pic_malloc(pic_state *pic, size_t size)
+pic_realloc(pic_state *pic, void *ptr, size_t size)
 {
-  void *ptr;
+  void *p;
 
  retry:
-  ptr = pic->allocf(pic->userdata, NULL, size);
+  p = pic->allocf(pic->userdata, ptr, size);
-  if (ptr == NULL && size > 0) {
+  if (p == NULL && size > 0) {
     pic->panicf(pic, "out of memory", 0, NULL);
     goto retry;
   }
-  return ptr;
+  return p;
 }
 
 void *
-pic_realloc(pic_state *pic, void *ptr, size_t size)
+pic_malloc(pic_state *pic, size_t size)
 {
- retry:
+  return pic_realloc(pic, NULL, size);
-  ptr = pic->allocf(pic->userdata, ptr, size);
-  if (ptr == NULL && size > 0) {
-    pic->panicf(pic, "out of memory", 0, NULL);
-    goto retry;
-  }
-  return ptr;
 }
 
 void *
 pic_calloc(pic_state *pic, size_t count, size_t size)
 {
-  void *ptr;
+  void *ptr = pic_malloc(pic, count * size);
-
+  memset(ptr, 0, count * size);
-  size *= count;
- retry:
-  ptr = pic->allocf(pic->userdata, NULL, size);
-  if (ptr == NULL && size > 0) {
-    pic->panicf(pic, "out of memory", 0, NULL);
-    goto retry;
-  }
-  memset(ptr, 0, size);
   return ptr;
 }
 
@@ -146,14 +53,16 @@ pic_free(pic_state *pic, void *ptr)
   pic->allocf(pic->userdata, ptr, 0);
 }
 
-static void
+size_t
-gc_protect(pic_state *pic, struct object *obj)
+pic_enter(pic_state *pic)
 {
-  if (pic->ai >= pic->arena_size) {
+  return pic->ai;
-    pic->arena_size = pic->arena_size * 2 + 1;
+}
-    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
+
-  }
+void
-  pic->arena[pic->ai++] = obj;
+pic_leave(pic_state *pic, size_t ai)
+{
+  pic->ai = ai;
 }
 
 pic_value
@@ -162,23 +71,14 @@ pic_protect(pic_state *pic, pic_value v)
   if (! pic_obj_p(pic, v))
     return v;
 
-  gc_protect(pic, pic_ptr(pic, v));
+  if (pic->ai >= pic->arena_size) {
-
+    pic->arena_size = pic->arena_size * 2 + 1;
+    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct object *) * pic->arena_size);
+  }
+  pic->arena[pic->ai++] = pic_ptr(pic, v);
   return v;
 }
 
-size_t
-pic_enter(pic_state *pic)
-{
-  return pic->ai;
-}
-
-void
-pic_leave(pic_state *pic, size_t state)
-{
-  pic->ai = state;
-}
-
 void *
 pic_alloca(pic_state *pic, size_t n)
 {
@@ -187,19 +87,12 @@ pic_alloca(pic_state *pic, size_t n)
   return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
 }
 
-/* MARK */
+/* GC */
 
-PIC_STATIC_INLINE bool
+#define is_alive(obj) ((obj)->tt & GC_MARK)
-is_alive(struct object *obj)
+#define mark(obj) ((obj)->tt |= GC_MARK)
-{
+#define unmark(obj) ((obj)->tt &= ~GC_MARK)
-  return obj->u.basic.tt & GC_MARK;
-}
 
-PIC_STATIC_INLINE void
-mark(struct object *obj)
-{
-  obj->u.basic.tt |= GC_MARK;
-}
 static void gc_mark_object(pic_state *, struct object *);
 
 static void
@@ -225,102 +118,195 @@ gc_mark_object(pic_state *pic, struct object *obj)
 
   switch (obj_type(obj)) {
   case PIC_TYPE_PAIR: {
-    gc_mark(pic, obj->u.pair.car);
+    struct pair *pair = (struct pair *) obj;
-    if (pic_obj_p(pic, obj->u.pair.cdr)) {
+    gc_mark(pic, pair->car);
-      LOOP(pic_ptr(pic, obj->u.pair.cdr));
+    if (pic_obj_p(pic, pair->cdr)) {
+      LOOP(pic_ptr(pic, pair->cdr));
     }
     break;
   }
   case PIC_TYPE_FRAME: {
+    struct frame *frame = (struct frame *) obj;
     int i;
-
+    for (i = 0; i < frame->regc; ++i) {
-    for (i = 0; i < obj->u.frame.regc; ++i) {
+      gc_mark(pic, frame->regs[i]);
-      gc_mark(pic, obj->u.frame.regs[i]);
     }
-    if (obj->u.frame.up) {
+    if (frame->up) {
-      LOOP(obj->u.frame.up);
+      LOOP(frame->up);
     }
     break;
   }
   case PIC_TYPE_PROC_FUNC: {
-    if (obj->u.proc.env) {
+    struct proc *proc = (struct proc *) obj;
-      LOOP(obj->u.proc.env);
+    if (proc->env) {
+      LOOP(proc->env);
     }
     break;
   }
   case PIC_TYPE_PROC_IREP: {
-    if (obj->u.proc.env) {
+    struct proc *proc = (struct proc *) obj;
-      gc_mark_object(pic, (struct object *)obj->u.proc.env);
+    if (proc->env) {
+      gc_mark_object(pic, (struct object *) proc->env);
     }
-    LOOP(obj->u.proc.u.irep);
+    LOOP(proc->u.irep);
     break;
   }
   case PIC_TYPE_IREP: {
+    struct irep *irep = (struct irep *) obj;
     size_t i;
-    for (i = 0; i < obj->u.irep.objc; ++i) {
+    for (i = 0; i < irep->objc; ++i) {
-      gc_mark(pic, obj->u.irep.obj[i]);
+      gc_mark(pic, irep->obj[i]);
     }
-    for (i = 0; i < obj->u.irep.irepc; ++i) {
+    for (i = 0; i < irep->irepc; ++i) {
-      gc_mark_object(pic, (struct object *)obj->u.irep.irep[i]);
+      gc_mark_object(pic, (struct object *) irep->irep[i]);
     }
     break;
   }
-  case PIC_TYPE_STRING: {
-    break;
-  }
   case PIC_TYPE_VECTOR: {
+    struct vector *vec = (struct vector *) obj;
     int i;
-    for (i = 0; i < obj->u.vec.len; ++i) {
+    for (i = 0; i < vec->len; ++i) {
-      gc_mark(pic, obj->u.vec.data[i]);
+      gc_mark(pic, vec->data[i]);
     }
     break;
   }
-  case PIC_TYPE_BLOB: {
-    break;
-  }
-  case PIC_TYPE_DATA: {
-    break;
-  }
   case PIC_TYPE_DICT: {
-    pic_value key, val;
+    struct dict *dict = (struct dict *) obj;
-    int it = 0;
+    khash_t(dict) *h = &dict->hash;
-
+    int it;
-    while (pic_dict_next(pic, obj_value(pic, &obj->u.dict), &it, &key, &val)) {
+    for (it = 0; it != kh_end(h); ++it) {
-      gc_mark(pic, key);
+      if (kh_exist(h, it)) {
-      gc_mark(pic, val);
+        gc_mark_object(pic, (struct object *) kh_key(h, it));
+        gc_mark(pic, kh_val(h, it));
+      }
     }
     break;
   }
   case PIC_TYPE_RECORD: {
-    gc_mark(pic, obj->u.rec.datum);
+    struct record *rec = (struct record *) obj;
-    LOOP(obj->u.rec.type);
+    gc_mark(pic, rec->datum);
+    LOOP(rec->type);
     break;
   }
   case PIC_TYPE_SYMBOL: {
-    LOOP(obj->u.sym.str);
+    struct symbol *sym = (struct symbol *) obj;
+    LOOP(sym->str);
     break;
   }
   case PIC_TYPE_ATTR: {
-    struct attr *attr = (struct attr *)obj;
+    struct attr *attr = (struct attr *) obj;
-
+    attr->prev = pic->gc_attrs;
-    attr->prev = pic->heap->attrs;
+    pic->gc_attrs = attr;
-    pic->heap->attrs = attr;
     break;
   }
+  case PIC_TYPE_STRING: {
+    struct string *str = (struct string *) obj;
+    LOOP(str->rope);
+    break;
+  }
+  case PIC_TYPE_ROPE_NODE: {
+    struct rope_node *node = (struct rope_node *) obj;
+    gc_mark_object(pic, (struct object *) node->s1);
+    LOOP(node->s2);
+    break;
+  }
+
+  case PIC_TYPE_ROPE_LEAF:
+  case PIC_TYPE_BLOB:
+  case PIC_TYPE_DATA:
+    break;
+
   default:
     PIC_UNREACHABLE();
   }
 }
 
 static void
-gc_mark_phase(pic_state *pic)
+gc_finalize_object(pic_state *pic, struct object *obj)
+{
+  switch (obj_type(obj)) {
+  case PIC_TYPE_VECTOR: {
+    struct vector *vec = (struct vector *) obj;
+    pic_free(pic, vec->data);
+    break;
+  }
+  case PIC_TYPE_BLOB: {
+    struct blob *blob = (struct blob *) obj;
+    pic_free(pic, blob->data);
+    break;
+  }
+  case PIC_TYPE_DATA: {
+    struct data *data = (struct data *) obj;
+    if (data->type->dtor) {
+      data->type->dtor(pic, data->data);
+    }
+    break;
+  }
+  case PIC_TYPE_DICT: {
+    struct dict *dict = (struct dict *) obj;
+    kh_destroy(dict, &dict->hash);
+    break;
+  }
+  case PIC_TYPE_SYMBOL: {
+    /* TODO: remove this symbol's entry from pic->syms immediately */
+    break;
+  }
+  case PIC_TYPE_ATTR: {
+    struct attr *attr = (struct attr *) obj;
+    kh_destroy(attr, &attr->hash);
+    break;
+  }
+  case PIC_TYPE_IREP: {
+    struct irep *irep = (struct irep *) obj;
+    if ((irep->flags & IREP_CODE_STATIC) == 0) {
+      pic_free(pic, (code_t *) irep->code);
+    }
+    pic_free(pic, irep->obj);
+    pic_free(pic, irep->irep);
+    break;
+  }
+  case PIC_TYPE_FRAME: {
+    struct frame *frame = (struct frame *) obj;
+    pic_free(pic, frame->regs);
+    break;
+  }
+  case PIC_TYPE_ROPE_LEAF: {
+    struct rope_leaf *leaf = (struct rope_leaf *) obj;
+    pic_free(pic, (char *) leaf->str);
+    break;
+  }
+
+  case PIC_TYPE_STRING:
+  case PIC_TYPE_ROPE_NODE:
+  case PIC_TYPE_PAIR:
+  case PIC_TYPE_RECORD:
+  case PIC_TYPE_PROC_FUNC:
+  case PIC_TYPE_PROC_IREP:
+    break;
+
+  default:
+    PIC_UNREACHABLE();
+  }
+}
+
+void
+pic_gc(pic_state *pic)
 {
   struct context *cxt;
   size_t j;
+  khash_t(oblist) *s = &pic->oblist;
+  struct symbol *sym;
+  int it;
+  struct object *obj, *prev, *next;
 
-  assert(pic->heap->attrs == NULL);
+  assert(pic->gc_attrs == NULL);
+
+  if (! pic->gc_enable) {
+    return;
+  }
+
+  /* scan objects */
 
-  /* context */
   for (cxt = pic->cxt; cxt != NULL; cxt = cxt->prev) {
     if (cxt->fp) gc_mark_object(pic, (struct object *)cxt->fp);
     if (cxt->sp) gc_mark_object(pic, (struct object *)cxt->sp);
@@ -328,21 +314,15 @@ gc_mark_phase(pic_state *pic)
     gc_mark(pic, cxt->conts);
   }
 
-  /* arena */
   for (j = 0; j < pic->ai; ++j) {
     gc_mark_object(pic, (struct object *)pic->arena[j]);
   }
 
-  /* global variables */
   gc_mark(pic, pic->globals);
-
-  /* dynamic environment */
-  gc_mark(pic, pic->dyn_env);
-
-  /* top continuation */
   gc_mark(pic, pic->halt);
 
-  /* weak maps */
+  /* scan weak references */
+
   do {
     struct object *key;
     pic_value val;
@@ -351,7 +331,7 @@ gc_mark_phase(pic_state *pic)
     struct attr *attr;
 
     j = 0;
-    attr = pic->heap->attrs;
+    attr = pic->gc_attrs;
 
     while (attr != NULL) {
       h = &attr->hash;
@@ -361,7 +341,7 @@ gc_mark_phase(pic_state *pic)
         key = kh_key(h, it);
         val = kh_val(h, it);
         if (is_alive(key)) {
-          if (pic_obj_p(pic, val) && ! is_alive(pic_ptr(pic, val))) {
+          if (pic_obj_p(pic, val) && ! is_alive((struct object *) pic_ptr(pic, val))) {
             gc_mark(pic, val);
             ++j;
           }
@@ -370,66 +350,43 @@ gc_mark_phase(pic_state *pic)
       attr = attr->prev;
     }
   } while (j > 0);
-}
 
-/* SWEEP */
+  /* reclaim dead weak references */
 
-static void
+  while (pic->gc_attrs != NULL) {
-gc_finalize_object(pic_state *pic, struct object *obj)
+    khash_t(attr) *h = &pic->gc_attrs->hash;
-{
+    for (it = kh_begin(h); it != kh_end(h); ++it) {
-  switch (obj_type(obj)) {
+      if (! kh_exist(h, it))
-  case PIC_TYPE_VECTOR: {
+        continue;
-    pic_free(pic, obj->u.vec.data);
+      obj = kh_key(h, it);
-    break;
+      if (! is_alive(obj)) {
+        kh_del(attr, h, it);
       }
-  case PIC_TYPE_BLOB: {
-    pic_free(pic, obj->u.blob.data);
-    break;
     }
-  case PIC_TYPE_STRING: {
+    pic->gc_attrs = pic->gc_attrs->prev;
-    pic_rope_decref(pic, obj->u.str.rope);
-    break;
-  }
-  case PIC_TYPE_DATA: {
-    if (obj->u.data.type->dtor) {
-      obj->u.data.type->dtor(pic, obj->u.data.data);
-    }
-    break;
-  }
-  case PIC_TYPE_DICT: {
-    kh_destroy(dict, &obj->u.dict.hash);
-    break;
-  }
-  case PIC_TYPE_SYMBOL: {
-    /* TODO: remove this symbol's entry from pic->syms immediately */
-    break;
-  }
-  case PIC_TYPE_ATTR: {
-    kh_destroy(attr, &obj->u.attr.hash);
-    break;
-  }
-  case PIC_TYPE_IREP: {
-    struct irep *irep = &obj->u.irep;
-    if ((irep->flags & IREP_CODE_STATIC) == 0) {
-      pic_free(pic, (code_t *) irep->code);
-    }
-    pic_free(pic, irep->obj);
-    pic_free(pic, irep->irep);
-    break;
-  }
-  case PIC_TYPE_FRAME: {
-    pic_free(pic, obj->u.frame.regs);
-    break;
   }
 
-  case PIC_TYPE_PAIR:
+  for (it = kh_begin(s); it != kh_end(s); ++it) {
-  case PIC_TYPE_RECORD:
+    if (! kh_exist(s, it))
-  case PIC_TYPE_PROC_FUNC:
+      continue;
-  case PIC_TYPE_PROC_IREP:
+    sym = kh_val(s, it);
-    break;
+    if (sym && ! is_alive((struct object *)sym)) {
+      kh_del(oblist, s, it);
+    }
+  }
 
-  default:
+  /* reclaim dead objects */
-    PIC_UNREACHABLE();
+
+  for (prev = &pic->gc_head, obj = prev->next; obj != &pic->gc_head; prev = obj, obj = next) {
+    next = obj->next;
+    if (is_alive(obj)) {
+      unmark(obj);
+    } else {
+      gc_finalize_object(pic, obj);
+      pic_free(pic, obj);
+      prev->next = next;
+      obj = prev;
+    }
   }
 }
 
@@ -450,218 +407,29 @@ type2size(int type)
     case PIC_TYPE_RECORD: return sizeof(struct record);
     case PIC_TYPE_PROC_FUNC: return sizeof(struct proc);
     case PIC_TYPE_PROC_IREP: return sizeof(struct proc);
+    case PIC_TYPE_ROPE_LEAF: return sizeof(struct rope_leaf);
+    case PIC_TYPE_ROPE_NODE: return sizeof(struct rope_node);
     default: PIC_UNREACHABLE();
   }
 }
 
-static struct object *
-obj_alloc(pic_state *pic, int type)
-{
-  union header *p, *prevp;
-  struct object *obj;
-  size_t nunits;
-
-  nunits = unitsof(type);
-
-  prevp = pic->heap->freep;
-  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
-    if (p->s.size >= nunits)
-      break;
-    if (p == pic->heap->freep) {
-      return NULL;
-    }
-  }
-
-  if (p->s.size == nunits) {
-    prevp->s.ptr = p->s.ptr;
-  }
-  else {
-    p->s.size -= nunits;
-    p += p->s.size;
-    p->s.size = nunits;
-  }
-  pic->heap->freep = prevp;
-
-  obj = (struct object *) p;
-  obj->u.basic.tt = type;
-  return obj;
-}
-
-static void
-free_chunk(pic_state *pic, union header *bp)
-{
-  union header *p;
-
-  assert(bp != NULL);
-
-  for (p = pic->heap->freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
-    if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
-      break;
-    }
-  }
-  if (bp + bp->s.size == p->s.ptr && p->s.ptr->s.size > 0) { /* don't melt base header */
-    bp->s.size += p->s.ptr->s.size;
-    bp->s.ptr = p->s.ptr->s.ptr;
-  } else {
-    bp->s.ptr = p->s.ptr;
-  }
-  if (p + p->s.size == bp && bp->s.size > 0) { /* don't melt base header */
-    p->s.size += bp->s.size;
-    p->s.ptr = bp->s.ptr;
-  } else {
-    p->s.ptr = bp;
-  }
-  pic->heap->freep = p;
-}
-
-static void
-heap_morecore(pic_state *pic)
-{
-  union header *bp, *np;
-  struct heap_page *page;
-
-  assert(PAGE_UNITS >= 2);
-
-  page = pic_malloc(pic, PIC_HEAP_PAGE_SIZE);
-  page->next = pic->heap->pages;
-
-  bp = page->u.basep;
-  bp->s.size = 0;      /* bp is never used for allocation */
-  free_chunk(pic, bp);
-
-  np = page->u.basep + 1;
-  np->s.size = PAGE_UNITS - 1;
-  free_chunk(pic, np);
-
-  pic->heap->pages = page;
-}
-
-static size_t
-gc_sweep_page(pic_state *pic, struct heap_page *page)
-{
-  union header *bp, *p, *head = NULL, *tail = NULL;
-  struct object *obj;
-  size_t alive = 0, nunits;
-
-  for (bp = page->u.basep; ; bp = bp->s.ptr) {
-    p = bp + (bp->s.size ? bp->s.size : 1); /* first bp's size is 0, so force advnce */
-    while (p != bp->s.ptr) {
-      if (p < page->u.basep || page->u.basep + PAGE_UNITS <= p) {
-        goto escape;
-      }
-      obj = (struct object *) p;
-      nunits = unitsof(obj_type(obj));
-      if (obj->u.basic.tt & GC_MARK) {
-        obj->u.basic.tt &= ~GC_MARK;
-        alive += nunits;
-      } else {
-        gc_finalize_object(pic, obj);
-        if (head == NULL) {
-          head = p;
-        }
-        if (tail != NULL) {
-          tail->s.ptr = p;
-        }
-        tail = p;
-        tail->s.size = nunits;
-        tail->s.ptr = NULL; /* We can safely reuse ptr field of dead object */
-      }
-      p += nunits;
-    }
-  }
- escape:
-
-  /* free! */
-  while (head != NULL) {
-    p = head;
-    head = head->s.ptr;
-    free_chunk(pic, p);
-  }
-
-  return alive;
-}
-
-static void
-gc_sweep_phase(pic_state *pic)
-{
-  struct heap_page *page;
-  int it;
-  khash_t(attr) *h;
-  khash_t(oblist) *s = &pic->oblist;
-  struct symbol *sym;
-  struct object *obj;
-  size_t total = 0, inuse = 0;
-
-  /* weak maps */
-  while (pic->heap->attrs != NULL) {
-    h = &pic->heap->attrs->hash;
-    for (it = kh_begin(h); it != kh_end(h); ++it) {
-      if (! kh_exist(h, it))
-        continue;
-      obj = kh_key(h, it);
-      if (! is_alive(obj)) {
-        kh_del(attr, h, it);
-      }
-    }
-    pic->heap->attrs = pic->heap->attrs->prev;
-  }
-
-  /* symbol table */
-  for (it = kh_begin(s); it != kh_end(s); ++it) {
-    if (! kh_exist(s, it))
-      continue;
-    sym = kh_val(s, it);
-    if (sym && ! is_alive((struct object *)sym)) {
-      kh_del(oblist, s, it);
-    }
-  }
-
-  page = pic->heap->pages;
-  while (page) {
-    inuse += gc_sweep_page(pic, page);
-    total += PAGE_UNITS;
-    page = page->next;
-  }
-
-  if (PIC_PAGE_REQUEST_THRESHOLD(total) <= inuse) {
-    heap_morecore(pic);
-  }
-}
-
-void
-pic_gc(pic_state *pic)
-{
-  if (! pic->gc_enable) {
-    return;
-  }
-
-  gc_mark_phase(pic);
-  gc_sweep_phase(pic);
-}
-
 struct object *
 pic_obj_alloc_unsafe(pic_state *pic, int type)
 {
   struct object *obj;
+  size_t size = type2size(type);
 
-  if (pic->heap->pages == NULL) {
+  if (pic->gc_count > PIC_GC_PERIOD) {
-    heap_morecore(pic);
-  }
-
-#if GC_STRESS
     pic_gc(pic);
-#endif
+    pic->gc_count -= PIC_GC_PERIOD;
+  }
 
-  obj = obj_alloc(pic, type);
+  obj = pic_malloc(pic, size);
-  if (obj == NULL) {
+  obj->tt = type;
-    pic_gc(pic);
+  obj->next = pic->gc_head.next;
-  retry:
+  pic->gc_head.next = obj;
-    obj = obj_alloc(pic, type);
+
-    if (obj == NULL) {
+  pic->gc_count += size;
-      pic->panicf(pic, "out of memory", 0, NULL);
-      goto retry;
-    }
-  }
 
   return obj;
 }
@@ -673,6 +441,6 @@ pic_obj_alloc(pic_state *pic, int type)
 
   obj = pic_obj_alloc_unsafe(pic, type);
 
-  gc_protect(pic, obj);
+  pic_protect(pic, obj_value(pic, obj));
   return obj;
 }

lib/include/picrin.h

@@ -41,7 +41,7 @@ typedef struct value {
   uint64_t v;
 #else
   union {
-    void *data;
+    void *p;
     double f;
     int i;
     char c;
@@ -135,7 +135,7 @@ pic_value pic_deserialize(pic_state *pic, pic_value blob);
 bool pic_str_p(pic_state *, pic_value);
 pic_value pic_str_value(pic_state *, const char *str, int len);
 pic_value pic_cstr_value(pic_state *, const char *str);
-#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1))
+#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, sizeof lit - 1)
 pic_value pic_strf_value(pic_state *, const char *fmt, ...);
 pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
 const char *pic_str(pic_state *, pic_value str, int *len);

lib/include/picrin/setup.h

@@ -72,12 +72,8 @@
 # define PIC_ARENA_SIZE (8 * 1024)
 #endif
 
-#ifndef PIC_HEAP_PAGE_SIZE
+#ifndef PIC_GC_PERIOD
-# define PIC_HEAP_PAGE_SIZE (4 * 1024 * 1024)
+# define PIC_GC_PERIOD (8 * 1024 * 1024)
-#endif
-
-#ifndef PIC_PAGE_REQUEST_THRESHOLD
-# define PIC_PAGE_REQUEST_THRESHOLD(total) ((total) * 77 / 100)
 #endif
 
 /* check compatibility */

lib/object.h

@@ -12,14 +12,13 @@ extern "C" {
 #include "khash.h"
 
 #define OBJECT_HEADER                           \
+  struct object *next;                          \
   unsigned char tt;
 
 #define TYPE_MASK 0x7f
 #define GC_MARK 0x80
 
-struct object;              /* defined in gc.c */
+struct object {
-
-struct basic {
   OBJECT_HEADER
 };
 
@@ -29,6 +28,25 @@ struct blob {
   int len;
 };
 
+#define ROPE_HEADER                             \
+  OBJECT_HEADER                                 \
+  int len;
+
+struct rope {
+  ROPE_HEADER
+};
+
+struct rope_leaf {
+  ROPE_HEADER
+  const char *str;
+};
+
+struct rope_node {
+  ROPE_HEADER
+  struct rope *s1;
+  struct rope *s2;
+};
+
 struct string {
   OBJECT_HEADER
   struct rope *rope;
@@ -157,7 +175,7 @@ struct proc {
 PIC_STATIC_INLINE int
 obj_type(void *ptr)
 {
-  return ((struct basic *) ptr)->tt & TYPE_MASK;
+  return ((struct object *) ptr)->tt & TYPE_MASK;
 }
 
 PIC_STATIC_INLINE pic_value
@@ -199,10 +217,6 @@ pic_value pic_make_cont(pic_state *pic, pic_value k);
 int pic_str_hash(pic_state *pic, pic_value str);
 int pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2);
 
-struct rope *pic_rope_incref(struct rope *);
-void pic_rope_decref(pic_state *, struct rope *);
-
-
 void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
 
 #if defined(__cplusplus)

lib/state.c

@@ -13,12 +13,9 @@ static pic_value pic_state_features(pic_state *);
 void
 pic_add_feature(pic_state *pic, const char *feature)
 {
-  pic_value f = pic_ref(pic, "features");
+  pic_value f = pic_ref(pic, "__picrin_features__");
 
-  if (! (pic_proc_func_p(pic, f) && proc_ptr(pic, f)->u.func == pic_state_features)) {
+  pic_set(pic, "__picrin_features__", pic_cons(pic, pic_intern_cstr(pic, feature), f));
-    pic_error(pic, "the features procedure is overwritten", 0);
-  }
-  pic_push(pic, pic_intern_cstr(pic, feature), proc_ptr(pic, f)->env->regs[0]);
 }
 
 void pic_init_bool(pic_state *);
@@ -50,9 +47,11 @@ pic_init_core(pic_state *pic)
 {
   size_t ai = pic_enter(pic);
 
+  pic_define(pic, "__picrin_features__", pic_nil_value(pic));
+  pic_define(pic, "__picrin_dynenv__", pic_list(pic, 1, pic_make_attr(pic)));
+
   pic_init_bool(pic); DONE;
   pic_init_pair(pic); DONE;
-  pic_init_port(pic); DONE;
   pic_init_number(pic); DONE;
   pic_init_proc(pic); DONE;
   pic_init_symbol(pic); DONE;
@@ -69,6 +68,9 @@ pic_init_core(pic_state *pic)
 #if PIC_USE_CONT
   pic_init_cont(pic); DONE;
 #endif
+#if PIC_USE_PORT
+  pic_init_port(pic); DONE;
+#endif
 #if PIC_USE_READ
   pic_init_read(pic); DONE;
 #endif
@@ -128,8 +130,10 @@ pic_open(pic_allocf allocf, void *userdata, pic_panicf panicf)
   /* turn off GC */
   pic->gc_enable = false;
 
-  /* memory heap */
+  /* gc */
-  pic->heap = pic_heap_open(pic);
+  pic->gc_head.next = (struct object *) &pic->gc_head;
+  pic->gc_attrs = NULL;
+  pic->gc_count = 0;
 
   /* symbol table */
   kh_init(oblist, &pic->oblist);
@@ -137,9 +141,6 @@ pic_open(pic_allocf allocf, void *userdata, pic_panicf panicf)
   /* global variables */
   pic->globals = pic_make_dict(pic);
 
-  /* dynamic environment */
-  pic->dyn_env = pic_list(pic, 1, pic_make_attr(pic));
-
   /* top continuation */
   {
     static const code_t halt_code[] = { 0x00 };
@@ -161,9 +162,6 @@ pic_open(pic_allocf allocf, void *userdata, pic_panicf panicf)
     pic->halt = obj_value(pic, proc);
   }
 
-  /* panic handler */
-  pic->panicf = NULL;
-
   /* turn on GC */
   pic->gc_enable = true;
 
@@ -189,7 +187,6 @@ pic_close(pic_state *pic)
   pic->ai = 0;
   pic->halt = pic_invalid_value(pic);
   pic->globals = pic_invalid_value(pic);
-  pic->dyn_env = pic_invalid_value(pic);
 
   assert(pic->cxt->ai == 0);
   assert(pic->cxt->pc == NULL);
@@ -201,8 +198,7 @@ pic_close(pic_state *pic)
   /* free all heap objects */
   pic_gc(pic);
 
-  /* free heaps */
+  assert(pic->gc_head.next == (struct object *) &pic->gc_head);
-  pic_heap_close(pic, pic->heap);
 
   /* free global stacks */
   kh_destroy(oblist, &pic->oblist);
@@ -342,7 +338,7 @@ pic_state_features(pic_state *pic)
 {
   pic_get_args(pic, "");
 
-  return pic_closure_ref(pic, 0);
+  return pic_ref(pic, "__picrin_features__");
 }
 
 static pic_value
@@ -369,10 +365,6 @@ pic_state_error(pic_state *pic)
 void
 pic_init_state(pic_state *pic)
 {
-  pic_define(pic, "features", pic_lambda(pic, pic_state_features, 1, pic_nil_value(pic)));
-  pic_defun(pic, "global-objects", pic_state_global_objects);
-  pic_defun(pic, "error", pic_state_error);
-
   pic_add_feature(pic, "picrin");
 
 #if __STDC_IEC_559__
@@ -426,4 +418,8 @@ pic_init_state(pic_state *pic)
   pic_add_feature(pic, "big-endian");
 # endif
 #endif
+
+  pic_defun(pic, "features", pic_state_features);
+  pic_defun(pic, "global-objects", pic_state_global_objects);
+  pic_defun(pic, "error", pic_state_error);
 }

lib/state.h

@@ -36,26 +36,24 @@ struct pic_state {
   void *userdata;
 
   struct context *cxt, default_cxt;
-
   size_t ai;
-  pic_value dyn_env;
 
   khash_t(oblist) oblist;       /* string to symbol */
   pic_value globals;            /* dict */
 
-  bool gc_enable;
-  struct heap *heap;
   struct object **arena;
   size_t arena_size;
 
+  bool gc_enable;
+  struct object gc_head;
+  struct attr *gc_attrs;
+  size_t gc_count;
+
   pic_value halt;               /* top continuation */
 
   pic_panicf panicf;
 };
 
-struct heap *pic_heap_open(pic_state *);
-void pic_heap_close(pic_state *, struct heap *);
-
 pic_value pic_global_ref(pic_state *pic, pic_value uid);
 void pic_global_set(pic_state *pic, pic_value uid, pic_value value);
 

lib/string.c

@@ -6,212 +6,26 @@
 #include "value.h"
 #include "object.h"
 
-struct rope {
-  int refcnt;
-  int weight;
-  bool isleaf;
-  union {
-    struct {
-      struct rope *owner;
-      const char *str;          /* always points to zero-term'd buf */
-    } leaf;
-    struct {
-      struct rope *left, *right;
-    } node;
-  } u;
-  char buf[1];
-};
-
-struct rope *
-pic_rope_incref(struct rope *rope) {
-  rope->refcnt++;
-  return rope;
-}
-
-void
-pic_rope_decref(pic_state *pic, struct rope *rope) {
-  if (! --rope->refcnt) {
-    if (rope->isleaf) {
-      if (rope->u.leaf.owner) {
-        pic_rope_decref(pic, rope->u.leaf.owner);
-      }
-    } else {
-      pic_rope_decref(pic, rope->u.node.left);
-      pic_rope_decref(pic, rope->u.node.right);
-    }
-    pic_free(pic, rope);
-  }
-}
-
-static struct rope *
-make_rope_leaf(pic_state *pic, const char *str, int len)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf) + len + 1);
-  rope->refcnt = 1;
-  rope->weight = len;
-  rope->isleaf = true;
-  rope->u.leaf.owner = NULL;
-  rope->u.leaf.str = rope->buf;
-  rope->buf[len] = 0;
-  if (str) {
-    memcpy(rope->buf, str, len);
-  }
-
-  return rope;
-}
-
-static struct rope *
-make_rope_lit(pic_state *pic, const char *str, int len)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf));
-  rope->refcnt = 1;
-  rope->weight = len;
-  rope->isleaf = true;
-  rope->u.leaf.owner = NULL;
-  rope->u.leaf.str = str;
-
-  return rope;
-}
-
-static struct rope *
-make_rope_slice(pic_state *pic, struct rope *owner, int i, int j)
-{
-  struct rope *rope, *real_owner;
-
-  assert(owner->isleaf);
-
-  real_owner = owner->u.leaf.owner == NULL ? owner : owner->u.leaf.owner;
-
-  rope = pic_malloc(pic, offsetof(struct rope, buf));
-  rope->refcnt = 1;
-  rope->weight = j - i;
-  rope->isleaf = true;
-  rope->u.leaf.owner = real_owner;
-  rope->u.leaf.str = owner->u.leaf.str + i;
-
-  pic_rope_incref(real_owner);
-
-  return rope;
-}
-
-static struct rope *
-make_rope_node(pic_state *pic, struct rope *left, struct rope *right)
-{
-  struct rope *rope;
-
-  rope = pic_malloc(pic, sizeof(struct rope));
-  rope->refcnt = 1;
-  rope->weight = left->weight + right->weight;
-  rope->isleaf = false;
-  rope->u.node.left = pic_rope_incref(left);
-  rope->u.node.right = pic_rope_incref(right);
-
-  return rope;
-}
-
-static pic_value
-make_str(pic_state *pic, struct rope *rope)
-{
-  struct string *str;
-
-  str = (struct string *)pic_obj_alloc(pic, PIC_TYPE_STRING);
-  str->rope = rope;             /* delegate ownership */
-
-  return obj_value(pic, str);
-}
-
-static struct rope *
-merge(pic_state *pic, struct rope *left, struct rope *right)
-{
-  if (left == 0)
-    return pic_rope_incref(right);
-  if (right == 0)
-    return pic_rope_incref(left);
-
-  return make_rope_node(pic, left, right);
-}
-
-static struct rope *
-slice(pic_state *pic, struct rope *rope, int i, int j)
-{
-  int lweight;
-
-  if (i == 0 && rope->weight == j) {
-    return pic_rope_incref(rope);
-  }
-
-  if (rope->isleaf) {
-    return make_rope_slice(pic, rope, i, j);
-  }
-
-  lweight = rope->u.node.left->weight;
-
-  if (j <= lweight) {
-    return slice(pic, rope->u.node.left, i, j);
-  } else if (lweight <= i) {
-    return slice(pic, rope->u.node.right, i - lweight, j - lweight);
-  } else {
-    struct rope *r, *l;
-
-    l = slice(pic, rope->u.node.left, i, lweight);
-    r = slice(pic, rope->u.node.right, 0, j - lweight);
-    rope = merge(pic, l, r);
-
-    pic_rope_decref(pic, l);
-    pic_rope_decref(pic, r);
-
-    return rope;
-  }
-}
-
-static void
-flatten(pic_state *pic, struct rope *rope, struct rope *owner, char *buf)
-{
-  if (rope->isleaf) {
-    memcpy(buf, rope->u.leaf.str, rope->weight);
-  } else {
-    flatten(pic, rope->u.node.left, owner, buf);
-    flatten(pic, rope->u.node.right, owner, buf + rope->u.node.left->weight);
-  }
-
-  /* path compression */
-
-  if (! rope->isleaf) {
-    pic_rope_incref(owner);
-    pic_rope_decref(pic, rope->u.node.left);
-    pic_rope_decref(pic, rope->u.node.right);
-    rope->isleaf = true;
-    rope->u.leaf.owner = owner;
-    rope->u.leaf.str = buf;
-  }
-}
-
-static void
-str_update(pic_state *pic, pic_value dst, pic_value src)
-{
-  pic_rope_incref(str_ptr(pic, src)->rope);
-  pic_rope_decref(pic, str_ptr(pic, dst)->rope);
-  str_ptr(pic, dst)->rope = str_ptr(pic, src)->rope;
-}
-
 pic_value
 pic_str_value(pic_state *pic, const char *str, int len)
 {
-  struct rope *r;
+  char *buf;
+  struct rope_leaf *leaf;
+  struct string *s;
 
-  if (len > 0) {
+  assert(str != NULL);
-    r = make_rope_leaf(pic, str, len);
+
-  } else {
+  buf = pic_malloc(pic, len + 1);
-    if (len == 0) {
+  buf[len] = 0;
-      str = "";
+  memcpy(buf, str, len);
-    }
+
-    r = make_rope_lit(pic, str, -len);
+  leaf = (struct rope_leaf *) pic_obj_alloc(pic, PIC_TYPE_ROPE_LEAF);
-  }
+  leaf->len = len;
-  return make_str(pic, r);
+  leaf->str = buf;
+
+  s = (struct string *) pic_obj_alloc(pic, PIC_TYPE_STRING);
+  s->rope = (struct rope *) leaf;
+  return obj_value(pic, s);
 }
 
 pic_value
@@ -273,12 +87,12 @@ pic_vstrf_value(pic_state *pic, const char *fmt, va_list ap)
   }
   case 'p': {
     static const char digits[] = "0123456789abcdef";
-    static const size_t bufsiz = sizeof(long) * CHAR_BIT / 4;
+#define MAXLEN (sizeof(long) * CHAR_BIT / 4)
     unsigned long vp = (unsigned long) va_arg(ap, void*);
-    char buf[2 + bufsiz + 1] = "0x", *p = buf + 2;
+    char buf[2 + MAXLEN + 1] = "0x", *p = buf + 2;
     size_t i;
-    for (i = 0; i < bufsiz; ++i) {
+    for (i = 0; i < MAXLEN; ++i) {
-      p[bufsiz - i - 2] = digits[vp % 16];
+      p[MAXLEN - i - 2] = digits[vp % 16];
       vp /= 16;
     }
     p[i] = '\0';
@@ -295,19 +109,58 @@ pic_vstrf_value(pic_state *pic, const char *fmt, va_list ap)
 int
 pic_str_len(pic_state *pic, pic_value str)
 {
-  return str_ptr(pic, str)->rope->weight;
+  return str_ptr(pic, str)->rope->len;
 }
 
 pic_value
 pic_str_cat(pic_state *pic, pic_value a, pic_value b)
 {
-  return make_str(pic, merge(pic, str_ptr(pic, a)->rope, str_ptr(pic, b)->rope));
+  struct rope *s1 = str_ptr(pic, a)->rope, *s2 = str_ptr(pic, b)->rope;
+  struct rope_node *node;
+  struct string *s;
+
+  node = (struct rope_node *) pic_obj_alloc(pic, PIC_TYPE_ROPE_NODE);
+  node->len = s1->len + s2->len;
+  node->s1 = s1;
+  node->s2 = s2;
+
+  s = (struct string *) pic_obj_alloc(pic, PIC_TYPE_STRING);
+  s->rope = (struct rope *) node;
+  return obj_value(pic, s);
+}
+
+static pic_value
+str_sub(pic_state *pic, struct rope *rope, int i, int j)
+{
+  int lweight;
+  pic_value s1, s2;
+
+  if (i == 0 && rope->len == j) {
+    return obj_value(pic, rope);
+  }
+
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
+    return pic_str_value(pic, ((struct rope_leaf *) rope)->str + i, j - i);
+  }
+
+  lweight = ((struct rope_node *) rope)->s1->len;
+
+  if (j <= lweight) {
+    return str_sub(pic, ((struct rope_node *) rope)->s1, i, j);
+  }
+  if (lweight <= i) {
+    return str_sub(pic, ((struct rope_node *) rope)->s2, i - lweight, j - lweight);
+  }
+
+  s1 = str_sub(pic, ((struct rope_node *) rope)->s1, i, lweight);
+  s2 = str_sub(pic, ((struct rope_node *) rope)->s2, 0, j - lweight);
+  return pic_str_cat(pic, s1, s2);
 }
 
 pic_value
 pic_str_sub(pic_state *pic, pic_value str, int s, int e)
 {
-  return make_str(pic, slice(pic, str_ptr(pic, str)->rope, s, e));
+  return str_sub(pic, str_ptr(pic, str)->rope, s, e);
 }
 
 int
@@ -342,24 +195,45 @@ pic_str_cmp(pic_state *pic, pic_value str1, pic_value str2)
   return len1 - len2;
 }
 
+static void
+str_cstr(pic_state *pic, struct rope *rope, char *buf)
+{
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
+    memcpy(buf, ((struct rope_leaf *) rope)->str, rope->len);
+  } else {
+    struct rope_node *r = (struct rope_node *) rope;
+    str_cstr(pic, r->s1, buf);
+    str_cstr(pic, r->s2, buf + r->s1->len);
+  }
+}
+
 const char *
 pic_str(pic_state *pic, pic_value str, int *len)
 {
-  struct rope *rope = str_ptr(pic, str)->rope, *r;
+  struct rope *rope = str_ptr(pic, str)->rope;
+  char *buf;
+  struct rope_leaf *leaf;
 
   if (len) {
-    *len = rope->weight;
+    *len = rope->len;
   }
 
-  if (rope->isleaf && rope->u.leaf.str[rope->weight] == '\0') {
+  if (obj_type(rope) == PIC_TYPE_ROPE_LEAF) {
-    return rope->u.leaf.str;
+    return ((struct rope_leaf *) rope)->str;
   }
 
-  r = make_rope_leaf(pic, 0, rope->weight);
+  buf = pic_malloc(pic, rope->len + 1);
+  buf[rope->len] = 0;
+  str_cstr(pic, rope, buf);
 
-  flatten(pic, rope, r, r->buf);
+  leaf = (struct rope_leaf *) pic_obj_alloc(pic, PIC_TYPE_ROPE_LEAF);
+  leaf->len = rope->len;
+  leaf->str = buf;
 
-  return r->u.leaf.str;
+  /* cache the result */
+  str_ptr(pic, str)->rope = (struct rope *) leaf;
+
+  return buf;
 }
 
 const char *
@@ -453,7 +327,7 @@ pic_str_string_ref(pic_state *pic)
 static pic_value
 pic_str_string_set(pic_state *pic)
 {
-  pic_value str, x, y, z;
+  pic_value str, x, y, z, w;
   char c;
   int k, len;
 
@@ -466,8 +340,9 @@ pic_str_string_set(pic_state *pic)
   x = pic_str_sub(pic, str, 0, k);
   y = pic_str_value(pic, &c, 1);
   z = pic_str_sub(pic, str, k + 1, len);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, str)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }
@@ -527,7 +402,7 @@ pic_str_string_copy(pic_state *pic)
 static pic_value
 pic_str_string_copy_ip(pic_state *pic)
 {
-  pic_value to, from, x, y, z;
+  pic_value to, from, x, y, z, w;
   int n, at, start, end, tolen, fromlen;
 
   n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);
@@ -547,8 +422,9 @@ pic_str_string_copy_ip(pic_state *pic)
   x = pic_str_sub(pic, to, 0, at);
   y = pic_str_sub(pic, from, start, end);
   z = pic_str_sub(pic, to, at + end - start, tolen);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, to, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, to)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }
@@ -556,7 +432,7 @@ pic_str_string_copy_ip(pic_state *pic)
 static pic_value
 pic_str_string_fill_ip(pic_state *pic)
 {
-  pic_value str, x, y, z;
+  pic_value str, x, y, z, w;
   char c, *buf;
   int n, start, end, len;
 
@@ -579,8 +455,9 @@ pic_str_string_fill_ip(pic_state *pic)
   x = pic_str_sub(pic, str, 0, start);
   y = pic_str_value(pic, buf, end - start);
   z = pic_str_sub(pic, str, end, len);
+  w = pic_str_cat(pic, x, pic_str_cat(pic, y, z));
 
-  str_update(pic, str, pic_str_cat(pic, x, pic_str_cat(pic, y, z)));
+  str_ptr(pic, str)->rope = str_ptr(pic, w)->rope;
 
   return pic_undef_value(pic);
 }

lib/value.h

@@ -30,10 +30,12 @@ enum {
   PIC_TYPE_DICT      = 22,
   PIC_TYPE_RECORD    = 23,
   PIC_TYPE_ATTR      = 24,
-  PIC_TYPE_IREP      = 27,
+  PIC_TYPE_IREP      = 25,
-  PIC_TYPE_FRAME     = 28,
+  PIC_TYPE_FRAME     = 26,
-  PIC_TYPE_PROC_FUNC = 29,
+  PIC_TYPE_PROC_FUNC = 27,
-  PIC_TYPE_PROC_IREP = 30,
+  PIC_TYPE_PROC_IREP = 28,
+  PIC_TYPE_ROPE_LEAF = 29,
+  PIC_TYPE_ROPE_NODE = 30,
   PIC_TYPE_MAX       = 63
 };
 
@@ -42,7 +44,7 @@ enum {
 PIC_STATIC_INLINE void
 make_value(struct value *v, int type)
 {
-  static const struct value zero = { 0 };
+  static const struct value zero = { {0}, 0 };
   *v = zero;
   v->type = type;
 }
@@ -61,7 +63,7 @@ make_float_value(struct value *v, double f)
   v->u.f = f;
 }
 
-PIC_STATIC_INLINE struct value
+PIC_STATIC_INLINE void
 make_char_value(struct value *v, char c)
 {
   make_value(v, PIC_TYPE_CHAR);

lib/var.c

@@ -20,7 +20,7 @@ var_call(pic_state *pic)
   if (n == 0) {
     pic_value env, it;
 
-    pic_for_each(env, pic->dyn_env, it) {
+    pic_for_each(env, pic_ref(pic, "__picrin_dynenv__"), it) {
       if (pic_attr_has(pic, env, self)) {
         return pic_attr_ref(pic, env, self);
       }
@@ -33,7 +33,7 @@ var_call(pic_state *pic)
     if (! pic_false_p(pic, conv)) {
       val = pic_call(pic, conv, 1, val);
     }
-    pic_attr_set(pic, pic_car(pic, pic->dyn_env), self, val);
+    pic_attr_set(pic, pic_car(pic, pic_ref(pic, "__picrin_dynenv__")), self, val);
     return pic_undef_value(pic);
   }
 }
@@ -41,7 +41,7 @@ var_call(pic_state *pic)
 pic_value
 pic_make_var(pic_state *pic, pic_value init, pic_value conv)
 {
-  pic_value var, env = pic->dyn_env;
+  pic_value var, env = pic_ref(pic, "__picrin_dynenv__");
 
   var = pic_lambda(pic, var_call, 1, conv);
   while (1) {
@@ -76,9 +76,9 @@ pic_var_current_dynamic_environment(pic_state *pic)
   n = pic_get_args(pic, "|o", &dyn_env);
 
   if (n == 0) {
-    return pic->dyn_env;
+    return pic_ref(pic, "__picrin_dynenv__");
   } else {
-    pic->dyn_env = dyn_env;
+    pic_set(pic, "__picrin_dynenv__", dyn_env);
     return pic_undef_value(pic);
   }
 }