bytecode compiler: break up and improve comments at final let step

racket/src/racket/src/resolve.c

@@ -25,11 +25,11 @@
 
 /* This file implements the bytecode "resolve" pass, which converts
    the optimization IR to the evaluation bytecode --- where the main
-   difference between the representations is to use stack addresses. This
+   difference between the representations is to use stack addresses.
-   pass is also responsible for closure conversion (in the sense of
+   This pass is also responsible for closure conversion: lifting
-   lifting closures that are used only in application positions where
+   functions that are used only in application positions, where all
-   all variables captured by the closure can be converted to arguments
+   variables captured by the closure can be converted to arguments at
-   at all call sites).
+   every call site.
 
    The "unresolve" functions convert run-time bytecode back into the
    optimizer's IR, which is used for cross-module inlining and for
@@ -113,6 +113,9 @@ void scheme_init_resolve()
 
 static Scheme_Object *check_converted_rator(Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator,
                                             int orig_arg_cnt, int *_rdelta)
+/* Check whether `rator` refers to a function that has been lifted and
+   changed to accept extra arguments, in which case the application
+   needs to be adjusted with the extra arguments. */
 {
   Scheme_Object *lifted;
 
@@ -338,6 +341,7 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_
 }
 
 static void set_app3_eval_type(Scheme_App3_Rec *app)
+/* set flags used for a shortcut in the interpreter */
 {
   short et;
 
@@ -860,6 +864,7 @@ static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info
 /*========================================================================*/
 
 static int is_lifted_reference(Scheme_Object *v)
+/* check whether `v` is a reference to a lifted function */
 {
   if (SCHEME_RPAIRP(v))
     return 1;
@@ -937,36 +942,18 @@ static Scheme_Object *drop_zero_value_return(Scheme_Object *expr)
 
 #define HAS_UNBOXABLE_TYPE(var) ((var)->val_type && (!(var)->escapes_after_k_tick || ALWAYS_PREFER_UNBOX_TYPE((var)->val_type)))
 
-Scheme_Object *
+static int check_need_boxed_letrec_rhs(Scheme_IR_Let_Header *head, Scheme_Hash_Tree *binding_vars, Resolve_Info *info,
-scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
+                                       int *_num_rec_procs, int *_rec_proc_nonapply)
+/* Check whether a `let`+`set!` is needed to implement a set of `letrec` bindings;
+   the result is true if so, otherwise report the number of bindings that are
+   functions for a function-only `letrec`. Set `_rec_proc_nonapply` if any binding
+   is used in a non-application position, since that will disable lifting for
+   closure conversion. */
 {
-  Resolve_Info *linfo;
+  int recbox = 0;
-  Scheme_IR_Let_Header *head = (Scheme_IR_Let_Header *)form;
+  Scheme_IR_Let_Value *irlv;
-  Scheme_IR_Let_Value *irlv, *pre_body;
+  int i;
-  Scheme_Let_Value *lv, *last = NULL;
-  Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL;
-  Scheme_Letrec *letrec;
-  Scheme_Object *boxes;
-  int i, j, pos, rpos, recbox, num_rec_procs = 0, extra_alloc;
-  int rec_proc_nonapply = 0;
-  int resolve_phase, num_skips, lifted_recs;
-  Scheme_Hash_Tree *lift_exclude_vars;
 
-  /* Find body and make a set of local bindings: */
-  body = head->body;
-  pre_body = NULL;
-  lift_exclude_vars = scheme_make_hash_tree(0);
-  for (i = head->num_clauses; i--; ) {
-    pre_body = (Scheme_IR_Let_Value *)body;
-    for (j = 0; j < pre_body->count; j++) {
-      lift_exclude_vars = scheme_hash_tree_set(lift_exclude_vars, (Scheme_Object *)pre_body->vars[j], scheme_true);
-    }
-    body = pre_body->body;
-  }
-
-  recbox = 0;
-  if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) {
-    /* Do we need to box vars in a letrec? */
   irlv = (Scheme_IR_Let_Value *)head->body;
   for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
     int is_proc, is_lift;
@@ -987,7 +974,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
       else if (SCHEME_IRLV_FLAGS(irlv) & SCHEME_IRLV_NO_GROUP_USES)
         is_lift = 1;
       else
-          is_lift = scheme_is_liftable(irlv->value, lift_exclude_vars, 5, 1, 0);
+        is_lift = scheme_is_liftable(irlv->value, binding_vars, 5, 1, 0);
 
       if (!is_proc && !is_lift) {
         recbox = 1;
@@ -1006,10 +993,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
           if (recbox)
             break;
 
-            if (is_nonconstant_procedure(irlv->value, info, lift_exclude_vars)) {
+          if (is_nonconstant_procedure(irlv->value, info, binding_vars)) {
-              num_rec_procs++;
+            (*_num_rec_procs)++;
             if (irlv->vars[0]->non_app_count)
-                rec_proc_nonapply = 1;
+              *_rec_proc_nonapply = 1;
           }
         }
       }
@@ -1017,21 +1004,19 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   }
 
   if (recbox)
-      num_rec_procs = 0;
+    *_num_rec_procs = 0;
-  } else {
-    /* Sequence of single-value, non-assigned lets? */
 
-    irlv = (Scheme_IR_Let_Value *)head->body;
+  return recbox;
-    for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
-      if (irlv->count != 1)
-	break;
-      if (irlv->vars[0]->mutated)
-	break;
 }
 
-    if (i < 0) {
+static Scheme_Object *build_let_one_chain(Scheme_IR_Let_Header *head, Scheme_Object *body, Resolve_Info *info)
-      /* Yes - build chain of Scheme_Let_Ones and we're done: */
+/* Build a chain of Scheme_Let_One records for a simple binding set */
-      int j, num_frames;
+{
+  Scheme_IR_Let_Value *irlv;
+  Scheme_Let_Value *last = NULL;
+  Scheme_Object *first = NULL;
+  int i, j, num_frames;
+  Resolve_Info *linfo;
 
   j = head->num_clauses;
 
@@ -1114,11 +1099,12 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   }
 
   return first;
-    } else {
+}
-      /* Maybe some multi-binding lets, but all of them are unused
+
-         and the RHSes are omittable? This can happen with auto-generated
+static int all_unused_and_omittable(Scheme_IR_Let_Header *head)
-         code. */
+{
-      int j, any_used = 0;
+  Scheme_IR_Let_Value *irlv;
+  int i, j, any_used = 0;
 
   irlv = (Scheme_IR_Let_Value *)head->body;
   for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
@@ -1135,26 +1121,25 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
     } else
       any_used = 1;
   }
