fix space-safety problem

A tail call with certain kinds of primitives would fail to
clear local bindings in a detectable way. For example, a
tail call to `sync' that blocks could retain references
to unreachable data in the context of the `sync' call.

Primitives that can cause problems in the run-time system
are already identified as "imemdiate" primitives. The
safe-for-space pass now inserts clearing actions before a tail
call, unless the call it to a known immediate primitive or a
Racket-implemented function.

Clearing operations are now omitted before non-tail calls
to immediate operations like structure predicates.

The newly added clearing operations could affect performance,
but they probably won't, since the clear operations are still
avoided in tail-call cases that are otherwise fast. The newly
omitted clearing operations may improve performance.

collects/tests/racket/will.rktl

@@ -218,6 +218,33 @@
   (test #t < (current-memory-use c) (+ mc (expt 2 28)))
   (semaphore-post s))
 
+;; ----------------------------------------
+;; Check that local variables are cleared for space safety
+;; before a tail `sync' or `thread-wait':
+
+(let ()
+  (define weak-syms (make-weak-hash))
+
+  (define thds
+    (for/list ([i (in-range 100)])
+      (thread (lambda () 
+                (define s (gensym))
+                (define t (current-thread))
+                (define sema (make-semaphore))
+                (define r (random 2))
+                (hash-set! weak-syms s #t)
+                (if (zero? (random 1))
+                    (if (zero? r)
+                        (sync sema)
+                        (thread-wait t))
+                    (displayln s))))))
+
+  (sync (system-idle-evt))
+  (collect-garbage)
+  (test #t < (hash-count weak-syms) 50)
+
+  (for ([t thds]) (kill-thread t)))
+
 ;; ----------------------------------------
 
 (report-errs)

src/racket/src/compile.c

@@ -4152,7 +4152,7 @@ Scheme_App_Rec *scheme_malloc_application(int n)
     app = (Scheme_App_Rec *)scheme_malloc_tagged(size);
   }
 
-  app->so.type = scheme_application_type;
+  app->iso.so.type = scheme_application_type;
 
   app->num_args = n - 1;
 

src/racket/src/eval.c

@@ -3291,7 +3291,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
 	  arg = app->rand;
 
-	  switch (flags >> 3) {
+	  switch ((flags >> 3) & 0x7) {
 	  case SCHEME_EVAL_CONSTANT:
 	    break;
 	  case SCHEME_EVAL_GLOBAL:
@@ -3390,7 +3390,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
 	  arg = app->rand2;
 
-	  switch (SCHEME_APPN_FLAGS(app) >> 6) {
+	  switch ((SCHEME_APPN_FLAGS(app) >> 6) & 0x7) {
 	  case SCHEME_EVAL_CONSTANT:
 	    break;
 	  case SCHEME_EVAL_GLOBAL:

src/racket/src/optimize.c

@@ -2118,10 +2118,47 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
   return finish_optimize_application(app, info, context, rator_flags);
 }
 
+static int appn_flags(Scheme_Object *rator, Optimize_Info *info)
+{
+  if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_toplevel_type)) {
+    if (info->top_level_consts) {
+      int pos;
+      pos = SCHEME_TOPLEVEL_POS(rator);
+      rator = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
+      rator = no_potential_size(rator);
+      if (!rator) return 0;
+      if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) {
+        return APPN_FLAG_SFS_TAIL;
+      } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) {
+        int ps = SCHEME_PROC_SHAPE_MODE(rator);
+        if ((ps == STRUCT_PROC_SHAPE_PRED)
+            || (ps == STRUCT_PROC_SHAPE_GETTER)
+            || (ps == STRUCT_PROC_SHAPE_SETTER))
+          return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL);
+        return 0;
+      }
+    }
+  }
+
+  if (SCHEME_PRIMP(rator)) {
+    int opt = (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_OPT_MASK);
+    if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
+      return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL);
+    return 0;
+  }
+
+  if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rator))
+      || SAME_TYPE(scheme_case_lambda_sequence_type, SCHEME_TYPE(rator))
+      || SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(rator)))
+    return APPN_FLAG_SFS_TAIL;
+  
+  return 0;
+}
+
 static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags)
 {
   Scheme_Object *le;
-  int all_vals = 1, i;
+  int all_vals = 1, i, flags;
 
   for (i = app->num_args; i--; ) {
     if (SCHEME_TYPE(app->args[i+1]) < _scheme_compiled_values_types_)
@@ -2150,6 +2187,9 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
 
   register_local_argument_types(app, NULL, NULL, info);
 
+  flags = appn_flags(app->args[0], info);
+  SCHEME_APPN_FLAGS(app) |= flags;
+
   return (Scheme_Object *)app;
 }
 
@@ -2259,6 +2299,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
 static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags)
 {
   Scheme_Object *le;
+  int flags;
 
   info->size += 1;
 
@@ -2410,6 +2451,9 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
 
   register_local_argument_types(NULL, app, NULL, info);
 
+  flags = appn_flags(app->rator, info);
+  SCHEME_APPN_FLAGS(app) |= flags;
+
   return (Scheme_Object *)app;
 }
 
