Turn float comparisons into primitive operations (#9945)

24 files changed, 203 insertions, 62 deletions

diff --git a/.depend b/.depend
index 422aab3479..5a8928716e 100644
--- a/.depend
+++ b/.depend
@@ -2240,14 +2240,20 @@ asmcomp/afl_instrument.cmi : \
     lambda/debuginfo.cmi \
     asmcomp/cmm.cmi
 asmcomp/arch.cmo : \
+    asmcomp/x86_ast.cmi \
+    lambda/lambda.cmi \
     utils/config.cmi \
     utils/clflags.cmi \
     asmcomp/arch.cmi
 asmcomp/arch.cmx : \
+    asmcomp/x86_ast.cmi \
+    lambda/lambda.cmx \
     utils/config.cmx \
     utils/clflags.cmx \
     asmcomp/arch.cmi
-asmcomp/arch.cmi :
+asmcomp/arch.cmi : \
+    asmcomp/x86_ast.cmi \
+    lambda/lambda.cmi
 asmcomp/asmgen.cmo : \
     lambda/translmod.cmi \
     asmcomp/split.cmi \
@@ -3090,6 +3096,7 @@ asmcomp/selectgen.cmi : \
     asmcomp/arch.cmi
 asmcomp/selection.cmo : \
     asmcomp/selectgen.cmi \
+    asmcomp/reg.cmi \
     asmcomp/proc.cmi \
     asmcomp/mach.cmi \
     asmcomp/cmm.cmi \
@@ -3098,6 +3105,7 @@ asmcomp/selection.cmo : \
     asmcomp/selection.cmi
 asmcomp/selection.cmx : \
     asmcomp/selectgen.cmx \
+    asmcomp/reg.cmx \
     asmcomp/proc.cmx \
     asmcomp/mach.cmx \
     asmcomp/cmm.cmx \
diff --git a/Changes b/Changes
index 818519185f..d9bd626179 100644
--- a/Changes
+++ b/Changes
@@ -78,6 +78,11 @@ Working version
 
 ### Code generation and optimizations:
 
+- #9945, #10883: Turn boolean-result float comparisons into primitive operations
+  Uses the architecture's elementary operations for float comparisons,
+  when available, rather than branching and then setting the return value.
+  (Stefan Muenzel, review by Stephen Dolan, Alain Frisch and Vincent Laviron)
+
 - #8998, #11321, #11430: change mangling of OCaml long identifiers
   from `camlModule__name_NNN` to `camlModule.name_NNN`.  The previous
   mangling schema, using `__`, was ambiguous.
diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml
index cbddd3b44f..687bfe04c8 100644
--- a/asmcomp/CSEgen.ml
+++ b/asmcomp/CSEgen.ml
@@ -233,7 +233,7 @@ method class_of_operation op =
   | Iintop _ -> Op_pure
   | Iintop_imm(Icheckbound, _) -> Op_checkbound
   | Iintop_imm(_, _) -> Op_pure
-  | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+  | Icompf _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat -> Op_pure
   | Ispecific _ -> Op_other
   | Idls_get -> Op_load Mutable
diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml
index 6f9ae9d659..335edfdb5f 100644
--- a/asmcomp/amd64/arch.ml
+++ b/asmcomp/amd64/arch.ml
@@ -152,3 +152,21 @@ let operation_is_pure = function
 (* Specific operations that can raise *)
 
 let operation_can_raise _ = false
+
+open X86_ast
+
+(* Certain float conditions aren't represented directly in the opcode for
+   float comparison, so we have to swap the arguments. The swap information
+   is also needed downstream because one of the arguments is clobbered. *)
+let float_cond_and_need_swap cond =
+  match (cond : Lambda.float_comparison) with
+  | CFeq  -> EQf,  false
+  | CFneq -> NEQf, false
+  | CFlt  -> LTf,  false
+  | CFnlt -> NLTf, false
+  | CFgt  -> LTf,  true
+  | CFngt -> NLTf, true
+  | CFle  -> LEf,  false
+  | CFnle -> NLEf, false
+  | CFge  -> LEf,  true
+  | CFnge -> NLEf, true
diff --git a/asmcomp/amd64/arch.mli b/asmcomp/amd64/arch.mli
index 52a5d3ae2f..ef988a0fe7 100644
--- a/asmcomp/amd64/arch.mli
+++ b/asmcomp/amd64/arch.mli
@@ -76,3 +76,6 @@ val win64 : bool
 val operation_is_pure : specific_operation -> bool
 
 val operation_can_raise : specific_operation -> bool
+
+val float_cond_and_need_swap
+  :  Lambda.float_comparison -> X86_ast.float_condition * bool
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 841f67c507..e2da778605 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -698,6 +698,12 @@ let emit_instr env fallthrough i =
   | Lop(Iintop_imm(op, n)) ->
       (* We have i.arg.(0) = i.res.(0) *)
       instr_for_intop op (int n) (res i 0)
+  | Lop(Icompf cmp) ->
+      let cond, need_swap = float_cond_and_need_swap cmp in
+      let a0, a1 = if need_swap then arg i 1, arg i 0 else arg i 0, arg i 1 in
+      I.cmpsd cond a1 a0;
+      I.movd a0 (res i 0);
+      I.neg (res i 0)
   | Lop(Inegf) ->
       I.xorpd (mem64_rip OWORD (emit_symbol "caml_negf_mask")) (res i 0)
   | Lop(Iabsf) ->
diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index f0fb7d98c4..56377b322c 100644
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -342,22 +342,28 @@ let safe_register_pressure = function
     Iextcall _ -> if win64 then if fp then 7 else 8 else 0
   | _ -> if fp then 10 else 11
 
-let max_register_pressure = function
+let max_register_pressure =
+  let consumes ~int ~float =
+    if fp
+    then [| 12 - int; 16 - float |]
+    else [| 13 - int; 16 - float |]
+  in
+  function
     Iextcall _ ->
-      if win64 then
-        if fp then [| 7; 10 |]  else [| 8; 10 |]
-        else
-        if fp then [| 3; 0 |] else  [| 4; 0 |]
+      if win64
+      then consumes ~int:5 ~float:6
+      else consumes ~int:9 ~float:16
   | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) ->
