unboxing of intermediate results in some 'unsafe-fl' combinations

svn: r16229

collects/tests/mzscheme/unsafe.ss

@@ -122,6 +122,24 @@
   (test-un 8.0 'unsafe-fx->fl 8)
   (test-un -8.0 'unsafe-fx->fl -8)
 
+  ;; test unboxing:
+  (test-tri 9.0 '(lambda (x y z) (unsafe-fl+ (unsafe-fl- x z) y)) 4.5 7.0 2.5)
+  (test-tri 9.0 '(lambda (x y z) (unsafe-fl+ y (unsafe-fl- x z))) 4.5 7.0 2.5)
+  (test-bin 10.0 '(lambda (x y) (unsafe-fl+ (unsafe-fx->fl x) y)) 2 8.0)
+  (test-bin 10.0 '(lambda (x y) (unsafe-fl+ (unsafe-fx->fl x) y)) 2 8.0)
+  (test-tri (/ 20.0 0.8) '(lambda (x y z) (unsafe-fl/ (unsafe-fl* x z) y)) 4.0 0.8 5.0)
+  (test-tri (/ 0.8 20.0) '(lambda (x y z) (unsafe-fl/ y (unsafe-fl* x z))) 4.0 0.8 5.0)
+  (test-tri #t '(lambda (x y z) (unsafe-fl< (unsafe-fl+ x y) z)) 1.2 3.4 5.0)
+  (test-tri 'yes '(lambda (x y z) (if (unsafe-fl< (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
+  (test-tri #f '(lambda (x y z) (unsafe-fl> (unsafe-fl+ x y) z)) 1.2 3.4 5.0)
+  (test-tri 'no '(lambda (x y z) (if (unsafe-fl> (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
+  
+  ;; test unboxing interaction with free variables:
+  (test-tri 4.4 '(lambda (x y z) (with-handlers ([exn:fail:contract:variable? 
+                                                  (lambda (exn) (unsafe-fl+ x y))])
+                                   (unsafe-fl- (unsafe-fl+ x y) NO-SUCH-VARIABLE)))
+            1.1 3.3 5.2)
+
   (test-un 5 'unsafe-car (cons 5 9))
   (test-un 9 'unsafe-cdr (cons 5 9))
   (test-un 15 'unsafe-mcar (mcons 15 19))

src/mzscheme/src/jit.c

@@ -189,6 +189,7 @@ typedef struct {
   int reg_status;
   void *patch_depth;
   int rs_virtual_offset;
+  int unbox, unbox_depth;
 } mz_jit_state;
 
 #define mz_RECORD_STATUS(s) (jitter->status_at_ptr = _jit.x.pc, jitter->reg_status = (s))
@@ -3185,6 +3186,76 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
   return is_tail ? 2 : 1;
 }
 
+static int is_unboxable_op(Scheme_Object *obj, int flag)
+{
+  if (!SCHEME_PRIMP(obj))
+    return 0;
+  if (!(SCHEME_PRIM_PROC_FLAGS(obj) & flag))
+    return 0;
+
+  if (IS_NAMED_PRIM(obj, "unsafe-fl+")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-fl-")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-fl*")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-fl/")) return 1;
+  if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1;
+
+  return 0;
+}
+
+static int generate_pop_unboxed(mz_jit_state *jitter)
+{
+#if defined(MZ_USE_JIT_I386)
+  /* If we have some arguments pushed on the FP stack, we need
+     to pop them off before escaping. */
+  int i;
+  for (i = jitter->unbox_depth; i--; ) {
+    FUCOMPr(1); /* compare with single pop; we ignore the compare result, of course */
+  }
+  CHECK_LIMIT();
+#endif
+  return 1;
+}
+
+static int can_unbox(Scheme_Object *obj, int fuel, int regs)
+/* Assuming that `arg' is unsafely assumed to produce a flonum, can we
+   just unbox it without using more than `regs' registers? There
+   cannot be any errors or function calls, unless we've specifically
+   instrumented them to save/pop floating-point values before
+   jumping. */
+{
+  Scheme_Type t;
+
+  if (!fuel) return 0;
+  if (!regs) return 0;
+
+  t = SCHEME_TYPE(obj);
+  switch (t) {
+  case scheme_application2_type:
+    {
+      Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
+      if (!is_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED))
+        return 0;
+      return can_unbox(app->rand, fuel - 1, regs);
+    }
+  case scheme_application3_type:
+    {
+      Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
+      if (!is_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED))
+        return 0;
+      if (!can_unbox(app->rand1, fuel - 1, regs))
+        return 0;
+      return can_unbox(app->rand2, fuel - 1, regs - 1);
+    }
+  case scheme_toplevel_type:
+  case scheme_local_type:
+  case scheme_local_unbox_type:
+    return 1;
+    break;
+  default:
+    return (t > _scheme_values_types_);
+  }
+}
+
 static jit_insn *generate_arith_slow_path(mz_jit_state *jitter, Scheme_Object *rator, 
 					  jit_insn **_ref, jit_insn **_ref4,
 					  jit_insn **for_branch, 
@@ -3291,6 +3362,7 @@ static int can_fast_double(int arith, int cmp, int two_args)
 
 #if !defined(MZ_USE_JIT_I386)
 /* Not FP stack, so use normal variants. */
+#define DIRECT_FPR_ACCESS
 #define jit_movi_d_fppush(rd,immd)    jit_movi_d(rd,immd)
 #define jit_ldi_d_fppush(rd, is)      jit_ldi_d(rd, is)
 #define jit_ldr_d_fppush(rd, rs)      jit_ldr_d(rd, rs)
@@ -3318,16 +3390,28 @@ static int can_fast_double(int arith, int cmp, int two_args)
 #define jit_extr_l_d_fppush(rd, rs)   jit_extr_l_d(rd, rs)
 #endif
 
+static int generate_unboxing(mz_jit_state *jitter)
+{
+  int fpr0;
+
+  fpr0 = JIT_FPR(jitter->unbox_depth);
+  jit_ldxi_d_fppush(fpr0, JIT_R0, &((Scheme_Double *)0x0)->double_val);  
+  jitter->unbox_depth++;
+
+  return 1;
+}
+
 static int generate_alloc_double(mz_jit_state *jitter)
+/* value should be in JIT_FPR0 */
 {
 #ifdef INLINE_FP_OPS
 # ifdef CAN_INLINE_ALLOC
   inline_alloc(jitter, sizeof(Scheme_Double), scheme_double_type, 0, 0, 1, 0);
   CHECK_LIMIT();
   jit_addi_p(JIT_R0, JIT_V1, GC_OBJHEAD_SIZE);
-  (void)jit_stxi_d_fppop(&((Scheme_Double *)0x0)->double_val, JIT_R0, JIT_FPR1);
+  (void)jit_stxi_d_fppop(&((Scheme_Double *)0x0)->double_val, JIT_R0, JIT_FPR0);
 # else
-  (void)jit_sti_d_fppop(&double_result, JIT_FPR1);
+  (void)jit_sti_d_fppop(&double_result, JIT_FPR0);
   JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
   mz_prepare(0);
   (void)mz_finish(malloc_double);
@@ -3339,11 +3423,15 @@ static int generate_alloc_double(mz_jit_state *jitter)
 
 static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int reversed, int two_args, int second_const,
                                  jit_insn **_refd, jit_insn **_refdt,
-                                 int branch_short, int unsafe_fl)
+                                 int branch_short, int unsafe_fl, int unboxed, int unboxed_result)
+/* Unless unboxed, first arg is in JIT_R1, second in JIT_R0.
+   If unboxed in push/pop mode, first arg is pushed before second.
+   If unboxed in direct mode, first arg is in JIT_FPR0+depth
+    and second is in JIT_FPR1+depth (which is backward). */
 {
 #if defined(INLINE_FP_OPS) || defined(INLINE_FP_COMP)
   GC_CAN_IGNORE jit_insn *ref8, *ref9, *ref10, *refd, *refdt;
-  int no_alloc = 0;
+  int no_alloc = unboxed_result;
 
   if (!unsafe_fl) {
     /* Maybe they're doubles */
@@ -3370,12 +3458,17 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
     /* Special case: multiplication by exact 0 */
     (void)jit_movi_p(JIT_R0, scheme_make_integer(0));
   } else {
-    /* Yes, they're doubles. */
+    /* Yes, they're doubles. First arg is in JIT_R1, second is in JIT_R0. 
-    if (arith != 12) {
+       Put the first arg in fpr0 and second (if any) into fpr1. To work
-      jit_ldxi_d_fppush(JIT_FPR1, JIT_R0, &((Scheme_Double *)0x0)->double_val);
+       right with stacks, that means pushing the second argument first. */
-    }
+    int fpr1, fpr0;
+
+    fpr0 = JIT_FPR(jitter->unbox_depth);
+    fpr1 = JIT_FPR(1+jitter->unbox_depth);
+
     if (two_args) {
-      jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
+      if (!unboxed)
+        jit_ldxi_d_fppush(fpr1, JIT_R1, &((Scheme_Double *)0x0)->double_val);
     } else if ((arith == -1) && !second_const && reversed) {
       reversed = 0;
     } else if (arith == 11) {
@@ -3384,33 +3477,48 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
       /* exact->inexact needs no extra number */
     } else {
       double d = second_const;
-      jit_movi_d_fppush(JIT_FPR0, d);
+      jit_movi_d_fppush(fpr1, d);
       reversed = !reversed;
       cmp = -cmp;
     }
+
+    if (!unboxed) {
+      if (arith != 12) {
+        jit_ldxi_d_fppush(fpr0, JIT_R0, &((Scheme_Double *)0x0)->double_val);
+      }
+    }
+
+#ifdef DIRECT_FPR_ACCESS
+    if (unboxed) {
+      /* arguments are backward */
+      reversed = !reversed;
+      cmp = -cmp;
+    }
+#endif
+
     if (arith) {
       switch (arith) {
       case 1:
-        jit_addr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+        jit_addr_d_fppop(fpr0, fpr0, fpr1);
         break;
       case 2:
-        jit_mulr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+        jit_mulr_d_fppop(fpr0, fpr0, fpr1);
         break;
       case -2:
-        if (reversed)
+        if (!reversed)
-          jit_divrr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+          jit_divrr_d_fppop(fpr0, fpr0, fpr1);
         else
-          jit_divr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+          jit_divr_d_fppop(fpr0, fpr0, fpr1);
         break;
       case -1:
         {
           if (!two_args && !second_const && !reversed) {
             /* Need a special case to make sure that (- 0.0) => -0.0 */
-            jit_negr_d_fppop(JIT_FPR1, JIT_FPR1);
+            jit_negr_d_fppop(fpr0, fpr0);
           } else if (reversed)
-            jit_subrr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+            jit_subr_d_fppop(fpr0, fpr0, fpr1);
           else
-            jit_subr_d_fppop(JIT_FPR1, JIT_FPR0, JIT_FPR1);
+            jit_subrr_d_fppop(fpr0, fpr0, fpr1);
         }
         break;
       case 9: /* min */
@@ -3419,22 +3527,24 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
           GC_CAN_IGNORE jit_insn *refc, *refn;
           __START_TINY_JUMPS__(1);
 	  /* If R0 is nan, then copy to R1, ensuring nan result */
-	  refn = jit_beqr_d(jit_forward(), JIT_FPR1, JIT_FPR1);
+	  refn = jit_beqr_d(jit_forward(), fpr0, fpr0);
           jit_movr_p(JIT_R1, JIT_R0);
 	  mz_patch_branch(refn);
           if (arith == 9) {
-            refc = jit_bger_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+            refc = jit_bltr_d_fppop(jit_forward(), fpr0, fpr1);
           } else {
-	    refc = jit_bltr_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+	    refc = jit_bger_d_fppop(jit_forward(), fpr0, fpr1);
           }
           jit_movr_p(JIT_R0, JIT_R1);
           mz_patch_branch(refc);
           __END_TINY_JUMPS__(1);
+          /* no unsafe version of `min' and `max', so we never need an
+             unboxed result, but we've already set JIT_R0 */
           no_alloc = 1;
         }
         break;
       case 11: /* abs */
-        jit_abs_d_fppop(JIT_FPR1, JIT_FPR1);
+        jit_abs_d_fppop(fpr0, fpr0);
         break;
       case 12: /* exact->inexact */
         no_alloc = 1;
@@ -3445,8 +3555,11 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
       CHECK_LIMIT();
 
       if (!no_alloc) {
+        mz_rs_sync(); /* needed if arguments were unboxed */
         generate_alloc_double(jitter);
         CHECK_LIMIT();
+      } else if (unboxed_result) {
+        jitter->unbox_depth++;
       }
     } else {
       /* The "anti" variants below invert the branch. Unlike the "un" 
@@ -3455,19 +3568,19 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
       __START_SHORT_JUMPS__(branch_short);
       switch (cmp) {
       case -2:
-        refd = jit_bantiltr_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+        refd = jit_bantigtr_d_fppop(jit_forward(), fpr0, fpr1);
         break;
       case -1:
-        refd = jit_bantiler_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+        refd = jit_bantiger_d_fppop(jit_forward(), fpr0, fpr1);
         break;
       case 0:
-        refd = jit_bantieqr_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+        refd = jit_bantieqr_d_fppop(jit_forward(), fpr0, fpr1);
         break;
       case 1:
-        refd = jit_bantiger_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+        refd = jit_bantiler_d_fppop(jit_forward(), fpr0, fpr1);
         break;
       case 2:
-        refd = jit_bantigtr_d_fppop(jit_forward(), JIT_FPR0, JIT_FPR1);
+        refd = jit_bantiltr_d_fppop(jit_forward(), fpr0, fpr1);
         break;
       default:
         refd = NULL;
@@ -3533,6 +3646,40 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
 
   LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name));
 
+  if (unsafe_fl
+      && can_unbox(rand, 5, JIT_FPR_NUM-2)
+      && (!rand2 || can_unbox(rand2, 5, JIT_FPR_NUM-3))) {
+    /* Unsafe, unboxed floating-point ops. */
+    jitter->unbox++;
+    if (!rand2) {
+      mz_runstack_skipped(jitter, 1);
+      generate(rand, jitter, 0, 1, JIT_R0);
+      CHECK_LIMIT();
+      mz_runstack_unskipped(jitter, 1);
+    } else {
+      mz_runstack_skipped(jitter, 2);
+      generate(rand, jitter, 0, 1, JIT_R0);
+      CHECK_LIMIT();
+      generate(rand2, jitter, 0, 1, JIT_R0);
+      CHECK_LIMIT();
+      mz_runstack_unskipped(jitter, 2);
+    }
+    --jitter->unbox;
+    jitter->unbox_depth -= (rand2 ? 2 : 1);
+    generate_double_arith(jitter, arith, cmp, 0, !!rand2, 0,
+                          &refd, &refdt, branch_short, 1, 1, jitter->unbox);
+    CHECK_LIMIT();
+    ref3 = NULL;
+    ref = NULL;
+    ref4 = NULL;
+
+    __START_SHORT_JUMPS__(branch_short);
+  } else {
+    int unbox = jitter->unbox;
+
+    /* While generating a fixnum op, don't unbox! */
+    jitter->unbox = 0;
+
     if (rand2) {
       if (SCHEME_INTP(rand2)
           && SCHEME_INT_SMALL_ENOUGH(rand2)
@@ -3663,7 +3810,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       if (unsafe_fl || (!unsafe_fx && !SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) {
         /* Maybe they're both doubles... */
         if (unsafe_fl) mz_rs_sync();
-      generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl);
+        generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
         CHECK_LIMIT();
       }
 
@@ -3712,7 +3859,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       if (unsafe_fl || (!unsafe_fx && can_fast_double(arith, cmp, 1))) {
         /* Maybe they're both doubles... */
         if (unsafe_fl) mz_rs_sync();
-      generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl);
+        generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
         CHECK_LIMIT();
       }
 
@@ -3758,7 +3905,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               /* watch out: divide by 0 is special: */
               && ((arith != -2) || v || reversed))) {
         /* Maybe it's a double... */
-      generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl);
+        generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl, 0, 0);
         CHECK_LIMIT();
       }
 
@@ -4074,12 +4221,19 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
               CHECK_LIMIT();
             } else if (arith == 12) {
               /* exact->inexact */
+              int fpr0;
+              fpr0 = JIT_FPR(jitter->unbox_depth);
               jit_rshi_l(JIT_R0, JIT_R0, 1);
-            jit_extr_l_d_fppush(JIT_FPR1, JIT_R0);
+              jit_extr_l_d_fppush(fpr0, JIT_R0);
               CHECK_LIMIT();
+              if (!unbox) {
+                mz_rs_sync(); /* needed for unsafe op before allocation */
                 __END_SHORT_JUMPS__(branch_short);
                 generate_alloc_double(jitter);
                 __START_SHORT_JUMPS__(branch_short);
+              } else {
+                jitter->unbox_depth++;
+              }
               CHECK_LIMIT();
             }
           }
@@ -4168,6 +4322,9 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       ref3 = NULL;
     }
 
+    jitter->unbox = unbox;
+  }
+
   if (!arith) {
     if (refdt)
       mz_patch_ucbranch(refdt);
@@ -6232,8 +6389,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       if (!(SCHEME_TOPLEVEL_FLAGS(obj) 
 	    & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))) {
 	/* Is it NULL? */
+        generate_pop_unboxed(jitter);
+        CHECK_LIMIT();
 	(void)jit_beqi_p(unbound_global_code, target, 0);
       }
+      if (jitter->unbox) generate_unboxing(jitter);
       END_JIT_DATA(0);
       return 1;
     }
@@ -6253,6 +6413,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
         mz_rs_stxi(pos, JIT_RUNSTACK);
       }
+      CHECK_LIMIT();
+      if (jitter->unbox) generate_unboxing(jitter);
       END_JIT_DATA(2);
       return 1;
     }
@@ -6270,6 +6432,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
         mz_rs_stxi(pos, JIT_RUNSTACK);
       }
       VALIDATE_RESULT(target);
+      CHECK_LIMIT();
+      if (jitter->unbox) generate_unboxing(jitter);
 
       END_JIT_DATA(3);
       return 1;
@@ -7143,7 +7307,14 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
       return 1;
     }
   default:
-    {
+    if (jitter->unbox && SCHEME_FLOATP(obj)) {
+      double d = SCHEME_FLOAT_VAL(obj);
+      int fpr0;
+      fpr0 = JIT_FPR(jitter->unbox_depth);
+      jit_movi_d_fppush(fpr0, d);
+      jitter->unbox_depth++;
+      return 1;
+    } else {
       int retptr;
       Scheme_Type type = SCHEME_TYPE(obj);
       START_JIT_DATA();