change bytecode optimizer's representation of `let'

- represent RHSes as before allocating stack positions
   for bindings, instead of after, which makes certain
   transformations simpler; this does not effect the
   final bytecode form that's is saved in a ".zo"

src/racket/src/env.c

@@ -3626,6 +3626,8 @@ 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 (info->flags & SCHEME_POST_BIND_FRAME)
+        delta += info->new_frame;          
       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. */
@@ -3644,9 +3646,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
       if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) {
 	if (!closure_offset)
 	  break;
-	else {
+	else
           *closure_offset = delta;
-	}
       } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
         /* Ok */
       } else if (closure_offset) {
@@ -3668,6 +3669,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
 	pos = SCHEME_LOCAL_POS(n);
 	if (info->flags & SCHEME_LAMBDA_FRAME)
 	  j--; /* because it will get re-added on recur */
+        else if (info->flags & SCHEME_POST_BIND_FRAME)
+          info = info->next; /* bindings are relative to next frame */
         
 	/* Marks local as used; we don't expect to get back
 	   a value, because chaining would normally happen on the 
@@ -3677,6 +3680,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, NULL, 0, context, potential_size);
 
 	if (!n) {

src/racket/src/eval.c

@@ -2671,7 +2671,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
         if (nested_count) {
           sub_info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
           sub_info->vclock++;
-          /* We could propagate bound values in sub_info , but relevant inlining
+          /* We could propagate bound values in sub_info, but relevant inlining
              and propagatation has probably already happened when the rator was
              optimized. */
         } else
@@ -3316,8 +3316,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
           lv->iso.so.type = scheme_compiled_let_value_type;
           lv->count = 1;
           lv->position = 0;
-          new_rand = scheme_optimize_shift(rand, 1, 0);
+          lv->value = rand;
-          lv->value = new_rand;
         
           flags = (int *)scheme_malloc_atomic(sizeof(int));
           flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT));
@@ -4545,6 +4544,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
       Scheme_Object *body;
       Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL;
       int i, *flags, sz;
+      int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
       
       head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header);
       head2->iso.so.type = scheme_compiled_let_void_type;
@@ -4568,7 +4568,8 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
 	lv2->position = lv->position;
 	lv2->flags = flags;
 
-	expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, closure_depth + head->count);
+	expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, 
+                                     closure_depth + (post_bind ? 0 : head->count));
 	if (!expr) return NULL;
 	lv2->value = expr;
 
@@ -4747,13 +4748,14 @@ Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_d
       Scheme_Object *body;
       Scheme_Compiled_Let_Value *lv = NULL;
       int i;
