Degrade emitter size cache to just a flat hashtable with regular flushes (sigh) and re-introduce horrible bounce-off-spill hack for DIV, MUL, etc.

3 files changed, 73 insertions, 33 deletions

diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml
index 792e83e200a..172d8661430 100644
--- a/src/boot/be/il.ml
+++ b/src/boot/be/il.ml
@@ -695,7 +695,7 @@ type emitter = { mutable emit_pc: int;
                  emit_target_specific: (emitter -> quad -> unit);
                  mutable emit_quads: quads;
                  emit_annotations: (int,string) Hashtbl.t;
-                 emit_size_cache: ((size,operand) Hashtbl.t) Stack.t;
+                 emit_size_cache: (size,operand) Hashtbl.t;
                  emit_node: node_id option;
                }
 
@@ -722,7 +722,7 @@ let new_emitter
     emit_target_specific = emit_target_specific;
     emit_quads = Array.create 4 badq;
     emit_annotations = Hashtbl.create 0;
-    emit_size_cache = Stack.create ();
+    emit_size_cache = Hashtbl.create 0;
     emit_node = node;
   }
 ;;
diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml
index 2ec34890669..55b101bbd34 100644
--- a/src/boot/be/x86.ml
+++ b/src/boot/be/x86.ml
@@ -302,11 +302,41 @@ let emit_target_specific
               | Il.IMOD | Il.UMOD ->
                   let dst_eax = hr_like_cell eax dst in
                   let lhs_eax = hr_like_op eax lhs in
-                  let rhs_ecx = hr_like_op ecx lhs in
-                    if lhs <> (Il.Cell lhs_eax)
-                    then mov lhs_eax lhs;
-                    if rhs <> (Il.Cell rhs_ecx)
-                    then mov rhs_ecx rhs;
+                  let rhs_ecx = hr_like_op ecx rhs in
+                    (* Horrible: we bounce complex mul inputs off spill slots
+                     * to ensure non-interference between the temporaries used
+                     * during mem-base-reg reloads and the registers we're
+                     * preparing.  *)
+                  let next_spill_like op =
+                    Il.Mem (Il.next_spill_slot e
+                              (Il.ScalarTy (Il.operand_scalar_ty op)))
+                  in
+                  let is_mem op =
+                    match op with
+                        Il.Cell (Il.Mem _) -> true
+                      | _ -> false
+                  in
+                  let bounce_lhs = is_mem lhs in
+                  let bounce_rhs = is_mem rhs in
+                  let lhs_spill = next_spill_like lhs in
+                  let rhs_spill = next_spill_like rhs in
+
+                    if bounce_lhs
+                    then mov lhs_spill lhs;
+
+                    if bounce_rhs
+                    then mov rhs_spill rhs;
+
+                    mov lhs_eax
+                      (if bounce_lhs
+                       then (Il.Cell lhs_spill)
+                       else lhs);
+
+                    mov rhs_ecx
+                      (if bounce_rhs
+                       then (Il.Cell rhs_spill)
+                       else rhs);
+                    
                     put (Il.Binary
                            { b with
                                Il.binary_lhs = (Il.Cell lhs_eax);
@@ -314,7 +344,7 @@ let emit_target_specific
                                Il.binary_dst = dst_eax; });
                     if dst <> dst_eax
                     then mov dst (Il.Cell dst_eax);
-
+                    
               | _ when (Il.Cell dst) <> lhs ->
                   mov dst lhs;
                   put (Il.Binary
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 8c280ebdb34..b708bb268ff 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -163,7 +163,6 @@ let trans_visitor
          abi.Abi.abi_emit_target_specific
          vregs_ok fnid
     in
-      Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
       Stack.push e emitters;
   in
 
@@ -172,16 +171,20 @@ let trans_visitor
 
   let pop_emitter _ = ignore (Stack.pop emitters) in
   let emitter _ = Stack.top emitters in
-  let emitter_size_cache _ = Stack.top (emitter()).Il.emit_size_cache in
-  let push_emitter_size_cache _ =
-    Stack.push
-      (Hashtbl.copy (emitter_size_cache()))
-      (emitter()).Il.emit_size_cache
+  let emitter_size_cache _ = (emitter()).Il.emit_size_cache in
+  let flush_emitter_size_cache _ =
+    Hashtbl.clear (emitter_size_cache())
   in
-  let pop_emitter_size_cache _ =
-    ignore (Stack.pop (emitter()).Il.emit_size_cache)
+
+  let emit q =
+    begin
+      match q with
+        Il.Jmp _ -> flush_emitter_size_cache();
+        | _ -> ()
+    end;        
+    Il.emit (emitter()) q
   in
-  let emit q = Il.emit (emitter()) q in
+
   let next_vreg _ = Il.next_vreg (emitter()) in
   let next_vreg_cell t = Il.next_vreg_cell (emitter()) t in
   let next_spill_cell t =
@@ -190,12 +193,17 @@ let trans_visitor
     let spill_ta = (spill_mem, Il.ScalarTy t) in
       Il.Mem spill_ta
   in
-  let mark _ : quad_idx = (emitter()).Il.emit_pc in
+  let mark _ : quad_idx =
+    flush_emitter_size_cache ();
+    (emitter()).Il.emit_pc
+  in
   let patch_existing (jmp:quad_idx) (targ:quad_idx) : unit =
-    Il.patch_jump (emitter()) jmp targ
+    Il.patch_jump (emitter()) jmp targ;
+    flush_emitter_size_cache ();
   in
   let patch (i:quad_idx) : unit =
     Il.patch_jump (emitter()) i (mark());
+    flush_emitter_size_cache ();
     (* Insert a dead quad to ensure there's an otherwise-unused
      * jump-target here.
      *)
@@ -583,7 +591,13 @@ let trans_visitor
                 (string_of_size size)));
     let sub_sz = calculate_sz ty_params in
     match htab_search (emitter_size_cache()) size with
-        Some op -> op
+        Some op ->
+          iflog (fun _ -> annotate
+                   (Printf.sprintf "cached size %s is %s"
+                      (string_of_size size)
+                      (oper_str op)));
+          op
+
       | _ ->
           let res =
             match size with
@@ -674,9 +688,7 @@ let trans_visitor
                      (Printf.sprintf "calculated size %s is %s"
                         (string_of_size size)
                         (oper_str res)));
-
-            (* FIXME: this appears to be incorrect; investigate why.*)
-            (* htab_put (emitter_size_cache()) size res; *)
+            htab_put (emitter_size_cache()) size res;
             res
 
 
@@ -1926,8 +1938,8 @@ let trans_visitor
       : quad_idx list =
     emit (Il.cmp (Il.Cell (Il.Reg (force_to_reg lhs))) rhs);
     let jmp = mark() in
-    emit (Il.jmp cjmp Il.CodeNone);
-    [ jmp ]
+      emit (Il.jmp cjmp Il.CodeNone);
+      [ jmp ]
 
   and trans_compare
       ?ty_params:(ty_params=get_ty_params_of_current_frame())
@@ -1946,7 +1958,6 @@ let trans_visitor
       | _ -> trans_compare_simple cjmp lhs rhs
 
   and trans_cond (invert:bool) (expr:Ast.expr) : quad_idx list =
-
     let anno _ =
       iflog
         begin
@@ -2078,15 +2089,14 @@ let trans_visitor
             trans_atom a
 
   and trans_block (block:Ast.block) : unit =
+    flush_emitter_size_cache();
     trace_str cx.ctxt_sess.Session.sess_trace_block
       "entering block";
-    push_emitter_size_cache ();
     emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups block.id));
     Array.iter trans_stmt block.node;
     trace_str cx.ctxt_sess.Session.sess_trace_block
       "exiting block";
     emit Il.Leave;
-    pop_emitter_size_cache ();
     trace_str cx.ctxt_sess.Session.sess_trace_block
       "exited block";
 
@@ -4398,11 +4408,11 @@ let trans_visitor
                     let back_jmp =
                       trans_compare_simple Il.JB (Il.Cell dptr) (Il.Cell dlim)
                     in
-                    List.iter
-                      (fun j -> patch_existing j back_jmp_targ) back_jmp;
-                    let v = next_vreg_cell word_sty in
-                      mov v (Il.Cell src_fill);
-                      add_to dst_fill (Il.Cell v);
+                      List.iter
+                        (fun j -> patch_existing j back_jmp_targ) back_jmp;
+                      let v = next_vreg_cell word_sty in
+                        mov v (Il.Cell src_fill);
+                        add_to dst_fill (Il.Cell v);
         | t ->
             begin
               bug () "unsupported vector-append type %a" Ast.sprintf_ty t