@@ -2417,7 +2461,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 {
   Scheme_App3_Rec *app;
   Scheme_Object *le;
-  int rator_flags = 0, sub_context = 0, ty;
+  int rator_flags = 0, sub_context = 0, ty, flags;
 
   app = (Scheme_App3_Rec *)o;
 
@@ -2466,6 +2510,9 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
   le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info);
   if (le) return finish_optimize_app(le, info, context, rator_flags);
 
+  flags = appn_flags(app->rator, info);
+  SCHEME_APPN_FLAGS(app) |= flags;
+
   return finish_optimize_application3(app, info, context, rator_flags);
 }
 
@@ -5896,6 +5943,8 @@ Scheme_Object *optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *in
       if (!expr) return NULL;
       app2->rand = expr;
 
+      SCHEME_APPN_FLAGS(app2) |= (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
+
       return (Scheme_Object *)app2;
     }
   case scheme_application_type:
@@ -5911,6 +5960,8 @@ Scheme_Object *optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *in
 	app2->args[i] = expr;
       }
 
+      SCHEME_APPN_FLAGS(app2) |= (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
+
       return (Scheme_Object *)app2;
     }
   case scheme_application3_type:
@@ -5932,6 +5983,8 @@ Scheme_Object *optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *in
       if (!expr) return NULL;
       app2->rand2 = expr;
 
+      SCHEME_APPN_FLAGS(app2) |= (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
+
       return (Scheme_Object *)app2;
     }
   case scheme_compiled_let_void_type:

src/racket/src/resolve.c

@@ -242,7 +242,7 @@ static void set_app2_eval_type(Scheme_App2_Rec *app)
   et = et << 3;
   et += scheme_get_eval_type(app->rator);
   
-  SCHEME_APPN_FLAGS(app) = et;
+  SCHEME_APPN_FLAGS(app) = et | (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
 }
 
 void scheme_reset_app2_eval_type(Scheme_App2_Rec *app)
@@ -364,7 +364,7 @@ static void set_app3_eval_type(Scheme_App3_Rec *app)
   et = et << 3;
   et += scheme_get_eval_type(app->rator);
   
-  SCHEME_APPN_FLAGS(app) = et;
+  SCHEME_APPN_FLAGS(app) = et | (SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
 }
 
 void scheme_reset_app3_eval_type(Scheme_App3_Rec *app)

src/racket/src/schpriv.h

@@ -1229,7 +1229,7 @@ int scheme_is_predefined_module_p(Scheme_Object *name);
 /*========================================================================*/
 
 typedef struct {
-  Scheme_Object so;
+  Scheme_Inclhash_Object iso; /* keyex used for flags */
   mzshort num_args; /* doesn't include rator, so arguments are at args[1]...args[num_args] */
   Scheme_Object *args[mzFLEX_ARRAY_DECL];
   /* After array of f & args, array of chars for eval type */
@@ -1245,6 +1245,13 @@ enum {
   SCHEME_EVAL_GENERAL
 };
 
+/* Flags to indicate to SFS pass that a [tail] application doesn't
+   need clearing before it (because the call is to a immediate
+   primitive or a Racket-implemented function). */
+#define APPN_FLAG_IMMED (1 << 12)
+#define APPN_FLAG_SFS_TAIL (1 << 13)
+#define APPN_FLAG_MASK (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL)
+
 typedef struct {
   Scheme_Inclhash_Object iso; /* keyex used for flags */
   Scheme_Object *rator;

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.3.7"
+#define MZSCHEME_VERSION "5.3.3.8"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 7
+#define MZSCHEME_VERSION_W 8
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/sfs.c

@@ -209,14 +209,17 @@ Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears,
   return (Scheme_Object *)s;
 }
 
-static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
+static void sfs_note_app(SFS_Info *info, Scheme_Object *rator, int flags)
 {
   if (!info->pass) {
     if (!info->tail_pos) {
+      if (flags & APPN_FLAG_IMMED)
+        return;
       if (SAME_OBJ(scheme_values_func, rator))
         /* no need to clear for app of `values' */
         return;
       if (SCHEME_PRIMP(rator)) {
+        /* Double-check for immediate primitives: */
         int opt;
         opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
         if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
@@ -225,6 +228,7 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
       }
       info->max_nontail = info->ip;
     } else {
+      int tail_ok = (flags & APPN_FLAG_SFS_TAIL);      
       if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
         if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
           if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
@@ -235,9 +239,12 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
               if ((info->selfstart + i) != info->tlpos)
                 scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
             }
+            tail_ok = 1;
           }
         }
       }
+      if (!tail_ok)
+        info->max_nontail = info->ip;
     }
   }
 }
@@ -260,7 +267,7 @@ static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info)
     app->args[i] = naya;
   }
 
-  sfs_note_app(info, app->args[0]);
+  sfs_note_app(info, app->args[0], SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
 
   scheme_finish_application(app);
 
@@ -282,7 +289,7 @@ static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info)
   app->rator = nrator;
   app->rand = nrand;
 
-  sfs_note_app(info, app->rator);
+  sfs_note_app(info, app->rator, SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
 
   scheme_reset_app2_eval_type(app);
   
@@ -307,7 +314,7 @@ static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info)
   app->rand1 = nrand1;
   app->rand2 = nrand2;
 
-  sfs_note_app(info, app->rator);
+  sfs_note_app(info, app->rator, SCHEME_APPN_FLAGS(app) & APPN_FLAG_MASK);
 
   scheme_reset_app3_eval_type(app);