-      if (!any_used) {
+
-        /* All unused and omittable */
+  return !any_used;
-        return scheme_resolve_expr((Scheme_Object *)irlv, info);
-      }
-    }
-  }
-
-  num_skips = 0;
-  irlv = (Scheme_IR_Let_Value *)head->body;
-  for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
-    if ((irlv->count == 1) && irlv->vars[0]->resolve_omittable) {
-      num_skips++;
-    } 
 }
 
+static Resolve_Info *compute_possible_lifts(Scheme_IR_Let_Header *head, Resolve_Info *info, Scheme_Hash_Tree *binding_vars,
+                                            int recbox, int num_skips, int num_rec_procs, int rec_proc_nonapply,
+                                            GC_CAN_IGNORE int *_lifted_recs)
 /* First assume that all letrec-bound procedures can be lifted to empty closures.
    Then try assuming that all letrec-bound procedures can be at least lifted.
-     Then fall back to assuming no lifts. */
+   Then fall back to assuming no lifts.
+   Returns a resolve frame that is set up with lift decisions, and sets
+   `_lifted_recs` to indicate the number of lifted functions. */
+{
+  int resolve_phase;
+  Resolve_Info *linfo;
+  int i, pos, rpos, lifted_recs = 0;
+  Scheme_IR_Let_Value *irlv;
   
-  linfo = 0;
+  linfo = NULL;
   for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply && !info->no_lift) ? 0 : 2); 
        resolve_phase < 3; 
        resolve_phase++) {
@@ -1172,8 +1157,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
       lifted_recs = 0;
     }
 
-    /* Build mapping to run-time indices, shuffling
+    /* Shuffle procedure letrecs to fall together in the shallowest part. Also determine
-       letrecs to fall together in the shallowest part. Also determine
        and initialize lifts for recursive procedures. Generating lift information
        requires an iteration. */
     irlv = (Scheme_IR_Let_Value *)head->body;
@@ -1196,7 +1180,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
 
           if (num_rec_procs
               && (irlv->count == 1)
-              && is_nonconstant_procedure(irlv->value, info, lift_exclude_vars)) {
+              && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
             MZ_ASSERT(!recbox);
             if (resolve_phase == 0)
               lift = scheme_resolve_generate_stub_closure();
@@ -1238,7 +1222,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
               && irlv->vars[0]->resolve_omittable) {
             /* skipped */
           } else if ((irlv->count == 1)
-                     && is_nonconstant_procedure(irlv->value, info, lift_exclude_vars)) {
+                     && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
             Scheme_Object *lift, *old_lift;
             int old_convert_count;
             Scheme_Object *old_convert_map, *convert_map;
@@ -1294,7 +1278,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
               && !irlv->vars[0]->optimize_used
               && irlv->vars[0]->resolve_omittable) {
             /* skipped */
-          } else if ((irlv->count == 1) && is_nonconstant_procedure(irlv->value, info, lift_exclude_vars)) {
+          } else if ((irlv->count == 1) && is_nonconstant_procedure(irlv->value, info, binding_vars)) {
             Scheme_Object *lift;
             lift = irlv->vars[0]->resolve.lifted;
             if (is_closed_reference(lift)) {
@@ -1318,10 +1302,99 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
     }
   }
 