-    if fp then [| 10; 16 |] else [| 11; 16 |]
+      consumes ~int:2 ~float:0
   | Ialloc _ | Ipoll _ ->
-    if fp then [| 11 - num_destroyed_by_plt_stub; 16 |]
-    else [| 12 - num_destroyed_by_plt_stub; 16 |]
+      consumes ~int:(1 + num_destroyed_by_plt_stub) ~float:0
   | Iintop(Icomp _) | Iintop_imm((Icomp _), _) ->
-    if fp then [| 11; 16 |] else [| 12; 16 |]
+      consumes ~int:1 ~float:0
   | Istore(Single, _, _) ->
-    if fp then [| 12; 15 |] else [| 13; 15 |]
-  | _ -> if fp then [| 12; 16 |] else [| 13; 16 |]
+      consumes ~int:0 ~float:1
+  | Icompf _ ->
+      consumes ~int:0 ~float:1
+  | _ -> consumes ~int:0 ~float:0
 
 (* Layout of the stack frame *)
 
diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
index b59f552e6d..1f973450ec 100644
--- a/asmcomp/amd64/selection.ml
+++ b/asmcomp/amd64/selection.ml
@@ -113,6 +113,18 @@ let pseudoregs_for_operation op arg res =
       ([| rax; rcx |], [| rax |])
   | Iintop(Imod) ->
       ([| rax; rcx |], [| rdx |])
+  | Icompf cond ->
+      (* We need to temporarily store the result of the comparison in a
+         float register, but we don't want to clobber any of the inputs
+         if they would still be live after this operation -- so we
+         add a fresh register as both an input and output. We don't use
+         [destroyed_at_oper], because that forces us to choose a fixed
+         register, which makes it more likely an extra mov would be added
+         to transfer the argument to the fixed register. *)
+      let treg = Reg.create Float in
+      let _,is_swapped = float_cond_and_need_swap cond in
+      (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |])
+    , [| res.(0); treg |]
   (* Other instructions are regular *)
   | _ -> raise Use_default
 
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index 9a40379e14..a0c9f62442 100644
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -490,6 +490,7 @@ module BR = Branch_relaxation.Make (struct
       | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_bytes)
       end
     | Lop (Iintop (Icomp _)) -> 2
