fix interaction between copy prop and once-used binding elimination

in the bytecode compiler, which could cause an expression to be
 duplicated

collects/tests/racket/optimize.rktl

@@ -831,6 +831,57 @@
               (- x 8))
            '(- (+ (cons 1 2) 0) 8))
 
+(test-comp '(let ([x (peek-char)])
+              (cons x 10))
+           '(cons (peek-char) 10))
+
+(test-comp '(let ([x (peek-char)])
+              (let ([y x])
+                (cons y 10)))
+           '(cons (peek-char) 10))
+
+(test-comp '(lambda (x)
+              (let ([y x])
+                (cons y 10)))
+           '(lambda (x) (cons x 10)))
+
+(test-comp '(lambda (x)
+              (let ([y x])
+                (cons y y)))
+           '(lambda (x) (cons x x)))
+
+(test-comp '(let ([f (lambda (x)
+                       (let ([y x])
+                         (cons y y)))])
+              (f (peek-char)))
+           '(let ([y (peek-char)])
+              (cons y y)))
+
+(test-comp '(let ([g (lambda (f)
+                       ;; Try to get uses of `z' replaced by `x',
+                       ;; but before `x' and `y' are split apart.
+                       ;; Single-use tracking of `x' can go wrong.
+                       (let-values ([(x y) (f (cons 1 2)
+                                              (cons 3 4))])
+                         (let ([z x])
+                           (list z z y))))])
+              (g values))
+           '(let ([x (cons 1 2)]
+                  [y (cons 3 4)])
+              (list x x y)))
+
+(test-comp '(let ([g (lambda (f)
+                       (letrec-values ([(x y) (f (cons 1 2)
+                                                 (cons 3 4))])
+                         (let ([z x])
+                           (list z z y))))])
+              (g values))
+           '(let ([g (lambda (f)
+                       (letrec-values ([(x y) (f (cons 1 2)
+                                                 (cons 3 4))])
+                         (list x x y)))])
+              (g values)))
+
 (test-comp '(let-values ([(x y) (values 1 2)])
               (+ x y))
            3)

src/racket/src/env.c

@@ -3648,7 +3648,8 @@ int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
 }
 
 static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, 
-                                              int *not_ready, int once_used_ok, int context, int *potential_size)
+                                              int *not_ready, int once_used_ok, int context, int *potential_size,
+                                              int disrupt_single_use)
 {
   Scheme_Object *p, *n;
   int delta = 0;
@@ -3701,10 +3702,17 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
       } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) {
         Scheme_Once_Used *o;
 
+        if (disrupt_single_use) {
+          ((Scheme_Once_Used *)n)->expr = NULL;
+          ((Scheme_Once_Used *)n)->vclock = -1;
+        }
+
         if (!once_used_ok)
           break;
 
         o = (Scheme_Once_Used *)n;
+        if (!o->expr) break; /* disrupted or not available */
+
         o->delta = delta;
         o->info = info;
         return (Scheme_Object *)o;
@@ -3726,13 +3734,23 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
             single_use = NULL;
         }
 
-	n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, 0, context, potential_size);
+        /* If the referenced variable is not single-use, then
+           the variable it is replaced by is no longer single-use */
+        disrupt_single_use = !SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]);
+
+	n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL,
+                                    once_used_ok && !disrupt_single_use, context, 
+                                    potential_size, disrupt_single_use);
 
 	if (!n) {
 	  /* Return shifted reference to other local: */
 	  delta += scheme_optimize_info_get_shift(info, pos);
 	  n = scheme_make_local(scheme_local_type, pos + delta, 0);
-	}
+	} else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) {
+          /* Need to adjust delta: */
+          delta = scheme_optimize_info_get_shift(info, pos);
+          ((Scheme_Once_Used *)n)->delta += delta;
+        }
       }
       return n;
     }
@@ -3748,14 +3766,14 @@ 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, 
                                            int once_used_ok, int context, int *potential_size)
 {
-  return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context, potential_size);
+  return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context, potential_size, 0);
 }
 
 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, 0, 0, NULL);
+  do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0, NULL, 0);
 
   return ready;
 }

src/racket/src/eval.c

@@ -4359,8 +4359,11 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
               return scheme_optimize_expr(val, info, context);
             }
           }
-          /* Can't move expression, so lookup again to mark as used. */
+          /* Can't move expression, so lookup again to mark as used
-          (void)scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, context, NULL);
+             and to perform any copy propagation that might apply. */
+          val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, context, NULL);
+          if (val)
+            return val;
         } else {
           if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) {
             info->size -= 1;

src/racket/src/fun.c

@@ -1025,7 +1025,8 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, i
   Scheme_Object *code, *ctx;
   Closure_Info *cl;
   mzshort dcs, *dcm;
-  int i;
+  int i, cnt;
+  Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL;
 
   data = (Scheme_Closure_Data *)_data;
 
@@ -1051,6 +1052,13 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, i
   for (i = 0; i < data->num_params; i++) {
     if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
       scheme_optimize_mutated(info, i);
+    
+    cnt = ((cl->local_flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
+    if (cnt == 1) {
+      last_once_used = scheme_make_once_used(NULL, i, info->vclock, last_once_used);
+      if (!first_once_used) first_once_used = last_once_used;
+      scheme_optimize_propagate(info, i, (Scheme_Object *)last_once_used, 1);
+    }
   }
 
   code = scheme_optimize_expr(data->code, info, 0);
@@ -1060,6 +1068,14 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, i
       cl->local_flags[i] |= SCHEME_WAS_FLONUM_ARGUMENT;
   }
 
+  while (first_once_used) {
+    if (first_once_used->vclock < 0) {
+      /* no longer used once, due to binding propagation */
+      cl->local_flags[first_once_used->pos] |= SCHEME_USE_COUNT_MASK;
+    }
+    first_once_used = first_once_used->next;
+  }
+
   if (info->single_result)
     SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT;
   else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)

src/racket/src/syntax.c

@@ -3091,9 +3091,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
   Scheme_Let_Header *head = (Scheme_Let_Header *)form;
   Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
   Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
-  Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL;
+  Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL, *once_used;
   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 size_before_opt, did_set_value, checked_once;
   int remove_last_one = 0, inline_fuel, rev_bind_order;
   int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
 
@@ -3460,6 +3460,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           pre_body = naya;
           body = (Scheme_Object *)naya;
           value = pre_body->value;
+          pos = pre_body->position;
         } else {
           /* We've dropped this clause entirely. */
           i++;
@@ -3472,6 +3473,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
       }
     }
 
+    checked_once = 0;
+
     if ((pre_body->count == 1)
 	&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
       int indirect = 0, indirect_binding = 0;
@@ -3536,6 +3539,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
 
         scheme_optimize_propagate(body_info, pos, value, cnt == 1);
 	did_set_value = 1;
+        checked_once = 1;
       } else if (value && !is_rec) {
         int cnt;
 
@@ -3543,13 +3547,38 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           scheme_optimize_produces_flonum(body_info, pos);
         
         if (!indirect) {
+          checked_once = 1;
           cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
           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, rhs_info->vclock, last_once_used);
+            once_used = scheme_make_once_used(value, pos, rhs_info->vclock, NULL);
-            if (!first_once_used) first_once_used = last_once_used;
+            if (!last_once_used)
-            scheme_optimize_propagate(body_info, pos, (Scheme_Object *)last_once_used, 1);
+              first_once_used = once_used;
+            else
+              last_once_used->next = once_used;
+            last_once_used = once_used;
+            scheme_optimize_propagate(body_info, pos, (Scheme_Object *)once_used, 1);
+          }
+        }
+      }
+    }
+
+    if (!checked_once) {
+      /* Didn't handle once-used check in case of copy propagation, so check here. */
+      int i, cnt;
+      for (i = pre_body->count; i--; ) {
+        if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) {
+          cnt = ((pre_body->flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
+          if (cnt == 1) {
+            /* Need to register as once-used, in case of copy propagation */
+            once_used = scheme_make_once_used(NULL, pos+i, rhs_info->vclock, NULL);
+            if (!last_once_used)
+              first_once_used = once_used;
+            else
+              last_once_used->next = once_used;
+            last_once_used = once_used;
+            scheme_optimize_propagate(body_info, pos+i, (Scheme_Object *)once_used, 1);
           }
         }
       }
@@ -3729,25 +3758,26 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
     pre_body = (Scheme_Compiled_Let_Value *)body;
     pos = pre_body->position;
 
-    while (first_once_used && pos_EARLIER(first_once_used->pos, pos)) {
-      first_once_used = first_once_used->next;
-    }
-
     for (j = pre_body->count; j--; ) {
       if (scheme_optimize_is_used(body_info, pos+j)) {
         used = 1;
         break;
       }
     }
+
     if (!used
         && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1)
-            || (first_once_used
+            || ((pre_body->count == 1)
+                && first_once_used
                 && (first_once_used->pos == pos) 
                 && first_once_used->used))) {
       for (j = pre_body->count; j--; ) {
         if (pre_body->flags[j] & SCHEME_WAS_USED) {
           pre_body->flags[j] -= SCHEME_WAS_USED;
         }
+
+        if (first_once_used && (first_once_used->pos == (pos + j)))
+          first_once_used = first_once_used->next;
       }
       if (pre_body->count == 1) {
         /* Drop expr and deduct from size to aid further inlining. */
@@ -3761,6 +3791,14 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         pre_body->flags[j] |= SCHEME_WAS_USED;
         if (scheme_optimize_is_flonum_arg(body_info, pos+j, 0))
           pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT;          
+
+        if (first_once_used && (first_once_used->pos == (pos+j))) {
+          if (first_once_used->vclock < 0) {
+            /* single-use no longer true, due to copy propagation */
+            pre_body->flags[j] |= SCHEME_USE_COUNT_MASK;
+          }
+          first_once_used = first_once_used->next;
+        }
       }
       info->size += 1;
     }