+  *_lifted_recs = lifted_recs;
+
+  return linfo;
+}
+
+Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
+/* Convert a Scheme_IR_Let_Header plus Scheme_IR_Let_Value records
+   into either a sequence of Scheme_Let_One records or Scheme_Let_Void
+   plus either Scheme_Letrec or Scheme_Let_Value records. Also, check
+   whether functions that are locally bound can be lifted through
+   closure conversion. The closure-conversion step may require
+   iteration to a fixpoint to determine whether a set of
+   mutually-referential functions can be lifted together, and whether
+   they must be lifted to the top level or module level (bacsue they
+   refer to other top-level or module-level bindings) or whether they
+   can be converted to constant empty closures. */
+{
+  Resolve_Info *linfo;
+  Scheme_IR_Let_Header *head = (Scheme_IR_Let_Header *)form;
+  Scheme_IR_Let_Value *irlv, *pre_body;
+  Scheme_Let_Value *lv, *last = NULL;
+  Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL;
+  Scheme_Letrec *letrec;
+  Scheme_Object *boxes;
+  int i, j, rpos, recbox, num_rec_procs = 0, extra_alloc;
+  int rec_proc_nonapply = 0;
+  int num_skips, lifted_recs;
+  Scheme_Hash_Tree *binding_vars;
+
+  /* Find body and make a set of local bindings: */
+  body = head->body;
+  pre_body = NULL;
+  binding_vars = scheme_make_hash_tree(0);
+  for (i = head->num_clauses; i--; ) {
+    pre_body = (Scheme_IR_Let_Value *)body;
+    for (j = 0; j < pre_body->count; j++) {
+      binding_vars = scheme_hash_tree_set(binding_vars, (Scheme_Object *)pre_body->vars[j], scheme_true);
+    }
+    body = pre_body->body;
+  }
+
+  recbox = 0;
+  if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) {
+    /* Do we need to box vars in a letrec? */
+    recbox = check_need_boxed_letrec_rhs(head, binding_vars, info,
+                                         &num_rec_procs, &rec_proc_nonapply);
+  } else {
+    /* Sequence of single-value, non-assigned lets? */
+
+    irlv = (Scheme_IR_Let_Value *)head->body;
+    for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
+      if (irlv->count != 1)
+	break;
+      if (irlv->vars[0]->mutated)
+	break;
+    }
+
+    if (i < 0) {
+      /* Yes - build chain of Scheme_Let_Ones and we're done: */
+      return build_let_one_chain(head, body, info);
+    } else {
+      /* Maybe some multi-binding lets, but all of them are unused and
+         the RHSes are omittable? This can happen with auto-generated
+         code. Checking has the side effect of setting
+         `resolve_omittable` fields. */
+      if (all_unused_and_omittable(head)) {
+        /* All unused and omittable */
+        return scheme_resolve_expr(body, info);
+      }
+    }
+  }
+
+  /* Count number of right-hand sides to be skipped entirely */
+  num_skips = 0;
+  irlv = (Scheme_IR_Let_Value *)head->body;
+  for (i = head->num_clauses; i--; irlv = (Scheme_IR_Let_Value *)irlv->body) {
+    if ((irlv->count == 1) && irlv->vars[0]->resolve_omittable) {
+      num_skips++;
+    }
+  }
+
+  /* Compute lifts */
+  linfo = compute_possible_lifts(head, info, binding_vars,
+                                 recbox, num_skips, num_rec_procs, rec_proc_nonapply,
+                                 &lifted_recs);
+
   extra_alloc = 0;
   
   if (num_rec_procs) {
     if (!lifted_recs) {
+      /* Since we didn't lift, prepare a frame for function-only
+         `letrec`; non-function bindings will be put in additional
+         Scheme_Let_Value steps. */
       Scheme_Object **sa;
       letrec = MALLOC_ONE_TAGGED(Scheme_Letrec);
       letrec->so.type = scheme_letrec_type;
@@ -1335,7 +1408,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   } else
     letrec = NULL;
 
-  /* Resolve values: */
+  /* Resolve right-hand sides: */
   boxes = scheme_null;
   irlv = (Scheme_IR_Let_Value *)head->body;
   rpos = 0;
@@ -1350,7 +1423,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
       if (!irlv->value)
         isproc = 1;
       else if (irlv->count == 1)
-        isproc = is_nonconstant_procedure(irlv->value, info, lift_exclude_vars);
+        isproc = is_nonconstant_procedure(irlv->value, info, binding_vars);
       else
         isproc = 0;
       if (num_rec_procs && isproc) {
@@ -1472,6 +1545,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
     boxes = SCHEME_CDR(boxes);
   }
 
+  /* Link up function-only `letrec` and Scheme_Let_Values chain */
   if (letrec) {
     letrec->body = body;
     if (last)
@@ -1491,6 +1565,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   else
     first = body;
 
+  /* Check one last time for a simplification: */
   if (head->count + extra_alloc - num_skips) {
     int cnt;
 
@@ -1532,7 +1607,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
 }
 
 /*========================================================================*/
-/*                             closures                                   */
+/*                               lambda                                   */
 /*========================================================================*/
 
 XFORM_NONGCING int scheme_boxmap_size(int n)