+      int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
 
       /* Build let-value change: */
       body = head->body;
       for (i = head->num_clauses; i--; ) {
 	lv = (Scheme_Compiled_Let_Value *)body;
 
-	expr = scheme_optimize_shift(lv->value, delta, after_depth + head->count);
+	expr = scheme_optimize_shift(lv->value, delta, after_depth + (post_bind ? 0 : head->count));
 	lv->value = expr;
 
         body = lv->body;

src/racket/src/schpriv.h

@@ -1073,6 +1073,46 @@ typedef struct {
   struct Resolve_Prefix *prefix;
 } Scheme_Compilation_Top;
 
+/* A `let', `let*', or `letrec' form is compiled to the intermediate
+   format (used during the optimization pass) as a Scheme_Let_Header
+   with a chain of Scheme_Compiled_Let_Value records as its body,
+   where there's one Scheme_Compiled_Let_Value for each binding
+   clause. A `let*' is normally expanded to nested `let's before
+   compilation, but the intermediate format also supposrts `let*',
+   which is useful mostly for converting a simple enough `letrec' form
+   into `let*.
+
+   The body of the `let...' form is the body of the innermost
+   Scheme_Compiled_Let_Value record. Obviously, all N bindings of a
+   `let...' form are pushed onto the virtual stack for the body, but
+   the situation is more complex for the binding right-hand
+   sides. There are three cases:
+
+    * Plain `let': no bindings are pushed, yet. (This is in contrast
+      to the convention for the final bytecode format, where space for
+      the binding is allocated before the right-hand side is
+      evaluated.)
+
+    * `letrec': all bindings are pushed; the first clause is pushed
+      first, etc.
+
+    * `let*' can be like `letrec', but also can have the bindings in
+      reverse order; that is, all bindings are pushed before any
+      right-hand side, but the last binding may be pushed first
+      instead of last.
+*/
+
+typedef struct Scheme_Let_Header {
+  Scheme_Inclhash_Object iso; /* keyex used for recursive */
+  mzshort count;       /* total number of bindings */
+  mzshort num_clauses; /* number of binding clauses */
+  Scheme_Object *body;
+} Scheme_Let_Header;
+
+#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
+#define SCHEME_LET_RECURSIVE 0x1
+#define SCHEME_LET_STAR 0x2
+
 typedef struct Scheme_Compiled_Let_Value {
   Scheme_Inclhash_Object iso; /* keyex used for set-starting */
   mzshort count;
@@ -1086,17 +1126,6 @@ typedef struct Scheme_Compiled_Let_Value {
 #define SCHEME_CLV_NO_GROUP_LATER_USES 0x1
 #define SCHEME_CLV_NO_GROUP_USES 0x2
 
-typedef struct Scheme_Let_Header {
-  Scheme_Inclhash_Object iso; /* keyex used for recursive */
-  mzshort count;
-  mzshort num_clauses;
-  Scheme_Object *body;
-} Scheme_Let_Header;
-
-#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
-#define SCHEME_LET_RECURSIVE 0x1
-#define SCHEME_LET_STAR 0x2
-
 typedef struct {
   Scheme_Object so;
   Scheme_Object *key;
@@ -2613,6 +2642,7 @@ int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos);
 #define SCHEME_FOR_INTDEF 256
 #define SCHEME_CAPTURE_LIFTED 512
 #define SCHEME_INTDEF_SHADOW 1024
+#define SCHEME_POST_BIND_FRAME 2048
 
 /* Flags used with scheme_static_distance */
 #define SCHEME_ELIM_CONST 1

src/racket/src/syntax.c

@@ -3055,12 +3055,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
   int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage, split_shift, skip_opts = 0;
   int size_before_opt, did_set_value;
   int remove_last_one = 0, inline_fuel, rev_bind_order;
+  int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
 
 # define pos_EARLIER(a, b) (rev_bind_order ? ((a) > (b)) : ((a) < (b)))
 
   if (context & OPT_CONTEXT_BOOLEAN) {
     /* Special case: (let ([x M]) (if x x N)), where x is not in N,
-       to (if M #t #f), since we're in a test position. */
+       to (if M #t N), since we're in a test position. */
     if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
       clv = (Scheme_Compiled_Let_Value *)head->body;
       if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
@@ -3077,16 +3078,28 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           b3->so.type = scheme_branch_type;
           b3->test = clv->value;
           b3->tbranch = scheme_true;
+          if (post_bind) {
+            /* still need a `let' around N: */
+            b3->fbranch = (Scheme_Object *)head;
+            clv->value = scheme_false;
+            clv->flags[0] = 0; /* variable now unused */
+            clv->body = b->fbranch;
+          } else {
             b3->fbranch = b->fbranch;
+          }
 
+          if (post_bind)
+            sub_info = info;
+          else
             sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
 	
           form = scheme_optimize_expr((Scheme_Object *)b3, sub_info, context);
 
+          if (!post_bind) {
             info->single_result = sub_info->single_result;
             info->preserves_marks = sub_info->preserves_marks;
-
             scheme_optimize_info_done(sub_info);
+          }
 
           return form;
         }
@@ -3102,8 +3115,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
     if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
         && (((Scheme_Local *)clv->body)->position == 0)) {
       if (worth_lifting(clv->value)) {
-        if (for_inline) {
+        if (post_bind) {
-	  /* Just drop the inline-introduced let */
+	  /* Just drop the let */
 	  return scheme_optimize_expr(clv->value, info, context);
 	} else {
 	  info = scheme_optimize_info_add_frame(info, 1, 0, 0);
@@ -3119,6 +3132,29 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
 
   is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
 
+#if 0
+  if (!is_rec) {
+    /* (let ([x (let ([y M]) N)]) P) => (let ([y M]) (let ([x N]) P)) */
+    if (head->count == 1) {
+      clv = (Scheme_Compiled_Let_Value *)head->body; /* ([x ...]) */
+      if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_let_void_type)) {
+        Scheme_Let_Header *lh = (Scheme_Let_Header *)clv->value; /* (let ([y ...]) ...) */
+        if (!(SCHEME_LET_FLAGS(lh) & SCHEME_LET_RECURSIVE)
+            && (lh->count == 1)) {
+          value = ((Scheme_Compiled_Let_Value *)lh->body)->body; /* = N */
+          ((Scheme_Compiled_Let_Value *)lh->body)->body = (Scheme_Object *)head;
+          clv->value = value;
+          head = lh;
+          form = (Scheme_Obejct *)head;
+
+          orig_info = info;
+          info = scheme_optimize_info_add_frame(info, 1, 0, 0);
+        }
+      }
+    }
+  }
+#endif
+
   split_shift = 0;
   if (is_rec) {
     /* Check whether we should break a prefix out into its own
@@ -3163,9 +3199,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
     }
   }
 
-  body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
+  body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 
-  if (for_inline) {
+                                             post_bind ? SCHEME_POST_BIND_FRAME : 0);
-    rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
+  if (post_bind) {
+    rhs_info = scheme_optimize_info_add_frame(info, 0, 0, 0);
+    if (for_inline)
       body_info->inline_fuel >>= 1;
   } else if (split_shift)
     rhs_info = scheme_optimize_info_add_frame(body_info, split_shift, 0, 0);
@@ -3416,9 +3454,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           value = NULL;
         else {
           /* Convert value back to a pre-optimized local coordinates.
-             This must be done with respect to body_info, not
+             Unless post_bind, this must be done with respect to
-             rhs_info, because we attach the value to body_info: */
+             body_info, not rhs_info, because we attach the value to
-          value = scheme_optimize_reverse(body_info, vpos, 1);
+             body_info: */
+          value = scheme_optimize_reverse(post_bind ? rhs_info : body_info, vpos, 1);
           
           /* Double-check that the value is ready, because we might be
              nested in the RHS of a `letrec': */
@@ -3449,7 +3488,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           if (cnt == 1) {
             /* used only once; we may be able to shift the expression to the use
                site, instead of binding to a temporary */
-            last_once_used = scheme_make_once_used(value, pos, body_info->vclock, last_once_used);
+            last_once_used = scheme_make_once_used(value, pos, rhs_info->vclock, last_once_used);
             if (!first_once_used) first_once_used = last_once_used;
             scheme_optimize_propagate(body_info, pos, (Scheme_Object *)last_once_used, 1);
           }
@@ -3604,7 +3643,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
     body = pre_body->body;
   }
 
-  if (for_inline) {
+  if (post_bind) {
     body_info->size = rhs_info->size;
     body_info->vclock = rhs_info->vclock;
   }
@@ -3715,6 +3754,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
             value = body;
             extract_depth = head->count;
             rhs_info = body_info;
+            post_bind = 0;
           }
         }
       }
@@ -3724,7 +3764,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
       value = scheme_optimize_clone(1, value, rhs_info, 0, 0);
 
       if (value) {
-        sub_info = scheme_optimize_info_add_frame(info, extract_depth, 0, 0);
+        sub_info = scheme_optimize_info_add_frame(info, post_bind ? 0 : extract_depth, 0, 0);
         sub_info->inline_fuel = 0;
         value = scheme_optimize_expr(value, sub_info, context);
         info->single_result = sub_info->single_result;
@@ -3830,7 +3870,7 @@ static Scheme_Object *drop_zero_value_return(Scheme_Object *expr)
 Scheme_Object *
 scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
 {
-  Resolve_Info *linfo, *val_linfo;
+  Resolve_Info *linfo, *val_linfo = NULL;
   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
   Scheme_Compiled_Let_Value *clv, *pre_body;
   Scheme_Let_Value *lv, *last = NULL;
@@ -3844,6 +3884,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   int max_let_depth = 0;
   int resolve_phase, num_skips;
   Scheme_Object **lifted_recs;
+  int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
 
   /* Find body: */
   body = head->body;
@@ -3967,19 +4008,25 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
 	/* The mapping is complicated because we now push in the order of 
 	   the variables, but it may have been compiled using the inverse order. */
         frame_size = i + 1 - skip_count;
-        linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
-	for (j = i, k = 0; j >= 0; j--) {
         if (lifts_frame_size != frame_size) {
           /* We need to shift coordinates for any lifted[j] that is a
              converted procedure. */
+          for (j = i, k = 0; j >= 0; j--) {
             shift_lift(lifted[j], frame_size, lifts_frame_size);
           }
+        }
+        if (post_bind) {
+          linfo = scheme_resolve_info_extend(info, frame_size, 0, 0);
+        } else {
+          linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
+          for (j = i, k = 0; j >= 0; j--) {
             n = (rev_bind_order ? (head->count - j - 1) : j);
             if (skips[j])
               scheme_resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]);
             else
               scheme_resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]);
           }
+        }
         lifts_frame_size = frame_size;
 
         if (skips[i]) {
@@ -4154,6 +4201,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
       lifted_recs = NULL;
     }
     
+    if (post_bind)
+      val_linfo = scheme_resolve_info_extend(info, head->count - num_skips, 0, 0);
+    else
+      val_linfo = linfo;
+
     /* Build mapping of compile-time indices to run-time indices, shuffling
        letrecs to fall together in the shallowest part. Also determine
        and initialize lifts for recursive procedures. Generating lift information
@@ -4231,7 +4283,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
             old_lift = lifted_recs[rpos];
             old_convert_count = get_convert_arg_count(old_lift);
 
-            lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 1, 
+            lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 1, 
                                                       (resolve_phase ? NULL : old_lift));
 
             if (is_closed_reference(lift)
@@ -4275,7 +4327,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
             Scheme_Object *lift;
             lift = lifted_recs[rpos];
             if (is_closed_reference(lift)) {
-              (void)scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, lift);
+              (void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lift);
               /* lift is the final result; this result might be
                  referenced in the body of closures already, or in
                  not-yet-closed functions.  If no one uses the result
@@ -4283,7 +4335,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
                  GCed. */
               clv->value = NULL; /* inidicates that there's nothing more to do with the expr */
             } else {
-              lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 2, NULL);
+              lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 2, NULL);
               /* need to resolve one more time for the body of the lifted function */
             }
             scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift);
