Merge branch 'simple-beta-reduction'

extlib/benz/codegen.c

@@ -295,9 +295,75 @@ pic_expand(pic_state *pic, pic_value expr, struct pic_env *env)
   return v;
 }
 
+static pic_value
+optimize_beta(pic_state *pic, pic_value expr)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+  pic_value functor, formals, args, tmp, val, it, defs;
+
+  if (! pic_list_p(expr))
+    return expr;
+
+  if (pic_nil_p(expr))
+    return expr;
+
+  if (pic_sym_p(pic_list_ref(pic, expr, 0))) {
+    pic_sym *sym = pic_sym_ptr(pic_list_ref(pic, expr, 0));
+
+    if (sym == pic->uQUOTE) {
+      return expr;
+    } else if (sym == pic->uLAMBDA) {
+      return pic_list3(pic, pic_list_ref(pic, expr, 0), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
+    }
+  }
+
+  tmp = pic_nil_value();
+  pic_for_each (val, expr, it) {
+    pic_push(pic, optimize_beta(pic, val), tmp);
+  }
+  expr = pic_reverse(pic, tmp);
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, expr);
+
+  functor = pic_list_ref(pic, expr, 0);
+  if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->uLAMBDA))) {
+    formals = pic_list_ref(pic, functor, 1);
+    if (! pic_list_p(formals))
+      goto exit;              /* TODO: support ((lambda args x) 1 2) */
+    args = pic_cdr(pic, expr);
+    if (pic_length(pic, formals) != pic_length(pic, args))
+      goto exit;
+    defs = pic_nil_value();
+    pic_for_each (val, args, it) {
+      pic_push(pic, pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_car(pic, formals), val), defs);
+      formals = pic_cdr(pic, formals);
+    }
+    expr = pic_list_ref(pic, functor, 2);
+    pic_for_each (val, defs, it) {
+      expr = pic_list3(pic, pic_obj_value(pic->uBEGIN), val, expr);
+    }
+  }
+ exit:
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, expr);
+  return expr;
+}
+
+pic_value
+pic_optimize(pic_state *pic, pic_value expr)
+{
+  return optimize_beta(pic, expr);
+}
+
 KHASH_DECLARE(a, pic_sym *, int)
 KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
 
+/**
+ * TODO: don't use khash_t, use kvec_t instead
+ */
+
 typedef struct analyze_scope {
   int depth;
   pic_sym *rest;                     /* Nullable */
@@ -456,8 +522,14 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
   }
 
   locals = pic_make_vec(pic, kh_size(&scope->locals));
-  for (it = kh_begin(&scope->locals), j = 0; it < kh_end(&scope->locals); ++it) {
+  j = 0;
+  if (scope->rest != NULL) {
+    locals->data[j++] = pic_obj_value(scope->rest);
+  }
+  for (it = kh_begin(&scope->locals); it < kh_end(&scope->locals); ++it) {
     if (kh_exist(&scope->locals, it)) {
+      if (scope->rest != NULL && kh_key(&scope->locals, it) == scope->rest)
+        continue;
       locals->data[j++] = pic_obj_value(kh_key(&scope->locals, it));
     }
   }
@@ -1045,6 +1117,17 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
 
   SAVE(pic, ai, obj);
 
+  /* optimize */
+  obj = pic_optimize(pic, obj);
+#if DEBUG
+  fprintf(stdout, "## optimize completed\n");
+  pic_write(pic, obj);
+  fprintf(stdout, "\n");
+  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
+#endif
+
+  SAVE(pic, ai, obj);
+
   /* analyze */
   obj = pic_analyze(pic, obj);
 #if DEBUG

extlib/benz/include/picrin/opcode.h

@@ -60,7 +60,6 @@ enum pic_opcode {
 PIC_INLINE void
 pic_dump_code(pic_code c)
 {
-  printf("[%2d] ", c.insn);
   switch (c.insn) {
   case OP_NOP:
     puts("OP_NOP");
@@ -187,7 +186,7 @@ pic_dump_irep(struct pic_irep *irep)
   printf("## irep %p\n", (void *)irep);
   printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec);
   for (i = 0; i < irep->clen; ++i) {
-    printf("%02x ", i);
+    printf("%02x: ", i);
     pic_dump_code(irep->code[i]);
   }
 

extlib/benz/include/picrin/pair.h

@@ -24,7 +24,7 @@ pic_car(pic_state *pic, pic_value obj)
   struct pic_pair *pair;
 
   if (! pic_pair_p(obj)) {
-    pic_errorf(pic, "pair required, but got ~s", obj);
+    pic_errorf(pic, "car: pair required, but got ~s", obj);
   }
   pair = pic_pair_ptr(obj);
 
@@ -37,7 +37,7 @@ pic_cdr(pic_state *pic, pic_value obj)
   struct pic_pair *pair;
 
   if (! pic_pair_p(obj)) {
-    pic_errorf(pic, "pair required, but got ~s", obj);
+    pic_errorf(pic, "cdr: pair required, but got ~s", obj);
   }
   pair = pic_pair_ptr(obj);