fix bytecode compiler bugs in tracking known-flonum arguments

collects/tests/racket/optimize.rktl

@@ -1363,6 +1363,25 @@
                         ((proc 98)
                          x)))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that an unboxable flonum argument 
+;; is not incorrectly inferred:
+
+(test '(done)
+      'unboxing-inference-test
+      (let ()
+        (define (f x y)
+          (if (zero? y)
+              ;; prevents inlining:
+              '(done)
+              (if (zero? y)
+                  ;; incorrectly triggered unboxing, 
+                  ;; once upon a time:
+                  (fl+ x 1.0) 
+                  ;; not a float argument => no unboxing of x:
+                  (f y (sub1 y)))))
+        (f 1.0 100)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

src/racket/src/eval.c

@@ -2814,14 +2814,14 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec
               if (!map) {
                 map = MALLOC_N_ATOMIC(char, n);
                 memset(map, 1, n);
+                memset(map, 0, i);
               }
             }
             if (map && !is_flonum)
               map[i] = 0;
           }
 
-          if (map)
+          scheme_set_closure_flonum_map(data, map);
-            scheme_set_closure_flonum_map(data, map);
         }
       }
     }

src/racket/src/fun.c

@@ -1143,12 +1143,41 @@ void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map)
     cl->flonum_map = flonum_map;
   }
   
-  for (i = data->num_params; i--; ) {
+  if (flonum_map) {
-    if (flonum_map[i]) break;
+    for (i = data->num_params; i--; ) {
+      if (flonum_map[i]) break;
+    }
+    
+    if (i < 0) {
+      cl->flonum_map = NULL;
+    }
   }
+}
 
-  if (i < 0) {
+void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2)
-    cl->flonum_map = NULL;
+{
+  Closure_Info *cl1 = (Closure_Info *)data1->closure_map;
+  Closure_Info *cl2 = (Closure_Info *)data2->closure_map;
+
+  if (cl1->has_flomap) {
+    if (!cl1->flonum_map || !cl2->has_flomap) {
+      cl2->has_flomap = 1;
+      cl2->flonum_map = cl1->flonum_map;
+    } else if (cl2->flonum_map) {
+      int i;
+      for (i = data1->num_params; i--; ) {
+        if (cl1->flonum_map[i] != cl2->flonum_map[i]) {
+          cl2->flonum_map = NULL;
+          cl1->flonum_map = NULL;
+          break;
+        }
+      }
+    } else {
+      cl1->flonum_map = NULL;
+    }
+  } else if (cl2->has_flomap) {
+    cl1->has_flomap = 1;
+    cl1->flonum_map = cl2->flonum_map;
   }
 }
 

src/racket/src/schpriv.h

@@ -2548,6 +2548,7 @@ int scheme_optimize_is_flonum_valued(Optimize_Info *info, int pos);
 int scheme_is_flonum_expression(Scheme_Object *expr, Optimize_Info *info);
 char *scheme_get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok);
 void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map);
+void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2);
 
 Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
 Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth);

src/racket/src/syntax.c

@@ -3018,7 +3018,8 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
 static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
                           Scheme_Compiled_Let_Value *pre_body,
                           Scheme_Object *clones,
-                          int set_flags, int mask_flags, int just_tentative)
+                          int set_flags, int mask_flags, int just_tentative,
+                          int merge_flonum)
 {
   Scheme_Compiled_Let_Value *clv;
   Scheme_Object *value, *first;
@@ -3035,12 +3036,18 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
     value = clv->value;
     if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
       data = (Scheme_Closure_Data *)value;
+
+      first = SCHEME_CAR(clones);
+
+      if (merge_flonum) {
+        scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first));
+        scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CDR(first));
+        scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first));
+      }        
       
       if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
         flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
         
-        first = SCHEME_CAR(clones);
-        
         data = (Scheme_Closure_Data *)SCHEME_CDR(first);
         SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
         data = (Scheme_Closure_Data *)SCHEME_CAR(first);
@@ -3611,6 +3618,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         (void)set_code_flags(retry_start, pre_body, clones,
                              CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 
                              0xFFFF,
+                             0,
                              0);
         /* Re-optimize loop: */
         clv = retry_start;
@@ -3690,11 +3698,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
 	  clv = (Scheme_Compiled_Let_Value *)clv->body;
 	}
         /* Check flags loop: */
-        flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0);
+        flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0, 0);
         /* Reset-flags loop: */
         (void)set_code_flags(retry_start, pre_body, clones,
                              (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), 
                              ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE),
+                             1,
                              1);
       }
       retry_start = NULL;