@@ -4298,7 +4350,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   }
 
   extra_alloc = 0;
-  val_linfo = linfo;
 
   if (num_rec_procs) {
     if (!lifted_recs) {
@@ -4498,6 +4549,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
 
   if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc)
     info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc;
+  if (val_linfo)
+    if (info->max_let_depth < val_linfo->max_let_depth + head->count - num_skips + extra_alloc)
+      info->max_let_depth = val_linfo->max_let_depth + head->count - num_skips + extra_alloc;
   
   return first;
 }
@@ -4509,13 +4563,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
 {
   Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname;
   int num_clauses, num_bindings, i, j, k, m, pre_k;
-  Scheme_Comp_Env *frame, *env;
+  Scheme_Comp_Env *frame, *env, *rhs_env;
   Scheme_Compile_Info *recs;
   Scheme_Object *first = NULL;
   Scheme_Compiled_Let_Value *last = NULL, *lv;
   DupCheckRecord r;
   int rec_env_already = rec[drec].env_already;
   int rev_bind_order = recursive;
+  int post_bind = !recursive && !star;
 
   i = scheme_stx_proper_list_length(form);
   if (i < 3)
@@ -4593,6 +4648,10 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
       frame_already = frame;
   }
   env = frame;
+  if (post_bind)
+    rhs_env = scheme_no_defines(origenv);
+  else
+    rhs_env = env;
 
   recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
 
@@ -4691,7 +4750,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
       rhs = SCHEME_STX_CDR(binding);
       rhs = SCHEME_STX_CAR(rhs);
       rhs = scheme_add_env_renames(rhs, env, origenv);
-      ce = scheme_compile_expr(rhs, env, recs, i);
+      ce = scheme_compile_expr(rhs, rhs_env, recs, i);
       lv->value = ce;
     } else {
       Scheme_Object *rhs;