merge

eval.c

@@ -148,8 +148,10 @@ static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
   sexp_gc_preserve1(ctx, res);
   for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
     sexp_push(ctx, res, sexp_car(ls));
+  if (!sexp_nullp(ls))
+    res = sexp_cons(ctx, ls, res);
   sexp_gc_release1(ctx);
-  return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res));
+  return res;
 }
 
 static sexp sexp_flatten_dot (sexp ctx, sexp ls) {
@@ -392,15 +394,15 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) {
 
 /**************************** identifiers *****************************/
 
-static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) {
+sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) {
   return sexp_make_boolean(sexp_idp(x));
 }
 
-static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) {
+sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) {
   return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
 }
 
-static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
+sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
   sexp res;
   sexp_gc_var2(kar, kdr);
   sexp_gc_preserve2(ctx, kar, kdr);
@@ -420,7 +422,7 @@ static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
   return res;
 }
 
-static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) {
+sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) {
   sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE;
   if (sexp_synclop(id1)) {
     e1 = sexp_synclo_env(id1);
@@ -906,7 +908,7 @@ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn)
   return sexp_exception_kind(exn);
 }
 
-static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
+sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
   FILE *in;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
   in = fopen(sexp_string_data(path), "r");
@@ -915,7 +917,7 @@ static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp pat
   return sexp_make_input_port(ctx, in, path);
 }
 
-static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
+sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) {
   FILE *out;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path);
   out = fopen(sexp_string_data(path), "w");
@@ -924,7 +926,7 @@ static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp pa
   return sexp_make_output_port(ctx, out, path);
 }
 
-static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) {
+sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) {
   sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port);
   if (! sexp_port_openp(port))
     return sexp_user_exception(ctx, self, "port already closed", port);
@@ -1423,15 +1425,14 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
 
 sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
                               int flags, sexp_proc1 f, sexp data) {
-  sexp res = SEXP_VOID;
+  sexp_gc_var2(op, res);
-  sexp_gc_var1(op);
+  sexp_gc_preserve2(ctx, op, res);
-  sexp_gc_preserve1(ctx, op);
   op = sexp_make_foreign(ctx, name, num_args, flags, f, data);
   if (sexp_exceptionp(op))
     res = op;
   else
-    sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op);
+    sexp_env_define(ctx, env, res = sexp_intern(ctx, name, -1), op);
-  sexp_gc_release1(ctx);
+  sexp_gc_release2(ctx);
   return res;
 }
 
@@ -1477,11 +1478,14 @@ sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) {
 
 sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) {
   sexp_uint_t i;
-  sexp e = sexp_make_env(ctx), core;
+  sexp_gc_var2(e, core);
+  sexp_gc_preserve2(ctx, e, core);
+  e = sexp_make_env(ctx);
   for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) {
     core = sexp_copy_core(ctx, &core_forms[i]);
     sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core);
   }
+  sexp_gc_release2(ctx);
   return e;
 }
 
@@ -1652,7 +1656,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
   sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1));
 #endif
   sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1));
-  sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp);
+  sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp);
   sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
 #if SEXP_USE_SIMPLIFY
   op = sexp_make_foreign(ctx, "simplify", 1, 0,
@@ -1699,7 +1703,9 @@ sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version)
 }
 
 sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) {
-  sexp oldname, newname, value;
+  sexp oldname, newname;
+  sexp_gc_var1(value);
+  sexp_gc_preserve1(ctx, value);
   if (! sexp_envp(to)) to = sexp_context_env(ctx);
   if (! sexp_envp(from)) from = sexp_context_env(ctx);
   if (sexp_not(ls)) {
@@ -1730,6 +1736,7 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se
       }
     }
   }
+  sexp_gc_release1(ctx);
   return SEXP_VOID;
 }
 

gc.c

@@ -48,10 +48,6 @@ static int sexp_in_heap(sexp ctx, sexp_uint_t x) {
 }
 #endif
 
-#if SEXP_USE_DEBUG_GC
-#include "opt/gc_debug.c"
-#endif
-
 void sexp_mark (sexp ctx, sexp x) {
   sexp_sint_t i, len;
   sexp t, *p;

include/chibi/eval.h

@@ -153,9 +153,15 @@ SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
 SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file);
 SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
 SEXP_API sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp);
-SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
+SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value);
-SEXP_API sexp sexp_env_copy_op (sexp context sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp);
+SEXP_API sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp);
-SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_identifier_op(sexp ctx sexp_api_params(self, n), sexp x);
+SEXP_API sexp sexp_syntactic_closure_expr(sexp ctx sexp_api_params(self, n), sexp x);
+SEXP_API sexp sexp_identifier_eq_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp c, sexp d);
+SEXP_API sexp sexp_open_input_file_op(sexp ctx sexp_api_params(self, n), sexp x);
+SEXP_API sexp sexp_open_output_file_op(sexp ctx sexp_api_params(self, n), sexp x);
+SEXP_API sexp sexp_close_port_op(sexp ctx sexp_api_params(self, n), sexp x);
+SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
 SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
 SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
 SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
@@ -191,7 +197,7 @@ SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name,
 #define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e)
 #define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e)
 #define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
-#define sexp_identifierp(ctx, x) sexp_identifier_op(ctx sexp_api_pass(NULL, 1), x)
+#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx sexp_api_pass(NULL, 1), x)
 #define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x)
 #define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
 #define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx sexp_api_pass(NULL, 1), x)

tools/genstatic.scm

@@ -121,7 +121,7 @@
 (define (init-c-lib lib)
   (display "  ")
   (display (cdr lib))
-  (display "(ctx, env);\n"))
+  (display "(ctx sexp_api_pass(NULL, 1), env);\n"))
 
 (define (main args)
   (find-c-libs (if (pair? (cdr args)) (cadr args) "lib"))

vm.c

@@ -149,10 +149,11 @@ static void generate_ref (sexp ctx, sexp ref, int unboxp) {
   if (! sexp_lambdap(sexp_ref_loc(ref))) {
     /* global ref */
     if (unboxp) {
-      emit(ctx,
+      emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
-           (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
                  ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
       emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
+      sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
+                sexp_ref_cell(ref));
     } else
       emit_push(ctx, sexp_ref_cell(ref));
   } else {
@@ -211,13 +212,13 @@ static void generate_opcode_app (sexp ctx, sexp app) {
           emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
 #else
           emit_push(ctx, sexp_opcode_data(op));
+          sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
+                    sexp_opcode_data(op));
 #endif
           emit(ctx, SEXP_OP_CDR);
         } else {
           emit_push(ctx, sexp_opcode_data(op));
         }
-        sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)),
-                  sexp_opcode_data(op));
         sexp_context_depth(ctx)++;
         num_args++;
       }
@@ -270,6 +271,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
   case SEXP_OPC_FOREIGN:
     emit(ctx, sexp_opcode_code(op));
     emit_word(ctx, (sexp_uint_t)op);
+    sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op);
     break;
   case SEXP_OPC_TYPE_PREDICATE:
   case SEXP_OPC_GETTER:
@@ -282,6 +284,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
         emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
       if (sexp_opcode_data2(op))
         emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
+      sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op);
     }
     break;
   case SEXP_OPC_PARAMETER:
@@ -435,8 +438,8 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) {
 }
 
 static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
-  sexp ls, bc, res, env;
+  sexp ls, res, env;
-  sexp_gc_var5(params, ref, refs, lambda, ctx2);
+  sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
   if (i == sexp_opcode_num_args(op)) { /* return before preserving */
     if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
   } else if (i < sexp_opcode_num_args(op)) {
@@ -444,7 +447,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
   } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
     return sexp_compile_error(ctx, "too many args for opcode", op);
   }
-  sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2);
+  sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
   params = make_param_list(ctx, i);
   lambda = sexp_make_lambda(ctx, params);
   ctx2 = sexp_make_child_context(ctx, lambda);
@@ -462,7 +465,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
   res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
   if (i == sexp_opcode_num_args(op))
     sexp_opcode_proc(op) = res;
-  sexp_gc_release5(ctx);
+  sexp_gc_release6(ctx);
   return res;
 }
 
@@ -987,14 +990,14 @@ sexp sexp_vm (sexp ctx, sexp proc) {
   case SEXP_OP_SLOT_REF:
     _ALIGN_IP();
     if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
-      sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
+      sexp_raise("slot-ref: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
     _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
     ip += sizeof(sexp)*2;
     break;
   case SEXP_OP_SLOT_SET:
     _ALIGN_IP();
     if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
-      sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
+      sexp_raise("slot-set!: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
     else if (sexp_immutablep(_ARG1))
       sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
     sexp_slot_set(_ARG1, _UWORD1, _ARG2);
@@ -1401,7 +1404,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
       _ARG1 = sexp_make_character(i);
     break;
   case SEXP_OP_YIELD:
+#if SEXP_USE_GREEN_THREADS
     fuel = 0;
+#endif
     _PUSH(SEXP_VOID);
     break;
   case SEXP_OP_RET:
@@ -1457,9 +1462,11 @@ sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
 sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
   sexp_sint_t top = sexp_context_top(ctx), len, offset;
+  sexp_gc_var1(tmp);
+  sexp_gc_preserve1(ctx, tmp);
   len = sexp_unbox_fixnum(sexp_length(ctx, args));
   if (sexp_opcodep(proc))
-    proc = make_opcode_procedure(ctx, proc, len);
+    proc = tmp = make_opcode_procedure(ctx, proc, len);
   if (! sexp_procedurep(proc)) {
     res = sexp_exceptionp(proc) ? proc :
       sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc);
@@ -1475,5 +1482,6 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     res = sexp_vm(ctx, proc);
     if (! res) res = SEXP_VOID; /* shouldn't happen */
   }
+  sexp_gc_release1(ctx);
   return res;
 }