fix gc and stack-overflow problems in JIT, module expansion & run

The GC problem was related to generational GC and the way constant
values are associated to JIT-generated code. See `retaining_data'.

The stack-overflow problems affects the JIT, module expansion,
and module invocation.

collects/tests/racket/stress/module-stack.rkt

@@ -0,0 +1,37 @@
+#lang racket/load
+
+;; This test tries to stress module expansion, module invocation/visit,
+;; and JIT compilation with stack overflows. It turns out to be a useful
+;; GC test, too, since stack overflows trigger many minor GCs.
+
+(module loopy racket/base
+  (require (for-syntax racket/base))
+  (provide loopy)
+  
+  (define-syntax (loopy stx)
+    (printf "~s\n" (variable-reference->module-base-phase (#%variable-reference)))  
+    (if (= 100 (variable-reference->module-base-phase (#%variable-reference)))
+        #'(void)
+        #'(begin
+            (require (for-syntax 'loopy))
+            (begin-for-syntax
+             (loopy))))))
+
+(define results (make-vector 30))
+
+(void
+ (let loop ([i 0])
+   (vector-set-performance-stats! results)
+   (if (zero? (vector-ref results 5))
+       (let ([v (loop (add1 i))])
+         (if (zero? v)
+             (begin
+               (printf "at ~s\n" i) ; around 129000 for 32-bit w/JIT; around 16750 for 32-bit w/o JIT
+               (eval '(module overflow racket
+                        (require 'loopy)
+                        (loopy)))
+               -1)
+             (sub1 v)))
+       (if (eval-jit-enabled)
+           500
+           50))))

src/racket/src/fun.c

@@ -959,6 +959,24 @@ void scheme_really_create_overflow(void *stack_base)
 
       reply = f();
       scheme_overflow_reply = reply;
+
+      /* At the time of writing, there appear to be no GCs on the 
+         longjmp return from stack overflow. Just in case, though,
+         it seems better to protect multiple-value and tail-call 
+         results from any GC that might be introduced one day. */
+      if (reply == SCHEME_MULTIPLE_VALUES) {
+        p = scheme_current_thread;
+        if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
+          p->values_buffer = NULL;
+      } else if (reply == SCHEME_TAIL_CALL_WAITING) {
+        p = scheme_current_thread;
+        if (p->ku.apply.tail_rands == p->tail_buffer) {
+          GC_CAN_IGNORE Scheme_Object **tb;
+          p->tail_buffer = NULL; /* so args aren't zeroed */
+          tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
+          p->tail_buffer = tb;
+        }
+      }
     }
 
     p = scheme_current_thread;

src/racket/src/jit.c

@@ -1535,16 +1535,27 @@ static Scheme_Object *generate_k(void)
   Scheme_Thread *p = scheme_current_thread;
   Scheme_Object *obj = (Scheme_Object *)p->ku.k.p1;
   mz_jit_state *jitter = (mz_jit_state *)p->ku.k.p2;
-  Branch_Info *for_branch = (Branch_Info *)p->ku.k.p3;
+  Branch_Info *for_branch = (Branch_Info *)p->ku.k.p3, for_branch_copy;
+  Branch_Info_Addr *for_branch_addrs = (Branch_Info_Addr *)p->ku.k.p4;
   int v;
 
   p->ku.k.p1 = NULL;
   p->ku.k.p2 = NULL;
   p->ku.k.p3 = NULL;
 
-  v = scheme_generate(obj, jitter, p->ku.k.i1, p->ku.k.i4, p->ku.k.i2, p->ku.k.i3, for_branch);
+  if (for_branch) {
+    memcpy(&for_branch_copy, for_branch, sizeof(Branch_Info));
+    for_branch_copy.addrs = for_branch_addrs;
+  }
 
-  return scheme_make_integer(v);
+  v = scheme_generate(obj, jitter, p->ku.k.i1, p->ku.k.i4, p->ku.k.i2, p->ku.k.i3, 
+                      (for_branch ? &for_branch_copy : NULL));
+
+  if (for_branch) {
+    memcpy(for_branch, &for_branch_copy, sizeof(Branch_Info));
+    return scheme_make_raw_pair(scheme_make_integer(v), (Scheme_Object *)for_branch->addrs);
+  } else
+    return scheme_make_integer(v);
 }
 
 #define NUM_QUICK_INFO_ADDRS 6
@@ -1781,12 +1792,22 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
     Scheme_Object *ok;
     Scheme_Thread *p = scheme_current_thread;
     mz_jit_state *jitter_copy;
+    Branch_Info *for_branch_copy;
+    Branch_Info_Addr *addrs;
+    int *copy_mappings;
 
-    jitter_copy = MALLOC_ONE_RT(mz_jit_state);
+    copy_mappings = (int *)scheme_malloc_atomic(jitter->mappings_size * sizeof(int));
-    memcpy(jitter_copy, jitter, sizeof(mz_jit_state));
+    memcpy(copy_mappings, jitter->mappings, jitter->mappings_size * sizeof(int));
-#ifdef MZTAG_REQUIRED
+    jitter->mappings = copy_mappings;
-    jitter_copy->type = scheme_rt_jitter_data;
+
-#endif
+    jitter_copy = scheme_clone_jitter(jitter);
+    if (for_branch) {
+      for_branch_copy = scheme_malloc_atomic(sizeof(Branch_Info));
+      memcpy(for_branch_copy, for_branch, sizeof(Branch_Info));
+      addrs = scheme_malloc_atomic(sizeof(Branch_Info_Addr) * for_branch->addrs_size);
+      memcpy(addrs, for_branch->addrs, sizeof(Branch_Info_Addr) * for_branch->addrs_count);
+    } else
+      for_branch_copy = NULL;
 
     p->ku.k.p1 = (void *)obj;
     p->ku.k.p2 = (void *)jitter_copy;
@@ -1794,11 +1815,18 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
     p->ku.k.i4 = wcm_may_replace;
     p->ku.k.i2 = multi_ok;
     p->ku.k.i3 = target;
-    p->ku.k.p3 = (void *)for_branch;
+    p->ku.k.p3 = (void *)for_branch_copy;
+    p->ku.k.p4 = (void *)addrs;
 
     ok = scheme_handle_stack_overflow(generate_k);
 
-    memcpy(jitter, jitter_copy, sizeof(mz_jit_state));
+    scheme_unclone_jitter(jitter, jitter_copy);
+
+    if (for_branch) {
+      memcpy(for_branch, for_branch_copy, sizeof(Branch_Info));
+      for_branch->addrs = (Branch_Info_Addr *)SCHEME_CDR(ok);
+      ok = SCHEME_CAR(ok);
+    }
 
     return SCHEME_INT_VAL(ok);
   }

src/racket/src/jit.h

@@ -298,6 +298,7 @@ typedef struct {
   int need_set_rs;
   void **retain_start;
   double *retain_double_start;
+  Scheme_Native_Closure_Data *retaining_data; /* poke when setting retain_start for generational GC */
   int local1_busy, pushed_marks;
   int log_depth;
   int self_pos, self_closure_size, self_toplevel_pos;
@@ -318,6 +319,9 @@ typedef struct {
   int self_restart_offset, self_restart_space;
 } mz_jit_state;
 
+mz_jit_state *scheme_clone_jitter(mz_jit_state *j);
+void scheme_unclone_jitter(mz_jit_state *j, mz_jit_state *j_copy);
+
 typedef int (*Generate_Proc)(mz_jit_state *j, void *data);
 
 typedef struct {
@@ -335,7 +339,7 @@ typedef struct {
 typedef struct {
   int include_slow;
   int non_tail, restore_depth, flostack, flostack_pos;
-  int need_sync, branch_short, true_needs_jump;
+  int branch_short, true_needs_jump;
   int addrs_count, addrs_size;
   Branch_Info_Addr *addrs;
 } Branch_Info;

src/racket/src/jitstate.c

@@ -51,6 +51,15 @@ int scheme_mz_retain_it(mz_jit_state *jitter, void *v)
 {
   if (jitter->retain_start) {
     jitter->retain_start[jitter->retained] = v;
+#ifdef JIT_PRECISE_GC
+    /* We just change an array that is marked indirectly for GC
+       via a Scheme_Native_Closure_Data. Write to that record
+       so that a minor GC will trace it and therefore trace
+       the reatined array: */
+    if (jitter->retaining_data) {
+      jitter->retaining_data->retained = jitter->retain_start;
+    }
+#endif
   }
   jitter->retained++;
   return jitter->retained;
@@ -183,7 +192,11 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
 #ifdef MZ_PRECISE_GC
       if (ndata) {
 	memset(jitter->retain_start, 0, num_retained * sizeof(void*));
-	ndata->retained = (num_retained ? jitter->retain_start : NULL);
+        if (num_retained) {
+          jitter->retaining_data = ndata;
+          ndata->retained = jitter->retain_start;
+        } else
+          ndata->retained = NULL;
 	SCHEME_BOX_VAL(fnl_obj) = scheme_make_integer(size_pre_retained_double);
 	GC_set_finalizer(fnl_obj, 1, 3,
 			 scheme_jit_release_native_code, buffer,
@@ -281,6 +294,24 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
   }
 }
 
+
+mz_jit_state *scheme_clone_jitter(mz_jit_state *jitter) {
+  mz_jit_state *jitter_copy;
+
+  jitter_copy = MALLOC_ONE_RT(mz_jit_state);
+  memcpy(jitter_copy, jitter, sizeof(mz_jit_state));
+#ifdef MZTAG_REQUIRED
+  jitter_copy->type = scheme_rt_jitter_data;
+#endif
+
+  return jitter_copy;
+}
+
+
+void scheme_unclone_jitter(mz_jit_state *jitter, mz_jit_state *jitter_copy) {
+  memcpy(jitter, jitter_copy, sizeof(mz_jit_state));
+}
+
 /*========================================================================*/
 /*                           code-gen utils                               */
 /*========================================================================*/

src/racket/src/module.c

@@ -4147,12 +4147,53 @@ static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase,
   }
 }
 
+static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, 
+                               intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx);
+
+static Scheme_Object *chain_start_module_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Env *menv = (Scheme_Env *)p->ku.k.p1;
+  Scheme_Env *env = (Scheme_Env *)p->ku.k.p2;
+  Scheme_Object *cycle_list = (Scheme_Object *)p->ku.k.p3;
+  Scheme_Object *syntax_idx = (Scheme_Object *)p->ku.k.p4;
+
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
+  p->ku.k.p4 = NULL;
+
+  chain_start_module(menv, env,
+                     p->ku.k.i1, p->ku.k.i2,
+                     p->ku.k.i3, cycle_list, syntax_idx);
+
+  return scheme_true;
+}
+
 static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, 
                                intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx)
 {
   Scheme_Object *new_cycle_list, *midx, *l;
   Scheme_Module *im;
 
+#ifdef DO_STACK_CHECK
+  {
+# include "mzstkchk.h"
+    {
+      Scheme_Thread *p = scheme_current_thread;
+      p->ku.k.p1 = (void *)menv;
+      p->ku.k.p2 = (void *)env;
+      p->ku.k.i1 = eval_exp;
+      p->ku.k.i2 = eval_run;
+      p->ku.k.i3 = base_phase;
+      p->ku.k.p3 = (void *)cycle_list;
+      p->ku.k.p4 = (void *)syntax_idx;
+      (void)scheme_handle_stack_overflow(chain_start_module_k);
+      return;
+    }
+  }
+#endif
+
   new_cycle_list = scheme_make_pair(menv->module->modname, cycle_list);
   
   if (!SCHEME_NULLP(menv->module->dt_requires)) {
@@ -6440,6 +6481,25 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
   }
 }
 
+static Scheme_Object *do_module_begin_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  void **args = p->ku.k.p1;
+  Scheme_Object *form = (Scheme_Object *)args[0];
+  Scheme_Comp_Env *env = (Scheme_Comp_Env *)args[1];
+  Scheme_Compile_Expand_Info *rec = (Scheme_Compile_Expand_Info *)args[2];
+  Scheme_Compile_Expand_Info *erec = (Scheme_Compile_Expand_Info *)args[3];
+  int phase = SCHEME_INT_VAL((Scheme_Object *)args[4]);
+  Scheme_Object *body_lists = (Scheme_Object *)args[5];
+  Module_Begin_Expand_State *bxs = (Module_Begin_Expand_State *)args[6];
+
+  p->ku.k.p1 = NULL;
+  
+  return do_module_begin_at_phase(form, env, rec, 0, erec, 0,
+                                  phase, body_lists, bxs);
+}
+
+
 #define DONE_MODFORM_KIND 0
 #define EXPR_MODFORM_KIND 1
 #define DEFN_MODFORM_KIND 2
@@ -6474,6 +6534,54 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
   int maybe_has_lifts = 0;
   Scheme_Object *observer, *vec;
   Scheme_Object *define_values_stx, *begin_stx, *define_syntaxes_stx, *begin_for_syntax_stx, *req_stx, *prov_stx, *sv[6];
+
+#ifdef DO_STACK_CHECK
+# include "mzstkchk.h"
+  {
+    Scheme_Thread *pt = scheme_current_thread;
+    Scheme_Compile_Expand_Info *recx, *erecx;
+    void **args;
+
+    if (rec) {
+      recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info);
+      memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info));
+#ifdef MZTAG_REQUIRED
+      recx->type = scheme_rt_compile_info;
+#endif
+    } else
+      recx = NULL;
+    
+    if (erec) {
+      erecx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info);
+      memcpy(erecx, erec + derec, sizeof(Scheme_Compile_Expand_Info));
+#ifdef MZTAG_REQUIRED
+      erecx->type = scheme_rt_compile_info;
+#endif
+    } else
+      erecx = NULL;
+
+    args = MALLOC_N(void*, 7);
+
+    args[0] = form;
+    args[1] = env;
+    args[2] = recx;
+    args[3] = erecx;
+    args[4] = scheme_make_integer(phase);
+    args[5] = body_lists;
+    args[6] = bxs;
+
+    pt->ku.k.p1 = (void *)args;
+    
+    fm = scheme_handle_stack_overflow(do_module_begin_k);
+
+    if (recx)
+      memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info));
+    if (erecx)
+      memcpy(erec + derec, erecx, sizeof(Scheme_Compile_Expand_Info));
+
+    return fm;
+  }
+#endif
   
   if (*bxs->_num_phases < phase + 1)
     *bxs->_num_phases = phase + 1;

src/racket/src/mzmark_jit.inc

@@ -79,6 +79,11 @@ static int mark_jit_state_MARK(void *p, struct NewGC *gc) {
   mz_jit_state *j = (mz_jit_state *)p;
   gcMARK2(j->mappings, gc);
   gcMARK2(j->self_data, gc);
+  gcMARK2(j->example_argv, gc);
+  gcMARK2(j->nc, gc);
+  gcMARK2(j->retaining_data, gc);
+  gcMARK2(j->patch_depth, gc);
+  
   return
   gcBYTES_TO_WORDS(sizeof(mz_jit_state));
 }
@@ -87,6 +92,11 @@ static int mark_jit_state_FIXUP(void *p, struct NewGC *gc) {
   mz_jit_state *j = (mz_jit_state *)p;
   gcFIXUP2(j->mappings, gc);
   gcFIXUP2(j->self_data, gc);
+  gcFIXUP2(j->example_argv, gc);
+  gcFIXUP2(j->nc, gc);
+  gcFIXUP2(j->retaining_data, gc);
+  gcFIXUP2(j->patch_depth, gc);
+  
   return
   gcBYTES_TO_WORDS(sizeof(mz_jit_state));
 }

src/racket/src/mzmarksrc.c

@@ -2346,6 +2346,11 @@ mark_jit_state {
   mz_jit_state *j = (mz_jit_state *)p;
   gcMARK2(j->mappings, gc);
   gcMARK2(j->self_data, gc);
+  gcMARK2(j->example_argv, gc);
+  gcMARK2(j->nc, gc);
+  gcMARK2(j->retaining_data, gc);
+  gcMARK2(j->patch_depth, gc);
+  
  size:
   gcBYTES_TO_WORDS(sizeof(mz_jit_state));
 }