fix over-eager bytecode optimization of folding a reference to a letrec-bound identifier that is not yet ready

svn: r12385

src/mzscheme/src/env.c

@@ -3033,6 +3033,8 @@ void scheme_optimize_info_used_top(Optimize_Info *info)
 
 void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use)
 {
+  /* A raw-pair `value' is an indicator for whether a letrec-bound
+     variable is ready. */
   Scheme_Object *p;
 
   p = scheme_make_vector(4, NULL);
@@ -3120,7 +3122,7 @@ int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
   return 0;
 }
 
-static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use)
+static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, int *not_ready)
 {
   Scheme_Object *p, *n;
   int delta = 0;
@@ -3140,6 +3142,13 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
     n = SCHEME_VEC_ELS(p)[1];
     if (SCHEME_INT_VAL(n) == pos) {
       n = SCHEME_VEC_ELS(p)[2];
+      if (SCHEME_RPAIRP(n)) {
+        /* This was a letrec-bound identifier that may or may not be ready,
+           but which wasn't replaced with more information. */
+        if (not_ready)
+          *not_ready = SCHEME_TRUEP(SCHEME_CAR(n));
+        break;
+      }
       if (single_use)
         *single_use = SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]);
       if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) {
@@ -3168,7 +3177,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
           if (!*single_use)
             single_use = NULL;
         }
-	n = do_optimize_info_lookup(info, pos, j, NULL, single_use);
+	n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL);
 
 	if (!n) {
 	  /* Return shifted reference to other local: */
@@ -3189,7 +3198,16 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
 
 Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use)
 {
-  return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use);
+  return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL);
+}
+
+int scheme_optimize_info_is_ready(Optimize_Info *info, int pos)
+{
+  int closure_offset, single_use, ready = 1;
+  
+  do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready);
+
+  return ready;
 }
 
 Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags)

src/mzscheme/src/schpriv.h

@@ -2165,6 +2165,7 @@ void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int
 void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted);
 int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted);
 int scheme_resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags, Scheme_Object **lifted, int convert_shift);
+int scheme_optimize_info_is_ready(Optimize_Info *info, int pos);
 void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos);
 
 void scheme_enable_expression_resolve_lifts(Resolve_Info *ri);

src/mzscheme/src/syntax.c

@@ -2959,7 +2959,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
   Optimize_Info *body_info, *rhs_info;
   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
   Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
-  Scheme_Object *body, *value;
+  Scheme_Object *body, *value, *ready_pairs = NULL;
   int i, j, pos, is_rec, not_simply_let_star = 0;
   int size_before_opt, did_set_value;
   int remove_last_one = 0;
@@ -3009,6 +3009,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
     for (j = pre_body->count; j--; ) {
       if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
 	scheme_optimize_mutated(body_info, pos + j);
+      } else if (is_rec) {
+        /* Indicate that it's not yet ready, so it cannot be inlined: */
+        ready_pairs = scheme_make_raw_pair(scheme_false, ready_pairs);
+        scheme_optimize_propagate(body_info, pos+j, ready_pairs, 0);
       }
     }
     pos += pre_body->count;
@@ -3120,6 +3124,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
 	     This must be done with respect to body_info, not
 	     rhs_info, because we attach the value to body_info: */
 	  value = scheme_optimize_reverse(body_info, vpos, 1);
+          
+          /* Double-check that the value is ready, because we might be
+             nested in the RHS of a `letrec': */
+          if (value)
+            if (!scheme_optimize_info_is_ready(body_info, SCHEME_LOCAL_POS(value)))
+              value = NULL;
 	}
       }
 
@@ -3241,6 +3251,15 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
     body_info->size = rhs_info->size;
   }
 
+  /* All letrec-bound variables are now ready.  We could improve the
+     optimizer by making variables available earlier, since letrec is
+     really letrec*, but watch out for the re-optimization loop
+     above. */
+  while (ready_pairs) {
+    SCHEME_CAR(ready_pairs) = scheme_true;
+    ready_pairs = SCHEME_CDR(ready_pairs);
+  }
+
   body = scheme_optimize_expr(body, body_info);
   if (head->num_clauses)
     pre_body->body = body;