+    | Lop (Icompf _) -> 2
     | Lop (Iintop_imm (Icomp _, _)) -> 2
     | Lop (Iintop (Icheckbound)) -> 2
     | Lop (Ispecific (Ifar_intop_checkbound)) -> 3
@@ -656,6 +657,19 @@ let emit_load_literal dst lbl =
     `	ldr	{emit_reg dst}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
   end
 
+
+let name_for_float_comparison = function
+  | CFeq -> "eq"
+  | CFneq -> "ne"
+  | CFlt -> "cc"
+  | CFnlt -> "cs"
+  | CFle -> "ls"
+  | CFnle -> "hi"
+  | CFgt -> "gt"
+  | CFngt -> "le"
+  | CFge -> "ge"
+  | CFnge -> "lt"
+
 (* Output the assembly code for an instruction *)
 
 let emit_instr env i =
@@ -833,6 +847,10 @@ let emit_instr env i =
     | Lop(Iintop(Icomp cmp)) ->
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
+    | Lop(Icompf cmp) ->
+        let comp = name_for_float_comparison cmp in
+        `	fcmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	cset	{emit_reg i.res.(0)}, {emit_string comp}\n`
     | Lop(Iintop_imm(Icomp cmp, n)) ->
         emit_cmpimm i.arg.(0) n;
         `	cset	{emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
@@ -963,19 +981,7 @@ let emit_instr env i =
             let comp = name_for_comparison cmp in
             `	b.{emit_string comp}	{emit_label lbl}\n`
         | Ifloattest cmp ->
-            let comp =
-              match cmp with
-              | CFeq -> "eq"
-              | CFneq -> "ne"
-              | CFlt -> "cc"
-              | CFnlt -> "cs"
-              | CFle -> "ls"
-              | CFnle -> "hi"
-              | CFgt -> "gt"
-              | CFngt -> "le"
-              | CFge -> "ge"
-              | CFnge -> "lt"
-            in
+            let comp = name_for_float_comparison cmp in
             `	fcmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
             `	b.{emit_string comp}	{emit_label lbl}\n`
         | Ioddtest ->
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index b13a01229b..85b3ce9a57 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -60,6 +60,7 @@ type operation =
   | Ialloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo; }
   | Iintop of integer_operation
   | Iintop_imm of integer_operation * int
+  | Icompf of float_comparison
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat
   | Iopaque
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index f7c4c3abad..e3e9b06513 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -61,6 +61,7 @@ type operation =
   | Ialloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo; }
   | Iintop of integer_operation
   | Iintop_imm of integer_operation * int
+  | Icompf of float_comparison
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat
   | Iopaque
diff --git a/asmcomp/polling.ml b/asmcomp/polling.ml
index c8ca125ac6..6959660f1e 100644
--- a/asmcomp/polling.ml
+++ b/asmcomp/polling.ml
@@ -259,7 +259,7 @@ let find_poll_alloc_or_calls instr =
             Iconst_symbol _ | Iextcall { alloc = false } | Istackoffset _ |
             Iload _ | Istore _ | Iintop _ | Iintop_imm _ | Ifloatofint |
             Iintoffloat | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf |
-            Iopaque | Ispecific _ | Idls_get) -> None
+            Iopaque | Ispecific _ | Idls_get | Icompf _) -> None
       | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ |
         Itrywith _ | Iraise _ -> None
     in
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index 422e558ed0..ed96111671 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -275,6 +275,27 @@ let emit_set_comp cmp res =
   | _ -> ()
   end
 
+let emit_float_comp cmp arg =
+  `	fcmpu	0, {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`;
+  (* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
+  let bitnum =
+    match cmp with
+    | CFeq | CFneq -> 2
+    | CFle | CFnle ->
+    `	cror	3, 0, 2\n`; (* lt or eq *)
+    3
+    | CFgt | CFngt -> 1
+    | CFge | CFnge ->
+    `	cror	3, 1, 2\n`; (* gt or eq *)
+    3
+    | CFlt | CFnlt -> 0
+  in
+  match cmp with
+  | CFneq | CFngt | CFnge | CFnlt | CFnle ->
+    bitnum, true
+  | CFeq | CFgt | CFge | CFlt | CFle ->
+    bitnum, false
+
 (* Free the stack frame *)
 
 let emit_free_frame env =
@@ -478,6 +499,9 @@ module BR = Branch_relaxation.Make (struct
     | Lop(Ispecific(Ipoll_far { return_label = None } )) -> 4
     | Lop(Iintop Imod) -> 3
     | Lop(Iintop(Icomp _)) -> 4
+    | Lop(Icompf _) ->
+        Misc.fatal_error "Icompf is not implemented for this platform";
+        (* 5 *)
     | Lop(Iintop _) -> 1
     | Lop(Iintop_imm(Icomp _, _)) -> 4
     | Lop(Iintop_imm _) -> 1
@@ -821,6 +845,21 @@ let emit_instr env i =
             `	{emit_string cmplg}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
             emit_set_comp c i.res.(0)
         end
+    | Lop(Icompf cmp) ->
+        ignore cmp;
+        Misc.fatal_error "Icompf is not implemented for this platform";
+        (* smuenzel: the following code may be used to implement
+           Icompf when this platform is supported again post 5.0.
+           It will need to be tested.
+           {[
+             let res = i.res.(0) in
+             let bitnum, negated = emit_float_comp cmp i.arg in
+             `	mfcr	0\n`;
+             `	rlwinm	{emit_reg res}, 0, {emit_int(bitnum+1)}, 31, 31\n`;
+             if negated
+             then `  xori  {emit_reg res}, {emit_reg res}, 1\n`
+           ]}
+        *)
     | Lop(Iintop (Icheckbound)) ->
         if !Clflags.debug then
           record_frame env Reg.Set.empty (Dbg_other i.dbg);
@@ -918,25 +957,10 @@ let emit_instr env i =
             `	{emit_string comp}i	{emit_reg i.arg.(0)}, {emit_int n}\n`;
             `	{emit_string branch}	{emit_label lbl}\n`
         | Ifloattest cmp -> begin
-            `	fcmpu	0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-            (* bit 0 = lt, bit 1 = gt, bit 2 = eq *)
-            let bitnum =
-              match cmp with
-              | CFeq | CFneq -> 2
-              | CFle | CFnle ->
-                `	cror	3, 0, 2\n`; (* lt or eq *)
-                3
-              | CFgt | CFngt -> 1
-              | CFge | CFnge ->
-                `	cror	3, 1, 2\n`; (* gt or eq *)
-                3
-              | CFlt | CFnlt -> 0
-            in
-            match cmp with
-            | CFneq | CFngt | CFnge | CFnlt | CFnle ->
-               `	bf	{emit_int bitnum}, {emit_label lbl}\n`
-            | CFeq | CFgt | CFge | CFlt | CFle ->
-               `	bt	{emit_int bitnum}, {emit_label lbl}\n`
+            let bitnum, negated = emit_float_comp cmp i.arg in
+            if negated
+            then `	bf	{emit_int bitnum}, {emit_label lbl}\n`
+            else `	bt	{emit_int bitnum}, {emit_label lbl}\n`
           end
         | Ioddtest ->
             `	andi.	0, {emit_reg i.arg.(0)}, 1\n`;
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 89f12e8504..5180ab9d20 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -143,6 +143,7 @@ let operation op arg ppf res =
     fprintf ppf "alloc %i" n;
   | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1)
   | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n
+  | Icompf cmp -> fprintf ppf "%a%s%a" reg arg.(0) (floatcomp cmp) reg arg.(1)
   | Inegf -> fprintf ppf "-f %a" reg arg.(0)
   | Iabsf -> fprintf ppf "absf %a" reg arg.(0)
   | Iaddf -> fprintf ppf "%a +f %a" reg arg.(0) reg arg.(1)
diff --git a/asmcomp/riscv/emit.mlp b/asmcomp/riscv/emit.mlp
index 6bb703b29d..bcc9d12947 100644
--- a/asmcomp/riscv/emit.mlp
+++ b/asmcomp/riscv/emit.mlp
@@ -149,6 +149,21 @@ let emit_float_load rd ofs rs =
 let emit_float_store rs ofs rd =
   emit_mem_op "fsd" (reg_name rs) ofs rd
 
+let emit_float_test cmp ~arg ~res =
+  let negated =
+    match cmp with
+    | CFneq | CFnlt | CFngt | CFnle | CFnge -> true
+    | CFeq | CFlt | CFgt | CFle | CFge -> false
+  in
+  begin match cmp with
+  | CFeq | CFneq -> `	feq.d	{emit_reg res}, {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`
+  | CFlt | CFnlt -> `	flt.d	{emit_reg res}, {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`
+  | CFgt | CFngt -> `	flt.d	{emit_reg res}, {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`
+  | CFle | CFnle -> `	fle.d	{emit_reg res}, {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`
+  | CFge | CFnge -> `	fle.d	{emit_reg res}, {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`
+  end;
+  negated
+
 (* Record live pointers at call points *)
 
 let record_frame_label env live dbg =
@@ -455,6 +470,9 @@ let emit_instr env i =
           `	sltu	{emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
           `	xori	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
       end
+  | Lop(Icompf cmp) ->
+      let negated = emit_float_test cmp ~res:i.res.(0) ~arg:i.arg in
+      if negated then `	xori	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
   | Lop(Iintop (Icheckbound)) ->
       let lbl = bound_error_label env i.dbg in
       `	bleu	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
@@ -514,18 +532,12 @@ let emit_instr env i =
       | Iinttest_imm _ ->
           Misc.fatal_error "Emit.emit_instr (Iinttest_imm _)"
       | Ifloattest cmp ->
+          let negated = emit_float_test cmp ~arg:i.arg ~res:reg_tmp in
           let branch =
-            match cmp with
-            | CFneq | CFnlt | CFngt | CFnle | CFnge -> "beqz"
-            | CFeq | CFlt | CFgt | CFle | CFge -> "bnez"
+            if negated
+            then "beqz"
+            else "bnez"
           in
-          begin match cmp with
-          | CFeq | CFneq -> `	feq.d	{emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
-          | CFlt | CFnlt -> `	flt.d	{emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
-          | CFgt | CFngt -> `	flt.d	{emit_reg reg_tmp}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
-          | CFle | CFnle -> `	fle.d	{emit_reg reg_tmp}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
-          | CFge | CFnge -> `	fle.d	{emit_reg reg_tmp}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
-          end;
           `	{emit_string branch}	{emit_reg reg_tmp}, {emit_label lbl}\n`
       | Ioddtest ->
           `	andi	{emit_reg reg_tmp}, {emit_reg i.arg.(0)}, 1\n`;
diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
index 7088edadeb..49494965ee 100644
--- a/asmcomp/s390x/emit.mlp
+++ b/asmcomp/s390x/emit.mlp
@@ -469,6 +469,14 @@ let emit_instr env i =
         `	brc	{emit_int mask}, {emit_label lbl}\n`;
         `	lghi	{emit_reg i.res.(0)}, 0\n`;
         `{emit_label lbl}:\n`
+    | Lop(Icompf cmp) ->
+        let lbl = new_label() in
+        `	cdbr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 1\n`;
+        let mask = branch_for_float_comparison cmp in
+        `	brc	  {emit_int mask}, {emit_label lbl}\n`;
+        `	lghi	{emit_reg i.res.(0)}, 0\n`;
+        `{emit_label lbl}:\n`
     | Lop(Iintop (Icheckbound)) ->
         let lbl = bound_error_label env i.dbg in
         `	clgr	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 3b576f23fa..0758696f88 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -483,6 +483,7 @@ method select_operation op args _dbg =
   | (Caddv, _) -> self#select_arith_comm Iadd args
   | (Cadda, _) -> self#select_arith_comm Iadd args
   | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args
+  | (Ccmpf comp, _) -> (Icompf comp, args)
   | (Cnegf, _) -> (Inegf, args)
   | (Cabsf, _) -> (Iabsf, args)
   | (Caddf, _) -> (Iaddf, args)
@@ -677,12 +678,6 @@ method emit_expr (env:environment) exp =
           self#insert_debug env  (Iraise k) dbg rd [||];
           None
       end
-  | Cop(Ccmpf _, _, dbg) ->
-      self#emit_expr env
-        (Cifthenelse (exp,
-          dbg, Cconst_int (1, dbg),
-          dbg, Cconst_int (0, dbg),
-          dbg))
   | Cop(Copaque, args, dbg) ->
       begin match self#emit_parts_list env args with
         None -> None
diff --git a/asmcomp/x86_ast.mli b/asmcomp/x86_ast.mli
index d3355bdf5b..7cd2817f8c 100644
--- a/asmcomp/x86_ast.mli
+++ b/asmcomp/x86_ast.mli
@@ -25,6 +25,16 @@ type condition =
   | S | NS     (* sign *)
   | P | NP     (* parity *)
 
+type float_condition =
+  | EQf
+  | LTf
+  | LEf
+  | UNORDf
+  | NEQf
+  | NLTf
+  | NLEf
+  | ORDf
+
 type rounding =
   | RoundUp
   | RoundDown
@@ -104,6 +114,7 @@ type instruction =
   | CDQ
   | CMOV of condition * arg * arg
   | CMP of arg * arg
+  | CMPSD of float_condition * arg * arg
   | COMISD of arg * arg
   | CQO
   | CVTSD2SI of arg * arg
@@ -157,6 +168,7 @@ type instruction =
   | LEAVE
   | MOV of arg * arg
   | MOVAPD of arg * arg
+  | MOVD of arg * arg
   | MOVLPD of arg * arg
   | MOVSD of arg * arg
   | MOVSS of arg * arg
diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml
index 1a1dba4232..18afddaa93 100644
--- a/asmcomp/x86_dsl.ml
+++ b/asmcomp/x86_dsl.ml
@@ -121,6 +121,7 @@ module I = struct
   let call x = emit (CALL x)
   let cdq () = emit CDQ
   let cmp x y = emit (CMP (x, y))
+  let cmpsd cond x y = emit (CMPSD (cond, x, y))
   let comisd x y = emit (COMISD (x, y))
   let cqo () = emit CQO
   let cvtsd2ss x y = emit (CVTSD2SS (x, y))
@@ -180,12 +181,14 @@ module I = struct
   let lea x y = emit (LEA (x, y))
   let mov x y = emit (MOV (x, y))
   let movapd x y = emit (MOVAPD (x, y))
+  let movd x y = emit (MOVD (x, y))
   let movsd x y = emit (MOVSD (x, y))
   let movss x y = emit (MOVSS (x, y))
   let movsx x y = emit (MOVSX (x, y))
   let movsxd x y = emit (MOVSXD  (x, y))
   let movzx x y = emit (MOVZX (x, y))
   let mulsd x y = emit (MULSD (x, y))
+  let neg x = emit (NEG x)
   let nop () = emit NOP
   let or_ x y = emit (OR (x, y))
   let pop x = emit (POP x)
diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli
index 9827836f82..e6b11d31f0 100644
--- a/asmcomp/x86_dsl.mli
+++ b/asmcomp/x86_dsl.mli
@@ -114,6 +114,7 @@ module I : sig
   val call: arg -> unit
   val cdq: unit -> unit
   val cmp: arg -> arg -> unit
+  val cmpsd : float_condition -> arg -> arg -> unit
   val comisd: arg -> arg -> unit
   val cqo: unit -> unit
   val cvtsd2ss: arg -> arg -> unit
@@ -173,12 +174,14 @@ module I : sig
   val lea: arg -> arg -> unit
   val mov: arg -> arg -> unit
   val movapd: arg -> arg -> unit
+  val movd: arg -> arg -> unit
   val movsd: arg -> arg -> unit
   val movss: arg -> arg -> unit
   val movsx: arg -> arg -> unit
   val movsxd: arg -> arg -> unit
   val movzx: arg -> arg -> unit
   val mulsd: arg -> arg -> unit
+  val neg : arg -> unit
   val nop: unit -> unit
   val or_: arg -> arg -> unit
   val pop: arg -> unit
diff --git a/asmcomp/x86_gas.ml b/asmcomp/x86_gas.ml
index 4576e2a512..de11014970 100644
--- a/asmcomp/x86_gas.ml
+++ b/asmcomp/x86_gas.ml
@@ -124,6 +124,8 @@ let print_instr b = function
   | CDQ -> i0 b "cltd"
   | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2
   | CMP (arg1, arg2) -> i2_s b "cmp" arg1 arg2
+  | CMPSD (c, arg1, arg2) ->
+      i2 b ("cmp" ^ string_of_float_condition c ^ "sd") arg1 arg2
   | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2
   | CQO ->  i0 b "cqto"
   | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2
@@ -189,6 +191,7 @@ let print_instr b = function
       i2 b "movabsq" arg1 arg2
   | MOV (arg1, arg2) -> i2_s b "mov" arg1 arg2
   | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2
+  | MOVD (arg1, arg2) -> i2 b "movd" arg1 arg2
   | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2
   | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2
   | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2
diff --git a/asmcomp/x86_masm.ml b/asmcomp/x86_masm.ml
index aa74e0c933..10668b0206 100644
--- a/asmcomp/x86_masm.ml
+++ b/asmcomp/x86_masm.ml
@@ -124,6 +124,8 @@ let print_instr b = function
   | CDQ -> i0 b "cdq"
   | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2
   | CMP (arg1, arg2) -> i2 b "cmp" arg1 arg2
+  | CMPSD (c, arg1, arg2) ->
+      i2 b ("cmp" ^ string_of_float_condition c ^ "sd") arg1 arg2
   | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2
   | CQO -> i0 b "cqo"
   | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2
@@ -184,6 +186,7 @@ let print_instr b = function
       i2 b "mov" arg1 (Reg32 r)
   | MOV (arg1, arg2) -> i2 b "mov" arg1 arg2
   | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2
+  | MOVD (arg1, arg2) -> i2 b "movd" arg1 arg2
   | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2
   | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2
   | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2
diff --git a/asmcomp/x86_proc.ml b/asmcomp/x86_proc.ml
index ee1ded3d69..e5a76d8e5f 100644
--- a/asmcomp/x86_proc.ml
+++ b/asmcomp/x86_proc.ml
@@ -221,6 +221,16 @@ let string_of_condition = function
   | NO -> "no"
   | O -> "o"
 
+let string_of_float_condition = function
+  | EQf -> "eq"
+  | LTf -> "lt"
+  | LEf -> "le"
+  | UNORDf -> "unord"
+  | NEQf -> "neq"
+  | NLTf -> "nlt"
+  | NLEf -> "nle"
+  | ORDf -> "ord"
+
 let string_of_rounding = function
   | RoundDown -> "roundsd.down"
   | RoundUp -> "roundsd.up"
diff --git a/asmcomp/x86_proc.mli b/asmcomp/x86_proc.mli
index 3bb7021a00..267ec72314 100644
--- a/asmcomp/x86_proc.mli
+++ b/asmcomp/x86_proc.mli
@@ -28,6 +28,7 @@ val string_of_reg64: reg64 -> string
 val string_of_registerf: registerf -> string
 val string_of_string_literal: string -> string
 val string_of_condition: condition -> string
+val string_of_float_condition: float_condition -> string
 val string_of_symbol: (*prefix*) string -> string -> string
 val string_of_rounding: rounding -> string
 val buf_bytes_directive: