Kill the preallocator, install a sane replacement. Closes #131. And probably a lot of others.

5 files changed, 123 insertions, 263 deletions

diff --git a/src/boot/be/abi.ml b/src/boot/be/abi.ml
index 975ff032..347d49fc 100644
--- a/src/boot/be/abi.ml
+++ b/src/boot/be/abi.ml
@@ -107,14 +107,13 @@ type abi =
     abi_word_bits: Il.bits;
     abi_word_ty: Common.ty_mach;
 
-    abi_is_2addr_machine: bool;
     abi_has_pcrel_data: bool;
     abi_has_pcrel_code: bool;
 
     abi_n_hardregs: int;
     abi_str_of_hardreg: (int -> string);
 
-    abi_prealloc_quad: (Il.quad' -> Il.quad');
+    abi_emit_target_specific: (Il.emitter -> Il.quad -> unit);
     abi_constrain_vregs: (Il.quad -> Bits.t array -> unit);
 
     abi_emit_fn_prologue: (Il.emitter
diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml
index 9661719d..792e83e2 100644
--- a/src/boot/be/il.ml
+++ b/src/boot/be/il.ml
@@ -692,8 +692,7 @@ let string_of_quad (f:hreg_formatter) (q:quad) : string =
 type emitter = { mutable emit_pc: int;
                  mutable emit_next_vreg: int option;
                  mutable emit_next_spill: int;
-                 emit_preallocator: (quad' -> quad');
-                 emit_is_2addr: bool;
+                 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;
@@ -712,8 +711,7 @@ let deadq = { quad_fixup = None;
 
 
 let new_emitter
-    (preallocator:quad' -> quad')
-    (is_2addr:bool)
+    (emit_target_specific:emitter -> quad -> unit)
     (vregs_ok:bool)
     (node:node_id option)
     : emitter =
@@ -721,8 +719,7 @@ let new_emitter
     emit_pc = 0;
     emit_next_vreg = (if vregs_ok then Some 0 else None);
     emit_next_spill = 0;
-    emit_preallocator = preallocator;
-    emit_is_2addr = is_2addr;
+    emit_target_specific = emit_target_specific;
     emit_quads = Array.create 4 badq;
     emit_annotations = Hashtbl.create 0;
     emit_size_cache = Stack.create ();
@@ -837,218 +834,30 @@ let append_quad
   e.emit_pc <- e.emit_pc + 1
 ;;
 
+let default_mov q' =
+  match q' with
+      Binary b ->
+        begin
+          match b.binary_op with
+              IDIV | IMUL | IMOD -> IMOV
+            | _ -> UMOV
+        end
+    | Unary u ->
+        begin
+          match u.unary_op with
+              IMOV -> IMOV
+            | _ -> UMOV
+        end
+    | _ -> UMOV
+;;
 
 let emit_full
     (e:emitter)
     (fix:fixup option)
     (q':quad')
     : unit =
-  let fixup = ref fix in
-  let emit_quad_bottom q' =
-    append_quad e { quad_body = q';
-                    quad_fixup = (!fixup) };
-    fixup := None;
-  in
-
-  let emit_quad (q':quad') : unit =
-    (* re-decay any freshly generated mem-mem movs. *)
-    match q' with
-        Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
-                unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
-                unary_op = op }
-          when is_mov op ->
-            let v = next_vreg_cell e dst_st in
-              emit_quad_bottom
-                (unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
-              emit_quad_bottom
-                (unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
-      | _ -> emit_quad_bottom q'
-  in
-
-  let default_mov =
-    match q' with
-        Binary b ->
-          begin
-            match b.binary_op with
-                IDIV | IMUL | IMOD -> IMOV
-              | _ -> UMOV
-          end
-      | Unary u ->
-          begin
-            match u.unary_op with
-                IMOV -> IMOV
-              | _ -> UMOV
-          end
-      | _ -> UMOV
-  in
-
-  let emit_mov (dst:cell) (src:operand) : unit =
-    emit_quad (unary default_mov dst src)
-  in
-
-  let mov_if_operands_differ
-      (old_op:operand) (new_op:operand)
-      : unit =
-    if (new_op <> old_op)
-    then
-      match new_op with
-          (Cell new_cell) ->
-            emit_mov new_cell old_op
-        | _ -> ()
-  in
-
-  let mov_if_two_operands_differ
-      (old_lhs_op:operand) (new_lhs_op:operand)
-      (old_rhs_op:operand) (new_rhs_op:operand)
-      : unit =
-    (*
-     * This is sufficiently obscure that it deserves an explanation.
-     * 
-     * The main idea here is to do two "mov_if_operands_differ" calls,
-     * such as one might have when setting up a binary quad.
-     * 
-     * The problem comes when you happen to hit a case like X86 div,
-     * which preallocates *both* operands. Preallocating both means we
-     * have to potentially issue two movs into the preallocated regs,
-     * and the second of those movs might be a problem. Specifically:
-     * the second mov-to-prealloc might make be moving from a
-     * register-indirect mem cell based on a vreg, and that vreg may
-     * wind up being assigned to an hreg that we just loaded with the
-     * first mov. In other words, the second mov may retask the
-     * preallocated hreg we set up in the first mov.
-     * 
-     * You laugh, but of course this actually happens.
-     * 
-     * So here we do a conservative thing and check to see if either
-     * operand is memory-indirect at all. If either is, then for either
-     * of the 'old' operands we're *about* to mov into a prealloc reg,
-     * we first bounce them off a spill slot. Spill slots, thankfully,
-     * we can always count on being able to address irrespective of the
-     * opinions of the RA, as they are all just fp-relative.
-     * 
-     * A slightly more aggressive version of this would only bounce
-     * cases that are not fp-relative already, though doing so would
-     * require threading the notion of what fp *is* through to
-     * here. Possibly tighten this up in the future (or just
-     * ... destroy this backend ASAP).
-     * 
-     *)
-    let has_reg_indirect op =
-      match op with
-          Cell (Mem _) -> true
-        | _ -> false
-    in
-    let either_old_op_has_reg_indirect =
-      (has_reg_indirect old_lhs_op) || (has_reg_indirect old_rhs_op)
-    in
-    let old_lhs_op =
-      if either_old_op_has_reg_indirect && (new_lhs_op <> old_lhs_op)
-      then
-        let tmp =
-          Mem (next_spill_slot e
-                 (ScalarTy (operand_scalar_ty old_lhs_op)))
-        in
-          emit_mov tmp old_lhs_op;
-          Cell tmp
-      else
-        old_lhs_op
-    in
-    let old_rhs_op =
-      if either_old_op_has_reg_indirect && (new_rhs_op <> old_rhs_op)
-      then
-        let tmp =
-          Mem (next_spill_slot e
-                 (ScalarTy (operand_scalar_ty old_rhs_op)))
-        in
-          emit_mov tmp old_rhs_op;
-          Cell tmp
-      else
-        old_rhs_op
-    in
-      mov_if_operands_differ old_lhs_op new_lhs_op;
-      mov_if_operands_differ old_rhs_op new_rhs_op;
-  in
-
-  let mov_if_cells_differ (old_cell:cell) (new_cell:cell) : unit =
-    if not (new_cell = old_cell)
-    then
-      emit_mov old_cell (Cell new_cell)
-  in
-
-  let emit_decayed_quad q' =
-    match (q', e.emit_preallocator q') with
-        (Binary b, Binary b') ->
-          begin
-            mov_if_two_operands_differ
-              b.binary_lhs b'.binary_lhs
-              b.binary_rhs b'.binary_rhs;
-            if e.emit_is_2addr &&
-              (not (b'.binary_lhs = (Cell b'.binary_dst)))
-            then
-              begin
-                emit_mov b'.binary_dst b'.binary_lhs;
-                emit_quad (Binary { b' with
-                                      binary_lhs = (Cell b'.binary_dst) })
-              end
-            else
-              emit_quad (Binary b');
-            mov_if_cells_differ b.binary_dst b'.binary_dst
-          end
-
-      | (Unary u, Unary u') ->
-          mov_if_operands_differ u.unary_src u'.unary_src;
-          (* Assume '2addr' means '1addr' for unary ops. *)
-          if e.emit_is_2addr &&
-            (u'.unary_op = NEG || u'.unary_op = NOT) &&
-            (not (u'.unary_src = (Cell u'.unary_dst)))
-            then
-              begin
-                emit_mov u'.unary_dst u'.unary_src;
-                emit_quad (Unary { u' with unary_src = (Cell u'.unary_dst) })
-              end
-            else
-              emit_quad (Unary u');
-          mov_if_cells_differ u.unary_dst u'.unary_dst
-
-      | (Cmp c, Cmp c') ->
-          mov_if_two_operands_differ
-            c.cmp_lhs c'.cmp_lhs
-            c.cmp_rhs c'.cmp_rhs;
-          emit_quad (Cmp c');
-
-      | (Push op, Push op') ->
-          mov_if_operands_differ op op';
-          emit_quad (Push op');
-
-      | (Pop c, Pop c') ->
-          emit_quad (Pop c');
-          mov_if_cells_differ c c'
-
-      | (Call c, Call c') ->
-          emit_quad (Call c');
-          mov_if_cells_differ c.call_dst c'.call_dst
-
-      | (Lea lea, Lea lea') ->
-          emit_quad (Lea lea');
-          mov_if_cells_differ lea.lea_dst lea'.lea_dst
-
-      | (x, y) ->
-          assert (x = y);
-          emit_quad x
-  in
-
-    (* pre-decay mem-mem movs. *)
-    match q' with
-        Unary { unary_dst = Mem (dst_mem, ScalarTy src_st);
-                unary_src = Cell (Mem (src_mem, ScalarTy dst_st));
-                unary_op = op }
-          when is_mov op ->
-            let v = next_vreg_cell e dst_st in
-              emit_decayed_quad
-                (unary op v (Cell (Mem (src_mem, ScalarTy src_st))));
-              emit_decayed_quad
-                (unary op (Mem (dst_mem, ScalarTy dst_st)) (Cell v))
-      | _ -> emit_decayed_quad q'
+  e.emit_target_specific e { quad_body = q';
+                             quad_fixup = fix }
 ;;
 
 let emit (e:emitter) (q':quad') : unit =
diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml
index ac567df0..217149c7 100644
--- a/src/boot/be/x86.ml
+++ b/src/boot/be/x86.ml
@@ -256,63 +256,111 @@ let is_rm8 (c:Il.cell) : bool =
     | _ -> is_r8 c
 ;;
 
-let prealloc_quad (quad':Il.quad') : Il.quad' =
-  let target_cell reg c =
-    Il.Reg (Il.Hreg reg, Il.cell_scalar_ty c)
+
+let emit_target_specific
+    (e:Il.emitter)
+    (q:Il.quad)
+    : unit =
+  let fixup = ref q.Il.quad_fixup in
+  let put q' =
+    Il.append_quad e { Il.quad_body = q';
+                       Il.quad_fixup = (!fixup) };
+    fixup := None;
   in
-  let target_operand reg op =
-    Il.Cell (Il.Reg (Il.Hreg reg, Il.operand_scalar_ty op))
+  let op_vreg op =
+    Il.next_vreg_cell e (Il.operand_scalar_ty op)
   in
-
-  let target_bin_to_hreg bin dst src =
-    { bin with
-        Il.binary_rhs = target_operand src bin.Il.binary_rhs;
-        Il.binary_lhs = target_operand dst bin.Il.binary_lhs;
-        Il.binary_dst = target_cell dst bin.Il.binary_dst }
+  let cell_vreg cell = op_vreg (Il.Cell cell) in
+  let mem_vreg mem = cell_vreg (Il.Mem mem) in
+  let movop = Il.default_mov q.Il.quad_body in
+  let mov dst src =
+    (* Decay mem-mem moves to use a vreg. *)
+    match dst, src with
+        Il.Mem dm, Il.Cell (Il.Mem _) ->
+          let v = mem_vreg dm in
+            put (Il.unary movop v src);
+            put (Il.unary movop dst (Il.Cell v))
+      | _ -> put (Il.unary movop dst src)
   in
 
-  let target_cmp cmp =
-    match cmp.Il.cmp_lhs with
-        (* Immediate LHS we force to eax. *)
-        Il.Imm _ ->
-          { cmp with
-              Il.cmp_lhs = target_operand eax cmp.Il.cmp_lhs }
-      | _ -> cmp
+  let hr_like_op hr op =
+    Il.Reg (Il.Hreg hr, Il.operand_scalar_ty op)
   in
-
-    match quad' with
-        Il.Binary bin ->
+  let hr_like_cell hr c = hr_like_op hr (Il.Cell c) in
+  let q = q.Il.quad_body in
+
+    match q with
+        Il.Binary ({ Il.binary_op = op;
+                     Il.binary_dst = dst;
+                     Il.binary_lhs = lhs;
+                     Il.binary_rhs = rhs; } as b) ->
           begin
-            Il.Binary
-              begin
-                match bin.Il.binary_op with
-                    Il.IMUL | Il.UMUL
-                  | Il.IDIV | Il.UDIV -> target_bin_to_hreg bin eax ecx
-                  | Il.IMOD | Il.UMOD -> target_bin_to_hreg bin eax ecx
-                  | _ -> bin
-              end
+            match op with
+
+                Il.IMUL | Il.UMUL
+              | Il.IDIV | Il.UDIV
+              | 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;
+                    put (Il.Binary
+                           { b with
+                               Il.binary_lhs = (Il.Cell lhs_eax);
+                               Il.binary_rhs = (Il.Cell rhs_ecx);
+                               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
+                         { b with Il.binary_lhs = Il.Cell dst })
+
+              | _ -> put q
           end
 
-      | Il.Cmp cmp -> Il.Cmp (target_cmp cmp)
+      | Il.Unary ({ Il.unary_op = op;
+                    Il.unary_dst = dst;
+                    Il.unary_src = src; } as u) ->
+          begin
+            match op with
 
-      | Il.Call c ->
-          let ty = Il.cell_scalar_ty c.Il.call_dst in
-            Il.Call { c with
-                        Il.call_dst = Il.Reg ((Il.Hreg eax), ty) }
+                Il.UMOV | Il.IMOV ->
+                  mov dst src
 
-      | Il.Lea le ->
-          begin
-            match (le.Il.lea_dst, le.Il.lea_src) with
-                (Il.Reg (_, dst_ty), Il.ImmPtr _)
-                  when is_ty32 dst_ty ->
-                    Il.Lea { le with
-                               Il.lea_dst = Il.Reg (Il.Hreg eax, dst_ty) }
-              | _ -> quad'
+              (* x86 can only NEG or NOT in-place. *)
+              | Il.NEG | Il.NOT when (Il.Cell dst) <> src ->
+                  mov dst src;
+                  put (Il.Unary { u with Il.unary_src = Il.Cell dst })
+
+              | _ -> put q
           end
 
-      | x -> x
+      | Il.Call c ->
+          let dst_eax = hr_like_cell eax c.Il.call_dst in
+            put (Il.Call { c with Il.call_dst = dst_eax });
+            if c.Il.call_dst <> dst_eax
+            then mov c.Il.call_dst (Il.Cell dst_eax)
+
+      (* 
+       * For the get-next-pc thunk hack to work, we need to lea an immptr
+       * to eax, always.
+       *)
+      | Il.Lea ({ Il.lea_dst = dst;
+                  Il.lea_src = Il.ImmPtr _  } as lea) ->
+          let eax_dst = hr_like_cell eax dst in
+            put (Il.Lea { lea with Il.lea_dst = eax_dst });
+            if dst <> eax_dst
+            then mov dst (Il.Cell eax_dst);
+
+      | q -> put q
 ;;
 
+
 let constrain_vregs (q:Il.quad) (hregs:Bits.t array) : unit =
 
   let involves_8bit_cell =
@@ -1640,13 +1688,12 @@ let (abi:Abi.abi) =
     Abi.abi_word_bits = word_bits;
     Abi.abi_word_ty = word_ty;
 
-    Abi.abi_is_2addr_machine = true;
     Abi.abi_has_pcrel_data = false;
     Abi.abi_has_pcrel_code = true;
 
     Abi.abi_n_hardregs = n_hardregs;
     Abi.abi_str_of_hardreg = reg_str;
-    Abi.abi_prealloc_quad = prealloc_quad;
+    Abi.abi_emit_target_specific = emit_target_specific;
     Abi.abi_constrain_vregs = constrain_vregs;
 
     Abi.abi_emit_fn_prologue = fn_prologue;
@@ -2291,8 +2338,7 @@ let select_insn (q:Il.quad) : Asm.frag =
 
 let new_emitter_without_vregs _ : Il.emitter =
   Il.new_emitter
-    abi.Abi.abi_prealloc_quad
-    abi.Abi.abi_is_2addr_machine
+    abi.Abi.abi_emit_target_specific
     false None
 ;;
 
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index faa39442..f2bb2287 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -160,8 +160,7 @@ let trans_visitor
   let emitters = Stack.create () in
   let push_new_emitter (vregs_ok:bool) (fnid:node_id option) =
     let e = Il.new_emitter
-         abi.Abi.abi_prealloc_quad
-         abi.Abi.abi_is_2addr_machine
+         abi.Abi.abi_emit_target_specific
          vregs_ok fnid
     in
       Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
diff --git a/src/test/run-pass/arithmetic-interference.rs b/src/test/run-pass/arithmetic-interference.rs
new file mode 100644
index 00000000..588148bb
--- /dev/null
+++ b/src/test/run-pass/arithmetic-interference.rs
@@ -0,0 +1,7 @@
+// Testcase for issue #131.
+
+fn main() -> () {
+  let int a = 10;
+  log a;
+  check (a * (a - 1) == 90);
+}