safe-for-space repairs for functions with rest args

collects/compiler/decompile.rkt

@@ -307,6 +307,7 @@
          ,@(if (and name (not (null? name)))
                `(',name)
                null)
+         ,@(if (null? flags) null `('(flags: ,@flags)))
          ,@(if (null? captures)
                null
                `('(captures: ,@(map (lambda (c t)

collects/compiler/zo-marshal.rkt

@@ -257,6 +257,7 @@
 (define CLOS_HAS_REST 1)
 (define CLOS_HAS_REF_ARGS 2)
 (define CLOS_PRESERVES_MARKS 4)
+(define CLOS_NEED_REST_CLEAR 8)
 (define CLOS_IS_METHOD 16)
 (define CLOS_SINGLE_RESULT 32)
 
@@ -1006,6 +1007,7 @@
                        (+ (if rest? CLOS_HAS_REST 0)
                           (if any-refs? CLOS_HAS_REF_ARGS 0)
                           (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0)
+                          (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0)
                           (if (memq 'is-method flags) CLOS_IS_METHOD 0)
                           (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0))
                        num-all-params

collects/compiler/zo-parse.rkt

@@ -81,6 +81,7 @@
   (define CLOS_HAS_REST 1)
   (define CLOS_HAS_REF_ARGS 2)
   (define CLOS_PRESERVES_MARKS 4)
+  (define CLOS_NEED_REST_CLEAR 8)
   (define CLOS_IS_METHOD 16)
   (define CLOS_SINGLE_RESULT 32)
   (define BITS_PER_MZSHORT 32)
@@ -118,6 +119,7 @@
                     (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
                     (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method))
                     (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))
+                    (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args))
                     (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null))
                    (if (and rest? (num-params . > . 0))
                        (sub1 num-params)

collects/compiler/zo-structs.rkt

@@ -131,7 +131,8 @@
                                 [internal-context (or/c #f #t stx?)]))
 
 (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
-                                [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))]
+                                [flags (listof (or/c 'preserves-marks 'is-method 'single-result
+                                                     'only-rest-arg-not-used 'sfs-clear-rest-args))]
                                 [num-params exact-nonnegative-integer?]
                                 [param-types (listof (or/c 'val 'ref 'flonum))]
                                 [rest? boolean?]

collects/scribblings/raco/zo-parse.scrbl

@@ -271,7 +271,8 @@
 
 @defstruct+[(lam expr)
             ([name (or/c symbol? vector?)]
-             [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))]
+             [flags (listof (or/c 'preserves-marks 'is-method 'single-result 
+                                  'only-rest-arg-not-used 'sfs-clear-rest-args))]
              [num-params exact-nonnegative-integer?]
              [param-types (listof (or/c 'val 'ref 'flonum))]
              [rest? boolean?]

src/racket/src/eval.c

@@ -8626,6 +8626,27 @@ static Scheme_Object *do_eval_k(void)
 			p->ku.k.i2);
 }
 
+#ifdef MZ_USE_JIT
+static Scheme_Object *do_eval_native_k(void)
+{
+  /* If argv corresponds to old runstack, copy to new runstack
+     and clear old argv for space safety. */
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
+
+  if (argv == (p->runstack_saved->runstack_start
+               + p->runstack_saved->runstack_offset)) {
+    int argc = p->ku.k.i1;
+    MZ_RUNSTACK -= argc;
+    memcpy(MZ_RUNSTACK, argv, argc * sizeof(Scheme_Object*));
+    memset(argv, 0, argc * sizeof(Scheme_Object*));
+    p->ku.k.p2 = MZ_RUNSTACK;
+  }
+
+  return do_eval_k();
+}
+#endif
+
 static void unbound_global(Scheme_Object *obj)
 {
   Scheme_Object *tmp;
@@ -9519,7 +9540,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
 	MZ_CONT_MARK_POS -= 2;
 	v = (Scheme_Object *)scheme_enlarge_runstack(data->max_let_depth / sizeof(void *), 
-						     (void *(*)(void))do_eval_k);
+						     (void *(*)(void))do_eval_native_k);
 	MZ_CONT_MARK_POS += 2;
 	goto returnv;
       }

src/racket/src/fun.c

@@ -1325,6 +1325,9 @@ Scheme_Object *scheme_sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_
       
       if (SCHEME_PAIRP(clears))
         code = scheme_sfs_add_clears(code, clears, 1);
+
+      if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
+        SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR;
     }
 
     data->code = code;

src/racket/src/jit.c

@@ -99,6 +99,16 @@ static void wrong_argument_count(Scheme_Object *proc, int argc, Scheme_Object **
   scheme_wrong_count((char *)proc, -1, -1, argc, argv);
 }
 
+static Scheme_Object *clear_rs_arguments(Scheme_Object *v, int size, int delta) XFORM_SKIP_PROC
+{
+  int i;
+  Scheme_Object **argv = MZ_RUNSTACK;
+  for (i = size; i-- > delta; ) {
+    argv[i] = NULL;
+  }
+  return v;
+}
+
 #ifdef JIT_THREAD_LOCAL
 void *scheme_jit_get_threadlocal_table() XFORM_SKIP_PROC { return &BOTTOM_VARIABLE; }
 #endif
@@ -2856,15 +2866,11 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
 {
   int i, cnt;
   GC_CAN_IGNORE jit_insn *ref;
-  int set_ref;
 
-  /* If rands == runstack and there are no rest args, set runstack
+  /* If rands == runstack, set runstack base to runstack + rands (and
-     base to runstack + rands (and don't copy rands), otherwise set
+     don't copy rands), otherwise set base to runstack and copy
-     base to runstack and proceed normally. Implement this by
+     arguments at runstack. Implement the test by optimistically
-     optimistically assuming rands == runstack, so that there's just
+     assuming rands == runstack, so that there's just one jump. */
-     one jump. Skip this optimization when the procedure has
-     rest args, because we'll have to copy anyway. */
-  if (!has_rest && num_params) {
   jit_lshi_l(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1, JIT_LOG_WORD_SIZE);
   jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_V1));
 #ifndef JIT_RUNSTACK_BASE
@@ -2873,11 +2879,7 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
   __START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
   ref = jit_beqr_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
   __END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
-    set_ref = 1;
+
-  } else {
-    ref = 0;
-    set_ref = 0;
-  }
 #ifdef JIT_RUNSTACK_BASE
   jit_movr_p(JIT_RUNSTACK_BASE, JIT_RUNSTACK);
 #else
@@ -2901,11 +2903,9 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
     CHECK_LIMIT();
   }
 
-  if (set_ref) {
   __START_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
   mz_patch_branch(ref);
   __END_TINY_OR_SHORT_JUMPS__(num_params < 10, num_params < 100);
-  }
 
   return cnt;
 }
@@ -2943,6 +2943,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
   cnt = generate_function_getarg(jitter, 
 				 (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST),
 				 data->num_params);
+  /* At this point, all non-rest arguments are now at the runstack */
   CHECK_LIMIT();
 
   /* A tail call with arity checking can start here.
@@ -2980,7 +2981,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
   tail_code = jit_get_ip().ptr;
 
   /* 0 params and has_rest => (lambda args E) where args is not in E,
-     so accept any number of arguments and ignore them. */
+     so accept any number of arguments and just clear them (for space 
+     safety). */
 
   if (has_rest && data->num_params) {
     /* If runstack == argv and argc == cnt, then we didn't
@@ -2998,6 +3000,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
     for (i = cnt; i--; ) {
       jit_ldxi_p(JIT_V1, JIT_R2, WORDS_TO_BYTES(i));
       jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_V1);
+      /* space safety: */
+      jit_stxi_p(WORDS_TO_BYTES(i), JIT_R2, JIT_RUNSTACK);
       CHECK_LIMIT();
     }
     (void)jit_movi_p(JIT_V1, scheme_null);
@@ -3008,6 +3012,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
     /* Build a list for extra arguments: */
     mz_patch_branch(ref);
     mz_patch_branch(ref3);
+    CHECK_LIMIT();
 #ifndef JIT_PRECISE_GC
     if (data->closure_size)
 #endif
@@ -3017,8 +3022,17 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
       }
     JIT_UPDATE_THREAD_RSPTR();
     CHECK_LIMIT();
-    mz_prepare(3);
     jit_movi_i(JIT_V1, cnt);
+    if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_NEED_REST_CLEAR)) {
+      /* negative count => clear argv */
+      GC_CAN_IGNORE jit_insn *ref;
+      __START_INNER_TINY__(cnt < 100);
+      ref = jit_bner_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
+      jit_negr_i(JIT_R1, JIT_R1);
+      mz_patch_branch(ref);
+      __END_INNER_TINY__(cnt < 100);
+    }
+    mz_prepare(3);
     jit_pusharg_i(JIT_V1);
     jit_pusharg_p(JIT_R2);
     jit_pusharg_i(JIT_R1);
@@ -3034,7 +3048,6 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
       }
     jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1);
     mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */
-    CHECK_LIMIT();
 
     __END_SHORT_JUMPS__(cnt < 100);
 
@@ -3044,6 +3057,27 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
       argc = 0;
     }
   } else {
+    if (has_rest && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_NEED_REST_CLEAR)) {
+      /* if we get here, the rest argument isn't used */
+      GC_CAN_IGNORE jit_insn *ref;
+      __START_TINY_JUMPS__(1);
+      ref = jit_bner_p(jit_forward(), JIT_RUNSTACK, JIT_R2);
+      __END_TINY_JUMPS__(1);
+      mz_rs_sync();
+      JIT_UPDATE_THREAD_RSPTR();
+      CHECK_LIMIT();
+      mz_prepare(3);
+      jit_movi_i(JIT_V1, cnt);
+      jit_pusharg_i(JIT_V1);
+      jit_pusharg_i(JIT_R1);
+      jit_pusharg_p(JIT_R0);
+      CHECK_LIMIT();
+      (void)mz_finish(clear_rs_arguments);
+      jit_retval(JIT_R0);
+      __START_TINY_JUMPS__(1);
+      mz_patch_branch(ref);
+      __END_TINY_JUMPS__(1);
+    }
     has_rest = 0;
     if (argc != data->num_params) {
       argv = NULL;

src/racket/src/jitinline.c

@@ -2976,9 +2976,8 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
 }
 
 int scheme_generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry)
+/* Args must be in R0 (car) and R1 (cdr); uses R2 and V1 as temporaries */
 {
-  /* Args should be in R0 (car) and R1 (cdr) */
-
 #ifdef CAN_INLINE_ALLOC
   /* Inlined alloc */
   scheme_inline_alloc(jitter, sizeof(Scheme_Simple_Object), scheme_pair_type, 0, 1, 0, inline_retry);

src/racket/src/list.c

@@ -848,12 +848,22 @@ Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
 }
 
 Scheme_Object *scheme_build_list_offset(int size, Scheme_Object **argv, int delta)
+/* clears originals in argv for space safety! */
 {
   Scheme_Object *pair = scheme_null;
   int i;
 
+  if (size < 0) {
+    /* clearing mode: */
+    size = -size;
     for (i = size; i-- > delta; ) {
       pair = cons(argv[i], pair);
+      argv[i] = NULL;
+    }
+  } else {
+    for (i = size; i-- > delta; ) {
+      pair = cons(argv[i], pair);
+    }
   }
 
   return pair;

src/racket/src/schpriv.h

@@ -2088,10 +2088,11 @@ typedef struct Scheme_Comp_Env
 #define CLOS_HAS_REST 1
 #define CLOS_HAS_TYPED_ARGS 2
 #define CLOS_PRESERVES_MARKS 4
-#define CLOS_SFS 8
+#define CLOS_NEED_REST_CLEAR 8
 #define CLOS_IS_METHOD 16
 #define CLOS_SINGLE_RESULT 32
 #define CLOS_RESULT_TENTATIVE 64
+#define CLOS_SFS 128
 #define CLOS_VALIDATED 128
 /* BITS 8-15 used by write_compiled_closure() */