From 4e0fac04775e0759f96a6040c35af67098533751 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 23 Nov 2012 08:15:03 -0700
Subject: [PATCH] JIT: fix allocation of came-lambda closures over flonums

Also, clean up code and assumptions related to fixnum-producing
functions and unboxing (not related to the bug).
---
 collects/tests/racket/optimize.rktl | 14 ++++++++++++++
 src/racket/src/jit.c                | 26 +++++++++++++++++++-------
 src/racket/src/jitarith.c           | 10 ++++++++--
 3 files changed, 41 insertions(+), 9 deletions(-)

diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl
index d7ae1fc779..74cd0ff1c3 100644
--- a/collects/tests/racket/optimize.rktl
+++ b/collects/tests/racket/optimize.rktl
@@ -2589,6 +2589,20 @@
                (f)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; check a `case-lambda' that closes over flonums
+
+(let ()
+  (define f #f)
+  (set! f
+        (lambda (x)
+          (let ([x (fl+ x x)])
+            (case-lambda
+             [() (fl+ x x)]
+             [(y) (fl+ x y)]))))
+  
+  (test 4.0 (f 1.0) 2.0))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 (report-errs)
diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c
index bd694425fd..075c9873e2 100644
--- a/src/racket/src/jit.c
+++ b/src/racket/src/jit.c
@@ -1324,6 +1324,19 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t
   ensure_case_closure_native(c);
   ndata = c->native_code;
 
+  count = c->count;
+
+  for (i = 0; i < count; i++) {
+    o = c->array[i];
+    if (SCHEME_PROCP(o))
+      o = (Scheme_Object *)((Scheme_Closure *)o)->code;
+    data = (Scheme_Closure_Data *)o;
+    mz_rs_sync();
+    CHECK_LIMIT();
+    generate_closure_prep(data, jitter);
+    CHECK_LIMIT();
+  }
+
   mz_rs_sync();
 
   JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
@@ -1337,8 +1350,6 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t
   jit_retval(JIT_R1);
   CHECK_LIMIT();
 
-  count = c->count;
-  
   for (i = 0; i < count; i++) {
     o = c->array[i];
     if (SCHEME_PROCP(o))
@@ -1514,7 +1525,7 @@ int scheme_generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
 }
 
 int scheme_generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway)
-/* de-sync's; if refslow, failure jumps conditionally with non-flonum in R0;
+/* de-sync's;
    inlined_ok == 2 => can generate directly; inlined_ok == 1 => non-tail unbox */
 {
   int saved;
@@ -2844,12 +2855,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
         if (scheme_can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)) {
           jitter->unbox++;
           scheme_generate_unboxed(lv->value, jitter, 2, 0);
-        } else {
-          if (0) /* validator should ensure that this is ok */
-            if (!scheme_can_unbox_directly(lv->value))
-              scheme_signal_error("internal error: bad FLONUM annotation on let");
+        } else if (scheme_can_unbox_directly(lv->value)) {
           jitter->unbox++;
           scheme_generate_unboxed(lv->value, jitter, 1, 0);
+        } else {
+          /* validator should ensure that this is ok */
+          jitter->unbox++;
+          scheme_generate_unboxed(lv->value, jitter, 0, 1);
         }
 #endif
       } else if (unused && SCHEME_FALSEP(lv->value)) {
diff --git a/src/racket/src/jitarith.c b/src/racket/src/jitarith.c
index bae0118eac..928e7b84fb 100644
--- a/src/racket/src/jitarith.c
+++ b/src/racket/src/jitarith.c
@@ -50,13 +50,18 @@ static int can_reorder_unboxing(Scheme_Object *rand, Scheme_Object *rand2)
 }
 
 static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely, int just_checking_result)
-/* If unsafely, a result f 2 means that arguments should be checked safely. */
+/* If unsafely, a result of 2 means that arguments should be checked safely. */
 {
   if (!SCHEME_PRIMP(obj))
     return 0;
   if (!(SCHEME_PRIM_PROC_OPT_FLAGS(obj) & flag))
     return 0;
 
+  /* We have a table here for now, instead of flags accessed via
+     SCHEME_PRIM_PROC_OPT_FLAGS(), because this function reports
+     properties of the JIT rather than inherent properties of the 
+     functions. */
+
   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;
@@ -209,7 +214,8 @@ int scheme_can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely
 
 int scheme_can_unbox_directly(Scheme_Object *obj)
 /* Used only when !can_unbox_inline(). Detects safe operations that
-   produce flonums when they don't raise an exception. */
+   produce flonums when they don't raise an exception, and that the JIT
+   supports directly unboxing. */
 {
   Scheme_Type t;