- Constant ropagation for float and int32/int64/nativeint arithmetic.

  Constant propagation for floats can be turned off with option
  -no-float-const-prop, for codes that change FP rounding modes at
  run-time.
- Clambda / C-- / Mach: represent float constants as FP numbers of type 
  float rather than literals of type string.
- Tested for AMD64; other archs need testing.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14673 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

32 files changed, 582 insertions, 233 deletions

diff --git a/Changes b/Changes
index 3a9bc539b6..4a649b428a 100644
--- a/Changes
+++ b/Changes
@@ -35,6 +35,10 @@ Type system:
   representation is unchanged.
 
 Compilers:
+- More aggressive constant propagation, including float and
+  int32/int64/nativeint arithmetic.  Constant propagation for floats
+  can be turned off with option -no-float-const-prop, for codes that
+  change FP rounding modes at run-time.
 - PR#6269 Optimization of string matching (patch by Benoit Vaugon
   and Luc Maranget)
 - Experimental native code generator for AArch64 (ARM 64 bits)
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index bdcc3a18d3..bea7e9331a 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -335,15 +335,16 @@ let output_epilogue f =
 
 (* Floating-point constants *)
 
-let float_constants = ref ([] : (string * int) list)
+let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
+  let repr = Int64.bits_of_float cst in
   try
-    List.assoc cst !float_constants
+    List.assoc repr !float_constants
   with
     Not_found ->
       let lbl = new_label() in
-      float_constants := (cst, lbl) :: !float_constants;
+      float_constants := (repr, lbl) :: !float_constants;
       lbl
 
 let emit_float_constant (cst, lbl) =
@@ -382,12 +383,12 @@ let emit_instr fallthrough i =
           `	movq	${emit_nativeint n}, {emit_reg i.res.(0)}\n`
         else
           `	movabsq	${emit_nativeint n}, {emit_reg i.res.(0)}\n`
-    | Lop(Iconst_float s) ->
-        begin match Int64.bits_of_float (float_of_string s) with
+    | Lop(Iconst_float f) ->
+        begin match Int64.bits_of_float f with
         | 0x0000_0000_0000_0000L ->       (* +0.0 *)
           `	xorpd	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
         | _ ->
-          let lbl = add_float_constant s in
+          let lbl = add_float_constant f in
           `	movsd	{emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
         end
     | Lop(Iconst_symbol s) ->
@@ -764,9 +765,9 @@ let emit_item = function
   | Cint n ->
       `	.quad	{emit_nativeint n}\n`
   | Csingle f ->
-      emit_float32_directive ".long" f
+      emit_float32_directive ".long" (Int32.bits_of_float f)
   | Cdouble f ->
-      emit_float64_directive ".quad" f
+      emit_float64_directive ".quad" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `	.quad	{emit_symbol s}\n`
   | Clabel_address lbl ->
diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp
index 77156b8f01..52e8e166ae 100644
--- a/asmcomp/amd64/emit_nt.mlp
+++ b/asmcomp/amd64/emit_nt.mlp
@@ -321,36 +321,21 @@ let output_epilogue () =
 
 (* Floating-point constants *)
 
-let float_constants = ref ([] : (string * int) list)
+let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
+  let repr = Int64.bits_of_float cst in
   try
-    List.assoc cst !float_constants
+    List.assoc repr !float_constants
   with
     Not_found ->
       let lbl = new_label() in
-      float_constants := (cst, lbl) :: !float_constants;
+      float_constants := (repr, lbl) :: !float_constants;
       lbl
 
-let emit_float s =
-  (* MASM doesn't like floating-point constants such as 2e9.
-     Turn them into 2.0e9. *)
-  let pos_e = ref (-1) and pos_dot = ref (-1) in
-  for i = 0 to String.length s - 1 do
-    match s.[i] with
-      'e'|'E' -> pos_e := i
-    | '.'     -> pos_dot := i
-    | _       -> ()
-  done;
-  if !pos_dot < 0 && !pos_e >= 0 then begin
-    emit_string (String.sub s 0 !pos_e);
-    emit_string ".0";
-    emit_string (String.sub s !pos_e (String.length s - !pos_e))
-  end else
-    emit_string s
-
 let emit_float_constant (cst, lbl) =
-  `{emit_label lbl}     REAL8   {emit_float cst}\n`
+  `{emit_label lbl}:`;
+  emit_float64_directive "QWORD" cst
 
 let emit_movabs reg n =
   (* force ml64 to use mov reg, imm64 instruction *)
@@ -721,9 +706,9 @@ let emit_item = function
   | Cint n ->
       `	QWORD	{emit_nativeint n}\n`
   | Csingle f ->
-      `	REAL4	{emit_float f}\n`
+      emit_float32_directive "DWORD" (Int32.bits_of_float f)
   | Cdouble f ->
-      `	REAL8	{emit_float f}\n`
+      emit_float64_directive "QWORD" (Int64.bits_of_float f)
   | Csymbol_address s ->
       add_used_symbol s;
       `	QWORD	{emit_symbol s}\n`
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index 2f20ecf61a..18c873de26 100644
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -273,7 +273,7 @@ let function_name = ref ""
 (* Entry point for tail recursive calls *)
 let tailrec_entry_point = ref 0
 (* Pending floating-point literals *)
-let float_literals = ref ([] : (string * label) list)
+let float_literals = ref ([] : (int64 * label) list)
 (* Pending relative references to the global offset table *)
 let gotrel_literals = ref ([] : (label * label) list)
 (* Pending symbol literals *)
@@ -283,12 +283,13 @@ let num_literals = ref 0
 
 (* Label a floating-point literal *)
 let float_literal f =
+  let repr = Int64.bits_of_float cst in
   try
-    List.assoc f !float_literals
+    List.assoc repr !float_literals
   with Not_found ->
     let lbl = new_label() in
     num_literals := !num_literals + 2;
-    float_literals := (f, lbl) :: !float_literals;
+    float_literals := (repr, lbl) :: !float_literals;
     lbl
 
 (* Label a GOTREL literal *)
@@ -314,7 +315,7 @@ let emit_literals() =
     `	.align	3\n`;
     List.iter
       (fun (f, lbl) ->
-        `{emit_label lbl}:	.double	{emit_string f}\n`)
+        `{emit_label lbl}:`; emit_float64_split_directive ".long" f)
       !float_literals;
     float_literals := []
   end;
@@ -874,8 +875,8 @@ let emit_item = function
   | Cint16 n -> `	.short	{emit_int n}\n`
   | Cint32 n -> `	.long	{emit_int32 (Nativeint.to_int32 n)}\n`
   | Cint n -> `	.long	{emit_int32 (Nativeint.to_int32 n)}\n`
-  | Csingle f -> `	.single	{emit_string f}\n`
-  | Cdouble f -> `	.double	{emit_string f}\n`
+  | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f)
   | Csymbol_address s -> `	.word	{emit_symbol s}\n`
   | Clabel_address lbl -> `	.word	{emit_data_label lbl}\n`
   | Cstring s -> emit_string_directive "	.ascii  " s
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index 4a3e3cd7b4..eaab3ef486 100644
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -286,7 +286,7 @@ let emit_literals() =
     `	.align	3\n`;
     List.iter
       (fun (f, lbl) ->
-        `{emit_label lbl}:	.quad	`; emit_printf "0x%Lx\n" f)
+        `{emit_label lbl}:`; emit_float64_directive ".quad" f)
       !float_literals;
     float_literals := []
   end
@@ -326,7 +326,7 @@ let emit_instr i =
     | Lop(Iconst_int n | Iconst_blockheader n) ->
         emit_intconst i.res.(0) n
     | Lop(Iconst_float f) ->
-        let b = Int64.bits_of_float(float_of_string f) in
+        let b = Int64.bits_of_float f in
         if b = 0L then
           `	fmov	{emit_reg i.res.(0)}, xzr	/* {emit_string f} */\n`
         else if is_immediate_float b then
@@ -334,7 +334,7 @@ let emit_instr i =
         else begin
           let lbl = float_literal b in
           `	adrp	{emit_reg reg_tmp1}, {emit_label lbl}\n`;
-          `	ldr	{emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]	/* {emit_string f} */\n`
+          `	ldr	{emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
         end
     | Lop(Iconst_symbol s) ->
         emit_load_symbol_addr i.res.(0) s
@@ -675,8 +675,8 @@ let emit_item = function
   | Cint16 n -> `	.short	{emit_int n}\n`
   | Cint32 n -> `	.long	{emit_nativeint n}\n`
   | Cint n -> `	.quad	{emit_nativeint n}\n`
-  | Csingle f -> emit_float32_directive ".long" f
-  | Cdouble f -> emit_float64_directive ".quad" f
+  | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
+  | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f)
   | Csymbol_address s -> `	.quad	{emit_symbol s}\n`
   | Clabel_address lbl -> `	.quad	{emit_data_label lbl}\n`
   | Cstring s -> emit_string_directive "	.ascii  " s
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 3586296e4f..4088265337 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -19,12 +19,12 @@ open Lambda
 type function_label = string
 
 type ustructured_constant =
-  | Uconst_float of string
+  | Uconst_float of float
   | Uconst_int32 of int32
   | Uconst_int64 of int64
   | Uconst_nativeint of nativeint
   | Uconst_block of int * uconstant list
-  | Uconst_float_array of string list
+  | Uconst_float_array of float list
   | Uconst_string of string
 
 and uconstant =
@@ -74,7 +74,9 @@ type function_description =
   { fun_label: function_label;          (* Label of direct entry point *)
     fun_arity: int;                     (* Number of arguments *)
     mutable fun_closed: bool;           (* True if environment not used *)
-    mutable fun_inline: (Ident.t list * ulambda) option }
+    mutable fun_inline: (Ident.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
 
 (* Approximation of values *)
 
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index e751326fe4..abb0e9c626 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -19,12 +19,12 @@ open Lambda
 type function_label = string
 
 type ustructured_constant =
-  | Uconst_float of string
+  | Uconst_float of float
   | Uconst_int32 of int32
   | Uconst_int64 of int64
   | Uconst_nativeint of nativeint
   | Uconst_block of int * uconstant list
-  | Uconst_float_array of string list
+  | Uconst_float_array of float list
   | Uconst_string of string
 
 and uconstant =
@@ -74,7 +74,9 @@ type function_description =
   { fun_label: function_label;          (* Label of direct entry point *)
     fun_arity: int;                     (* Number of arguments *)
     mutable fun_closed: bool;           (* True if environment not used *)
-    mutable fun_inline: (Ident.t list * ulambda) option }
+    mutable fun_inline: (Ident.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
 
 (* Approximation of values *)
 
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index eff35ce4f2..2f37e0fcc7 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -245,14 +245,15 @@ let rec is_pure_clambda = function
   | Uprim(p, args, _) -> List.for_all is_pure_clambda args
   | _ -> false
 
-(* Simplify primitive operations on integers *)
+(* Simplify primitive operations on known arguments *)
 
 let make_const c = (Uconst c, Value_const c)
-
+let make_const_ref c =
+  make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c))
 let make_const_int n = make_const (Uconst_int n)
 let make_const_ptr n = make_const (Uconst_ptr n)
 let make_const_bool b = make_const_ptr(if b then 1 else 0)
-let make_comparison cmp (x: int) (y: int) =
+let make_comparison cmp x y =
   make_const_bool
     (match cmp with
        Ceq -> x = y
@@ -261,71 +262,187 @@ let make_comparison cmp (x: int) (y: int) =
      | Cgt -> x > y
      | Cle -> x <= y
      | Cge -> x >= y)
+let make_const_float n = make_const_ref (Uconst_float n)
+let make_const_natint n = make_const_ref (Uconst_nativeint n)
+let make_const_int32 n = make_const_ref (Uconst_int32 n)
+let make_const_int64 n = make_const_ref (Uconst_int64 n)
+
+(* The [fpc] parameter is true if constant propagation of
+   floating-point computations is allowed *)
 
-let simplif_int_prim_pure p (args, approxs) dbg =
+let simplif_arith_prim_pure fpc p (args, approxs) dbg =
+  let default = (Uprim(p, args, dbg), Value_unknown) in
   match approxs with
-    [Value_const (Uconst_int x)] ->
+  (* int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] ->
       begin match p with
-        Pidentity -> make_const_int x
-      | Pnegint -> make_const_int (-x)
-      | Pbswap16 ->
-         make_const_int (((x land 0xff) lsl 8) lor
-                         ((x land 0xff00) lsr 8))
-      | Poffsetint y -> make_const_int (x + y)
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Pnot -> make_const_bool (n1 = 0)
+      | Pnegint -> make_const_int (- n1)
+      | Poffsetint n -> make_const_int (n + n1)
+      | Pfloatofint when fpc -> make_const_float (float_of_int n1)
+      | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1)
+      | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1)
+      | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1)
+      | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8)
+                                    lor ((n1 land 0xff00) lsr 8))
+      | _ -> default
       end
-  | [Value_const (Uconst_int x); Value_const (Uconst_int y)] ->
+  (* int (or enumerated type), int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1);
+      Value_const(Uconst_int n2 | Uconst_ptr n2) ] ->
       begin match p with
-        Paddint -> make_const_int(x + y)
-      | Psubint -> make_const_int(x - y)
-      | Pmulint -> make_const_int(x * y)
-      | Pdivint when y <> 0 -> make_const_int(x / y)
-      | Pmodint when y <> 0 -> make_const_int(x mod y)
-      | Pandint -> make_const_int(x land y)
-      | Porint -> make_const_int(x lor y)
-      | Pxorint -> make_const_int(x lxor y)
-      | Plslint -> make_const_int(x lsl y)
-      | Plsrint -> make_const_int(x lsr y)
-      | Pasrint -> make_const_int(x asr y)
-      | Pintcomp cmp -> make_comparison cmp x y
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0)
+      | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0)
+      | Paddint -> make_const_int (n1 + n2)
+      | Psubint -> make_const_int (n1 - n2)
+      | Pmulint -> make_const_int (n1 * n2)
+      | Pdivint when n2 <> 0 -> make_const_int (n1 / n2)
+      | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2)
+      | Pandint -> make_const_int (n1 land n2)
+      | Porint -> make_const_int (n1 lor n2)
+      | Pxorint -> make_const_int (n1 lxor n2)
+      | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 lsl n2)
+      | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 lsr n2)
+      | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_int (n1 asr n2)
+      | Pintcomp c -> make_comparison c n1 n2
+      | _ -> default
       end
-  | [Value_const (Uconst_ptr x)] ->
+  (* float *)
+  | [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc ->
       begin match p with
-        Pidentity -> make_const_ptr x
-      | Pnot -> make_const_bool(x = 0)
-      | Pisint -> make_const_bool true
-      | Pctconst c ->
-          begin
-            match c with
-            | Big_endian -> make_const_bool Arch.big_endian
-            | Word_size -> make_const_int (8*Arch.size_int)
-            | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
-            | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
-            | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
-          end
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Pintoffloat -> make_const_int (int_of_float n1)
+      | Pnegfloat -> make_const_float (-. n1)
+      | Pabsfloat -> make_const_float (abs_float n1)
+      | _ -> default
       end
-  | [Value_const (Uconst_ptr x); Value_const (Uconst_ptr y)] ->
+  (* float, float *)
+  | [Value_const(Uconst_ref(_, Uconst_float n1));
+     Value_const(Uconst_ref(_, Uconst_float n2))] when fpc ->
       begin match p with
-        Psequand -> make_const_bool(x <> 0 && y <> 0)
-      | Psequor  -> make_const_bool(x <> 0 || y <> 0)
-      | Pintcomp cmp -> make_comparison cmp x y
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Paddfloat -> make_const_float (n1 +. n2)
+      | Psubfloat -> make_const_float (n1 -. n2)
+      | Pmulfloat -> make_const_float (n1 *. n2)
+      | Pdivfloat -> make_const_float (n1 /. n2)
+      | Pfloatcomp c  -> make_comparison c n1 n2
+      | _ -> default
       end
-  | [Value_const (Uconst_ptr x); Value_const (Uconst_int y)] ->
+  (* nativeint *)
+  | [Value_const(Uconst_ref(_, Uconst_nativeint n))] ->
       begin match p with
-      | Pintcomp cmp -> make_comparison cmp x y
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n)
+      | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n)
+      | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n)
+      | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n)
+      | _ -> default
       end
-  | [Value_const (Uconst_int x); Value_const (Uconst_ptr y)] ->
+  (* nativeint, nativeint *)
+  | [Value_const(Uconst_ref(_, Uconst_nativeint n1));
+     Value_const(Uconst_ref(_, Uconst_nativeint n2))] ->
       begin match p with
-      | Pintcomp cmp -> make_comparison cmp x y
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)
+      | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)
+      | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2)
+      | Pdivbint Pnativeint when n2 <> 0n ->
+          make_const_natint (Nativeint.div n1 n2)
+      | Pmodbint Pnativeint when n2 <> 0n ->
+          make_const_natint (Nativeint.rem n1 n2)
+      | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)
+      | Porbint Pnativeint ->  make_const_natint (Nativeint.logor n1 n2)
+      | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2)
+      | Pbintcomp(Pnativeint, c)  -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* nativeint, int *)
+  | [Value_const(Uconst_ref(_, Uconst_nativeint n1));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_left n1 n2)
+      | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_right_logical n1 n2)
+      | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int ->
+          make_const_natint (Nativeint.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int32 *)
+  | [Value_const(Uconst_ref(_, Uconst_int32 n))] ->
+      begin match p with
+      | Pintofbint Pint32 -> make_const_int (Int32.to_int n)
+      | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n)
+      | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n)
+      | Pnegbint Pint32 -> make_const_int32 (Int32.neg n)
+      | _ -> default
+      end
+  (* int32, int32 *)
+  | [Value_const(Uconst_ref(_, Uconst_int32 n1));
+     Value_const(Uconst_ref(_, Uconst_int32 n2))] ->
+      begin match p with
+      | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)
+      | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)
+      | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2)
+      | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2)
+      | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2)
+      | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)
+      | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)
+      | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)
+      | Pbintcomp(Pint32, c) -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* int32, int *)
+  | [Value_const(Uconst_ref(_, Uconst_int32 n1));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_left n1 n2)
+      | Plsrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right_logical n1 n2)
+      | Pasrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int64 *)
+  | [Value_const(Uconst_ref(_, Uconst_int64 n))] ->
+      begin match p with
+      | Pintofbint Pint64 -> make_const_int (Int64.to_int n)
+      | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n)
+      | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n)
+      | Pnegbint Pint64 -> make_const_int64 (Int64.neg n)
+      | _ -> default
+      end
+  (* int64, int64 *)
+  | [Value_const(Uconst_ref(_, Uconst_int64 n1));
+     Value_const(Uconst_ref(_, Uconst_int64 n2))] ->
+      begin match p with
+      | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)
+      | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)
+      | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2)
+      | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2)
+      | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2)
+      | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)
+      | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)
+      | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)
+      | Pbintcomp(Pint64, c) -> make_comparison c n1 n2
+      | _ -> default
+      end
+  (* int64, int *)
+  | [Value_const(Uconst_ref(_, Uconst_int64 n1));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_left n1 n2)
+      | Plsrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right_logical n1 n2)
+      | Pasrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right n1 n2)
+      | _ -> default
       end
+  (* TODO: Pbbswap *)
+  (* Catch-all *)
   | _ ->
-      (Uprim(p, args, dbg), Value_unknown)
-
+     default
 
 let field_approx n = function
   | Value_tuple a when n < Array.length a -> a.(n)
@@ -333,8 +450,9 @@ let field_approx n = function
       Value_const (List.nth l n)
   | _ -> Value_unknown
 
-let simplif_prim_pure p (args, approxs) dbg =
+let simplif_prim_pure fpc p (args, approxs) dbg =
   match p, args, approxs with
+  (* Block construction *)
   | Pmakeblock(tag, Immutable), _, _ ->
       let field = function
         | Value_const c -> c
@@ -349,24 +467,43 @@ let simplif_prim_pure p (args, approxs) dbg =
       with Exit ->
         (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
       end
+  (* Field access *)
   | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ]
     when n < List.length l ->
       make_const (List.nth l n)
-
-  | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] ->
-      assert(n < List.length ul);
-      List.nth ul n, field_approx n approx
-
-  | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ]
-    ->
+  | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] 
+    when n < List.length ul ->
+      (List.nth ul n, field_approx n approx)
+  (* Strings *)
+  | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] ->
       make_const_int (String.length s)
-
+  (* Identity *)
+  | Pidentity, [arg1], [app1] ->
+      (arg1, app1)
+  (* Kind test *)
+  | Pisint, _, [a1] ->
+      begin match a1 with
+      | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true
+      | Value_const(Uconst_ref _) -> make_const_bool false
+      | Value_closure _ | Value_tuple _ -> make_const_bool false
+      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      end
+  (* Compile-time constants *)
+  | Pctconst c, _, _ ->
+      begin match c with
+        | Big_endian -> make_const_bool Arch.big_endian
+        | Word_size -> make_const_int (8*Arch.size_int)
+        | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
+        | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
+        | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+      end
+  (* Catch-all *)
   | _ ->
-      simplif_int_prim_pure p (args, approxs) dbg
+      simplif_arith_prim_pure fpc p (args, approxs) dbg
 
-let simplif_prim p (args, approxs as args_approxs) dbg =
+let simplif_prim fpc p (args, approxs as args_approxs) dbg =
   if List.for_all is_pure_clambda args
-  then simplif_prim_pure p args_approxs dbg
+  then simplif_prim_pure fpc p args_approxs dbg
   else
     (* XXX : always return the same approxs as simplif_prim_pure? *)
     let approx =
@@ -391,15 +528,16 @@ let approx_ulam = function
     Uconst c -> Value_const c
   | _ -> Value_unknown
 
-let rec substitute sb ulam =
+let rec substitute fpc sb ulam =
   match ulam with
     Uvar v ->
       begin try Tbl.find v sb with Not_found -> ulam end
   | Uconst _ -> ulam
   | Udirect_apply(lbl, args, dbg) ->
-      Udirect_apply(lbl, List.map (substitute sb) args, dbg)
+      Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg)
   | Ugeneric_apply(fn, args, dbg) ->
-      Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg)
+      Ugeneric_apply(substitute fpc sb fn,
+                     List.map (substitute fpc sb) args, dbg)
   | Uclosure(defs, env) ->
       (* Question: should we rename function labels as well?  Otherwise,
          there is a risk that function labels are not globally unique.
@@ -409,11 +547,12 @@ let rec substitute sb ulam =
          - When we substitute offsets for idents bound by let rec
            in [close], case [Lletrec], we discard the original
            let rec body and use only the substituted term. *)
-      Uclosure(defs, List.map (substitute sb) env)
-  | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs)
+      Uclosure(defs, List.map (substitute fpc sb) env)
+  | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs)
   | Ulet(id, u1, u2) ->
       let id' = Ident.rename id in
-      Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2)
+      Ulet(id', substitute fpc sb u1,
+           substitute fpc (Tbl.add id (Uvar id') sb) u2)
   | Uletrec(bindings, body) ->
       let bindings1 =
         List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
@@ -422,57 +561,64 @@ let rec substitute sb ulam =
           (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
           bindings1 sb in
       Uletrec(
-        List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1,
-        substitute sb' body)
+        List.map
+           (fun (id, id', rhs) -> (id', substitute fpc sb' rhs))
+           bindings1,
+        substitute fpc sb' body)
   | Uprim(p, args, dbg) ->
-      let sargs = List.map (substitute sb) args in
-      let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in
+      let sargs =
+        List.map (substitute fpc sb) args in
+      let (res, _) =
+        simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
       res
   | Uswitch(arg, sw) ->
-      Uswitch(substitute sb arg,
+      Uswitch(substitute fpc sb arg,
               { sw with
                 us_actions_consts =
-                  Array.map (substitute sb) sw.us_actions_consts;
+                  Array.map (substitute fpc sb) sw.us_actions_consts;
                 us_actions_blocks =
-                  Array.map (substitute sb) sw.us_actions_blocks;
+                  Array.map (substitute fpc sb) sw.us_actions_blocks;
                })
   | Ustringswitch(arg,sw,d) ->
       Ustringswitch
-        (substitute sb arg,
-         List.map (fun (s,act) -> s,substitute sb act) sw,
-         Misc.may_map (substitute sb) d)
+        (substitute fpc sb arg,
+         List.map (fun (s,act) -> s,substitute fpc sb act) sw,
+         Misc.may_map (substitute fpc sb) d)
   | Ustaticfail (nfail, args) ->
-      Ustaticfail (nfail, List.map (substitute sb) args)
+      Ustaticfail (nfail, List.map (substitute fpc sb) args)
   | Ucatch(nfail, ids, u1, u2) ->
-      Ucatch(nfail, ids, substitute sb u1, substitute sb u2)
+      Ucatch(nfail, ids, substitute fpc sb u1, substitute fpc sb u2)
   | Utrywith(u1, id, u2) ->
       let id' = Ident.rename id in
-      Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
+      Utrywith(substitute fpc sb u1, id',
+               substitute fpc (Tbl.add id (Uvar id') sb) u2)
   | Uifthenelse(u1, u2, u3) ->
-      begin match substitute sb u1 with
+      begin match substitute fpc sb u1 with
         Uconst (Uconst_ptr n) ->
-          if n <> 0 then substitute sb u2 else substitute sb u3
+          if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3
       | Uprim(Pmakeblock _, _, _) ->
-          substitute sb u2
+          substitute fpc sb u2
       | su1 ->
-          Uifthenelse(su1, substitute sb u2, substitute sb u3)
+          Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3)
       end
-  | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2)
-  | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2)
+  | Usequence(u1, u2) ->
+      Usequence(substitute fpc sb u1, substitute fpc sb u2)
+  | Uwhile(u1, u2) ->
+      Uwhile(substitute fpc sb u1, substitute fpc sb u2)
   | Ufor(id, u1, u2, dir, u3) ->
       let id' = Ident.rename id in
-      Ufor(id', substitute sb u1, substitute sb u2, dir,
-           substitute (Tbl.add id (Uvar id') sb) u3)
+      Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir,
+           substitute fpc (Tbl.add id (Uvar id') sb) u3)
   | Uassign(id, u) ->
       let id' =
         try
           match Tbl.find id sb with Uvar i -> i | _ -> assert false
         with Not_found ->
           id in
-      Uassign(id', substitute sb u)
+      Uassign(id', substitute fpc sb u)
   | Usend(k, u1, u2, ul, dbg) ->
-      Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul,
-            dbg)
+      Usend(k, substitute fpc sb u1, substitute fpc sb u2,
+            List.map (substitute fpc sb) ul, dbg)
 
 (* Perform an inline expansion *)
 
@@ -484,12 +630,12 @@ let no_effects = function
   | Uclosure _ -> true
   | u -> is_simple_argument u
 
-let rec bind_params_rec subst params args body =
+let rec bind_params_rec fpc subst params args body =
   match (params, args) with
-    ([], []) -> substitute subst body
+    ([], []) -> substitute fpc subst body
   | (p1 :: pl, a1 :: al) ->
       if is_simple_argument a1 then
-        bind_params_rec (Tbl.add p1 a1 subst) pl al body
+        bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body
       else begin
         let p1' = Ident.rename p1 in
         let u1, u2 =
@@ -500,17 +646,17 @@ let rec bind_params_rec subst params args body =
               a1, Uvar p1'
         in
         let body' =
-          bind_params_rec (Tbl.add p1 u2 subst) pl al body in
+          bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in
         if occurs_var p1 body then Ulet(p1', u1, body')
         else if no_effects a1 then body'
         else Usequence(a1, body')
       end
   | (_, _) -> assert false
 
-let bind_params params args body =
+let bind_params fpc params args body =
   (* Reverse parameters and arguments to preserve right-to-left
      evaluation order (PR#2910). *)
-  bind_params_rec Tbl.empty (List.rev params) (List.rev args) body
+  bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body
 
 (* Check if a lambda term is ``pure'',
    that is without side-effects *and* not containing function definitions *)
@@ -532,8 +678,10 @@ let direct_apply fundesc funct ufunct uargs =
     if fundesc.fun_closed then uargs else uargs @ [ufunct] in
   let app =
     match fundesc.fun_inline with
-      None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
-    | Some(params, body) -> bind_params params app_args body in
+    | None -> 
+        Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
+    | Some(params, body) ->
+        bind_params fundesc.fun_float_const_prop params app_args body in
   (* If ufunct can contain side-effects or function definitions,
      we must make sure that it is evaluated exactly once.
      If the function is not closed, we evaluate ufunct as part of the
@@ -648,14 +796,14 @@ let rec close fenv cenv = function
             str (Uconst_block (tag, List.map transl fields))
         | Const_float_array sl ->
             (* constant float arrays are really immutable *)
-            str (Uconst_float_array sl)
+            str (Uconst_float_array (List.map float_of_string sl))
         | Const_immstring s ->
             str (Uconst_string s)
         | Const_base (Const_string (s, _)) ->
               (* strings (even literal ones) are mutable! *)
               (* of course, the empty string is really immutable *)
             str ~shared:false(*(String.length s = 0)*) (Uconst_string s)
-        | Const_base(Const_float x) -> str (Uconst_float x)
+        | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
         | Const_base(Const_int32 x) -> str (Uconst_int32 x)
         | Const_base(Const_int64 x) -> str (Uconst_int64 x)
         | Const_base(Const_nativeint x) -> str (Uconst_nativeint x)
@@ -749,7 +897,7 @@ let rec close fenv cenv = function
             (fun (id, pos, approx) sb ->
               Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
             infos Tbl.empty in
-        (Ulet(clos_ident, clos, substitute sb ubody),
+        (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody),
          approx)
       end else begin
         (* General case: recursive definition of values *)
@@ -785,7 +933,8 @@ let rec close fenv cenv = function
       (Uprim(Praise k, [ulam], Debuginfo.from_raise ev),
        Value_unknown)
   | Lprim(p, args) ->
-      simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none
+      simplif_prim !Clflags.float_const_prop
+                   p (close_list_approx fenv cenv args) Debuginfo.none
   | Lswitch(arg, sw) ->
       let fn fail =
         let (uarg, _) = close fenv cenv arg in
@@ -925,7 +1074,8 @@ and close_functions fenv cenv fun_defs =
               {fun_label = label;
                fun_arity = (if kind = Tupled then -arity else arity);
                fun_closed = initially_closed;
-               fun_inline = None } in
+               fun_inline = None;
+               fun_float_const_prop = !Clflags.float_const_prop } in
             (id, params, body, fundesc)
         | (_, _) -> fatal_error "Closure.close_functions")
       fun_defs in
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 9a5f3ec6b8..67ee3445fd 100644
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -85,7 +85,7 @@ type operation =
 type expression =
     Cconst_int of int
   | Cconst_natint of nativeint
-  | Cconst_float of string
+  | Cconst_float of float
   | Cconst_symbol of string
   | Cconst_pointer of int
   | Cconst_natpointer of nativeint
@@ -118,8 +118,8 @@ type data_item =
   | Cint16 of int
   | Cint32 of nativeint
   | Cint of nativeint
-  | Csingle of string
-  | Cdouble of string
+  | Csingle of float
+  | Cdouble of float
   | Csymbol_address of string
   | Clabel_address of int
   | Cstring of string
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index be2bd41457..97b8d40971 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -71,7 +71,7 @@ type operation =
 type expression =
     Cconst_int of int
   | Cconst_natint of nativeint
-  | Cconst_float of string
+  | Cconst_float of float
   | Cconst_symbol of string
   | Cconst_pointer of int
   | Cconst_natpointer of nativeint
@@ -104,8 +104,8 @@ type data_item =
   | Cint16 of int
   | Cint32 of nativeint
   | Cint of nativeint
-  | Csingle of string
-  | Cdouble of string
+  | Csingle of float
+  | Cdouble of float
   | Csymbol_address of string
   | Clabel_address of int
   | Cstring of string
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index ccfa977ffa..11212140a2 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -88,16 +88,10 @@ let emit_bytes_directive directive s =
    done;
    if !pos > 0 then emit_char '\n'
 
-(* PR#4813: assemblers do strange things with float literals indeed,
-   so we convert to IEEE representation ourselves and emit float
-   literals as 32- or 64-bit integers. *)
-
-let emit_float64_directive directive f =
-  let x = Int64.bits_of_float (float_of_string f) in
+let emit_float64_directive directive x =
   emit_printf "\t%s\t0x%Lx\n" directive x
 
-let emit_float64_split_directive directive f =
-  let x = Int64.bits_of_float (float_of_string f) in
+let emit_float64_split_directive directive x =
   let lo = Int64.logand x 0xFFFF_FFFFL
   and hi = Int64.shift_right_logical x 32 in
   emit_printf "\t%s\t0x%Lx, 0x%Lx\n"
@@ -105,8 +99,7 @@ let emit_float64_split_directive directive f =
     (if Arch.big_endian then hi else lo)
     (if Arch.big_endian then lo else hi)
 
-let emit_float32_directive directive f =
-  let x = Int32.bits_of_float (float_of_string f) in
+let emit_float32_directive directive x =
   emit_printf "\t%s\t0x%lx\n" directive x
 
 (* Record live pointers at call points *)
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index cc479d8ccf..9b19e294c7 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -23,9 +23,9 @@ val emit_char: char -> unit
 val emit_string_literal: string -> unit
 val emit_string_directive: string -> string -> unit
 val emit_bytes_directive: string -> string -> unit
-val emit_float64_directive: string -> string -> unit
-val emit_float64_split_directive: string -> string -> unit
-val emit_float32_directive: string -> string -> unit
+val emit_float64_directive: string -> int64 -> unit
+val emit_float64_split_directive: string -> int64 -> unit
+val emit_float32_directive: string -> int32 -> unit
 
 val reset_debug_info: unit -> unit
 val emit_debug_info: Debuginfo.t -> unit
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 2b90d37f64..fbd4fc6266 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -412,15 +412,16 @@ let emit_floatspecial = function
 
 (* Floating-point constants *)
 
-let float_constants = ref ([] : (string * int) list)
+let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
+  let repr = Int64.bits_of_float cst in
   try
-    List.assoc cst !float_constants
+    List.assoc repr !float_constants
   with
     Not_found ->
       let lbl = new_label() in
-      float_constants := (cst, lbl) :: !float_constants;
+      float_constants := (repr, lbl) :: !float_constants;
       lbl
 
 let emit_float_constant (cst, lbl) =
@@ -960,9 +961,9 @@ let emit_item = function
   | Cint n ->
       `	.long	{emit_nativeint n}\n`
   | Csingle f ->
-      emit_float32_directive ".long" f
+      emit_float32_directive ".long" (Int32.bits_of_float f)
   | Cdouble f ->
-      emit_float64_split_directive ".long" f
+      emit_float64_split_directive ".long" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `	.long	{emit_symbol s}\n`
   | Clabel_address lbl ->
diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp
index 495a29aecc..533bc441a5 100644
--- a/asmcomp/i386/emit_nt.mlp
+++ b/asmcomp/i386/emit_nt.mlp
@@ -361,36 +361,21 @@ let emit_floatspecial = function
 
 (* Floating-point constants *)
 
-let float_constants = ref ([] : (string * int) list)
+let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
+  let repr = Int64.bits_of_float cst in
   try
-    List.assoc cst !float_constants
+    List.assoc repr !float_constants
   with
     Not_found ->
       let lbl = new_label() in
-      float_constants := (cst, lbl) :: !float_constants;
+      float_constants := (repr, lbl) :: !float_constants;
       lbl
 
-let emit_float s =
-  (* MASM doesn't like floating-point constants such as 2e9.
-     Turn them into 2.0e9. *)
-  let pos_e = ref (-1) and pos_dot = ref (-1) in
-  for i = 0 to String.length s - 1 do
-    match s.[i] with
-      'e'|'E' -> pos_e := i
-    | '.'     -> pos_dot := i
-    | _       -> ()
-  done;
-  if !pos_dot < 0 && !pos_e >= 0 then begin
-    emit_string (String.sub s 0 !pos_e);
-    emit_string ".0";
-    emit_string (String.sub s !pos_e (String.length s - !pos_e))
-  end else
-    emit_string s
-
 let emit_float_constant (cst, lbl) =
-  `{emit_label lbl}     REAL8   {emit_float cst}\n`
+  `{emit_label lbl}:`;
+  emit_float64_directive "QWORD" cst
 
 (* Output the assembly code for an instruction *)
 
@@ -816,9 +801,9 @@ let emit_item = function
   | Cint32 n ->
       `	DWORD	{emit_nativeint n}\n`
   | Csingle f ->
-      `	REAL4	{emit_float f}\n`
+      emit_float32_directive "DWORD" (Int32.bits_of_float f)
   | Cdouble f ->
-      `	REAL8	{emit_float f}\n`
+      emit_float64_directive "QWORD" (Int64.bits_of_float f)
   | Csymbol_address s ->
       add_used_symbol s ;
       `	DWORD	{emit_symbol s}\n`
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index a11910ec73..6b141230fe 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -36,7 +36,7 @@ type operation =
   | Ispill
   | Ireload
   | Iconst_int of nativeint
-  | Iconst_float of string
+  | Iconst_float of float
   | Iconst_symbol of string
   | Iconst_blockheader of nativeint
   | Icall_ind
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index 000c3cf9f1..30643730d1 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -36,7 +36,7 @@ type operation =
   | Ispill
   | Ireload
   | Iconst_int of nativeint
-  | Iconst_float of string
+  | Iconst_float of float
   | Iconst_symbol of string
   | Iconst_blockheader of nativeint
   | Icall_ind
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index f6ee1a2321..f31d632c1c 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -229,7 +229,7 @@ let record_frame live dbg =
 
 (* Record floating-point and large integer literals *)
 
-let float_literals = ref ([] : (string * int) list)
+let float_literals = ref ([] : (int64 * int) list)
 let int_literals = ref ([] : (nativeint * int) list)
 
 (* Record external C functions to be called in a position-independent way
@@ -466,9 +466,9 @@ let rec emit_instr i dslot =
           `	addis	{emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
           `	{emit_string lg}	{emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
         end
-    | Lop(Iconst_float s) ->
+    | Lop(Iconst_float f) ->
         let lbl = new_label() in
-        float_literals := (s, lbl) :: !float_literals;
+        float_literals := (Int64.bits_of_float f, lbl) :: !float_literals;
         `	addis	{emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
         `	lfd	{emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n`
     | Lop(Iconst_symbol s) ->
@@ -628,8 +628,7 @@ let rec emit_instr i dslot =
           `	fcfid	{emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
 	end else begin
           let lbl = new_label() in
-          float_literals := ("4.503601774854144e15", lbl) :: !float_literals;
-          (* That float above represents 0x4330000080000000 *)
+          float_literals := (0x4330000080000000L, lbl) :: !float_literals;
           `	addis	{emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`;
           `	lfd	{emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`;
           `	lis	{emit_gpr 0}, 0x4330\n`;
@@ -899,11 +898,11 @@ let emit_item = function
   | Cint n ->
       `	{emit_string datag}	{emit_nativeint n}\n`
   | Csingle f ->
-      emit_float32_directive ".long" f
+      emit_float32_directive ".long" (Int32.bits_of_float f)
   | Cdouble f ->
       if ppc64
-      then emit_float64_directive ".quad" f
-      else emit_float64_split_directive ".long" f
+      then emit_float64_directive ".quad" (Int64.bits_of_float f)
+      else emit_float64_split_directive ".long" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `	{emit_string datag}	{emit_symbol s}\n`
   | Clabel_address lbl ->
diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
index f4e3b4d93f..b28d749e24 100644
--- a/asmcomp/printclambda.ml
+++ b/asmcomp/printclambda.ml
@@ -16,17 +16,20 @@ open Asttypes
 open Clambda
 
 let rec structured_constant ppf = function
-  | Uconst_float x -> fprintf ppf "%s" x
-  | Uconst_int32 x -> fprintf ppf "%ld" x
-  | Uconst_int64 x -> fprintf ppf "%Ld" x
-  | Uconst_nativeint x -> fprintf ppf "%nd" x
+  | Uconst_float x -> fprintf ppf "%F" x
+  | Uconst_int32 x -> fprintf ppf "%ldl" x
+  | Uconst_int64 x -> fprintf ppf "%LdL" x
+  | Uconst_nativeint x -> fprintf ppf "%ndn" x
   | Uconst_block (tag, l) ->
       fprintf ppf "block(%i" tag;
       List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
       fprintf ppf ")"
-  | Uconst_float_array sl ->
-      fprintf ppf "floatarray(%s)"
-        (String.concat "," sl)
+  | Uconst_float_array [] ->
+      fprintf ppf "floatarray()"
+  | Uconst_float_array (f1 :: fl) ->
+      fprintf ppf "floatarray(%F" f1;
+      List.iter (fun f -> fprintf ppf ",%F" f) fl;
+      fprintf ppf ")"
   | Uconst_string s -> fprintf ppf "%S" s
 
 and uconstant ppf = function
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 008081fb47..89c8582aef 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -89,7 +89,7 @@ let rec expr ppf = function
   | Cconst_int n -> fprintf ppf "%i" n
   | Cconst_natint n | Cconst_blockheader n ->
     fprintf ppf "%s" (Nativeint.to_string n)
-  | Cconst_float s -> fprintf ppf "%s" s
+  | Cconst_float n -> fprintf ppf "%F" n
   | Cconst_symbol s -> fprintf ppf "\"%s\"" s
   | Cconst_pointer n -> fprintf ppf "%ia" n
   | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n)
@@ -188,8 +188,8 @@ let data_item ppf = function
   | Cint16 n -> fprintf ppf "int16 %i" n
   | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n)
   | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n)
-  | Csingle f -> fprintf ppf "single %s" f
-  | Cdouble f -> fprintf ppf "double %s" f
+  | Csingle f -> fprintf ppf "single %F" f
+  | Cdouble f -> fprintf ppf "double %F" f
   | Csymbol_address s -> fprintf ppf "addr \"%s\"" s
   | Clabel_address l -> fprintf ppf "addr L%i" l
   | Cstring s -> fprintf ppf "string \"%s\"" s
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 824665cd9d..0c577890d7 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -105,7 +105,7 @@ let operation op arg ppf res =
   | Ireload -> fprintf ppf "%a (reload)" regs arg
   | Iconst_int n
   | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n)
-  | Iconst_float s -> fprintf ppf "%s" s
+  | Iconst_float f -> fprintf ppf "%F" f
   | Iconst_symbol s -> fprintf ppf "\"%s\"" s
   | Icall_ind -> fprintf ppf "call %a" regs arg
   | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg
diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
index 12d60ed327..2793776ff6 100644
--- a/asmcomp/sparc/emit.mlp
+++ b/asmcomp/sparc/emit.mlp
@@ -190,7 +190,7 @@ let emit_frame fd =
 
 (* Record floating-point constants *)
 
-let float_constants = ref ([] : (int * string) list)
+let float_constants = ref ([] : (int * int64) list)
 
 let emit_float_constant (lbl, cst) =
   rodata ();
@@ -309,11 +309,11 @@ let rec emit_instr i dslot =
           `	sethi	%hi({emit_nativeint n}), %g1\n`;
           `	or	%g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n`
         end
-    | Lop(Iconst_float s) ->
+    | Lop(Iconst_float f) ->
         (* On UltraSPARC, the fzero instruction could be used to set a
            floating point register pair to zero. *)
         let lbl = new_label() in
-        float_constants := (lbl, s) :: !float_constants;
+        float_constants := (lbl, Int64.bits_of_float f) :: !float_constants;
         `	sethi	%hi({emit_label lbl}), %g1\n`;
         `	ldd	[%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
     | Lop(Iconst_symbol s) ->
@@ -706,9 +706,9 @@ let emit_item = function
   | Cint n ->
       `	.word	{emit_nativeint n}\n`
   | Csingle f ->
-      emit_float32_directive ".word" f
+      emit_float32_directive ".word" (Int32.bits_of_float f)
   | Cdouble f ->
-      emit_float64_split_directive ".word" f
+      emit_float64_split_directive ".word" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `	.word	{emit_symbol s}\n`
   | Clabel_address lbl ->
diff --git a/driver/main_args.ml b/driver/main_args.ml
index ec97d6c983..7d1c402565 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -154,6 +154,10 @@ let mk_no_app_funct f =
   "-no-app-funct", Arg.Unit f, " Deactivate applicative functors"
 ;;
 
+let mk_no_float_const_prop f =
+  "-no-float-const-prop", Arg.Unit f, " Deactivate constant propagation for floating-point operations"
+;;
+
 let mk_noassert f =
   "-noassert", Arg.Unit f, " Do not compile assertion checks"
 ;;
@@ -554,6 +558,7 @@ module type Optcomp_options = sig
   val _labels : unit -> unit
   val _linkall : unit -> unit
   val _no_app_funct : unit -> unit
+  val _no_float_const_prop : unit -> unit
   val _noassert : unit -> unit
   val _noautolink : unit -> unit
   val _nodynlink : unit -> unit
@@ -801,6 +806,7 @@ struct
     mk_labels F._labels;
     mk_linkall F._linkall;
     mk_no_app_funct F._no_app_funct;
+    mk_no_float_const_prop F._no_float_const_prop;
     mk_noassert F._noassert;
     mk_noautolink_opt F._noautolink;
     mk_nodynlink F._nodynlink;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 67a6c681d2..6ebf95c9ad 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -136,6 +136,7 @@ module type Optcomp_options = sig
   val _labels : unit -> unit
   val _linkall : unit -> unit
   val _no_app_funct : unit -> unit
+  val _no_float_const_prop : unit -> unit
   val _noassert : unit -> unit
   val _noautolink : unit -> unit
   val _nodynlink : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index d04ad76b19..2fb1a22b30 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -94,6 +94,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _labels = clear classic
   let _linkall = set link_everything
   let _no_app_funct = clear applicative_functors
+  let _no_float_const_prop = clear float_const_prop
   let _noassert = set noassert
   let _noautolink = set no_auto_link
   let _nodynlink = clear dlcode
diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
index ad697b6f4b..c81ca619b6 100644
--- a/testsuite/tests/asmcomp/parsecmm.mly
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -172,7 +172,7 @@ componentlist:
 ;
 expr:
     INTCONST    { Cconst_int $1 }
-  | FLOATCONST  { Cconst_float $1 }
+  | FLOATCONST  { Cconst_float (float_of_string $1) }
   | STRING      { Cconst_symbol $1 }
   | POINTER     { Cconst_pointer $1 }
   | IDENT       { Cvar(find_ident $1) }
@@ -316,7 +316,7 @@ dataitem:
   | BYTE INTCONST               { Cint8 $2 }
   | HALF INTCONST               { Cint16 $2 }
   | INT INTCONST                { Cint(Nativeint.of_int $2) }
-  | FLOAT FLOATCONST            { Cdouble $2 }
+  | FLOAT FLOATCONST            { Cdouble (float_of_string $2) }
   | ADDR STRING                 { Csymbol_address $2 }
   | ADDR INTCONST               { Clabel_address $2 }
   | KSTRING STRING              { Cstring $2 }
diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml
new file mode 100644
index 0000000000..6661291316
--- /dev/null
+++ b/testsuite/tests/basic/constprop.ml
@@ -0,0 +1,72 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2014 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* Test constant propagation through inlining *)
+
+(* constprop.ml is generated from constprop.mlp using
+      cpp constprop.mlp > constprop.ml
+*)
+let do_test msg res1 res2 =
+  Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
+(* Hide a constant from the optimizer, preventing constant propagation *)
+let hide x = List.nth [x] 0
+let _ =
+  begin
+    let x = true and y = false in
+    let xh = hide x and yh = hide y in
+    do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh))
+  end;
+  begin
+    let x = 89809344 and y = 457455773 and s = 7 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "integers" ((-x, x + y, x - y, x * y, x / y, x mod y, x land y, x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y, x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y)) ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh, xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh))
+  end;
+  begin
+    let x = 3.141592654 and y = 0.341638588598232096 in
+    let xh = hide x and yh = hide y in
+    do_test "floats" ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y, x <> y, x < y, x <= y, x > y, x >= y)) ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 781944104l and y = 308219921l and s = 3 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "32-bit integers" (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1828697041n and y = -521695949n and s = 8 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "native integers" (Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "64-bit integers" (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh))
+  end;
+  begin
+    let x = 1000807289 in
+    let xh = hide x in
+    do_test "integer conversions" ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x)) ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh))
+  end;
+  begin
+    let x = 10486393l in
+    let xh = hide x in
+    do_test "32-bit integer conversions" ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x)) ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh))
+  end;
+  begin
+    let x = -131134014n in
+    let xh = hide x in
+    do_test "native integer conversions" ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x)) ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh))
+  end;
+  begin
+    let x = 531871273453404175L in
+    let xh = hide x in
+    do_test "64-bit integer conversions" ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x)) ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh))
+  end
diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp
new file mode 100644
index 0000000000..305a98dd95
--- /dev/null
+++ b/testsuite/tests/basic/constprop.mlp
@@ -0,0 +1,130 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2014 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* Test constant propagation through inlining *)
+
+(* constprop.ml is generated from constprop.mlp using
+      cpp constprop.mlp > constprop.ml
+*)
+
+#define tbool(x,y) \
+  (x && y, x || y, not x)
+
+#define tint(x,y,s)                                                         \
+  (-x, x + y, x - y, x * y, x / y, x mod y,                                 \
+   x land y, x lor y, x lxor y,                                             \
+   x lsl s, x lsr s, x asr s,                                               \
+   x = y, x <> y, x < y, x <= y, x > y, x >= y,                             \
+   succ x, pred y)
+
+#define tfloat(x,y)                                                         \
+  (int_of_float x,                                                          \
+   x +. y, x -. y, x *. y, x /. y,                                          \
+   x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tconvint(i)                                                         \
+  (float_of_int i,                                                          \
+   Int32.of_int i,                                                          \
+   Nativeint.of_int i,                                                      \
+   Int64.of_int i)
+
+#define tconvint32(i)                                                       \
+  (Int32.to_int i,                                                          \
+   Nativeint.of_int32 i,                                                    \
+   Int64.of_int32 i)
+
+#define tconvnativeint(i)                                                   \
+  (Nativeint.to_int i,                                                      \
+   Nativeint.to_int32 i,                                                    \
+   Int64.of_nativeint i)
+
+#define tconvint64(i)                                                       \
+  (Int64.to_int i,                                                          \
+   Int64.to_int32 i,                                                        \
+   Int64.to_nativeint i)                                                    \
+
+#define tint32(x,y,s)                                                       \
+  Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y,                \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+  
+#define tnativeint(x,y,s)                                                   \
+  Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y,            \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+
+#define tint64(x,y,s)                                                       \
+  Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y,                \
+         logand x y, logor x y, logxor x y,                                 \
+         shift_left x s, shift_right x s, shift_right_logical x s,          \
+         x = y, x <> y, x < y, x <= y, x > y, x >= y)
+  
+let do_test msg res1 res2 =
+  Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED")
+
+(* Hide a constant from the optimizer, preventing constant propagation *)
+let hide x = List.nth [x] 0
+
+let _ =
+  begin
+    let x = true and y = false in
+    let xh = hide x and yh = hide y in
+    do_test "booleans" (tbool(x, y)) (tbool(xh,yh))
+  end;
+  begin
+    let x = 89809344 and y = 457455773 and s = 7 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh))
+  end;
+  begin
+    let x = 3.141592654 and y = 0.341638588598232096 in
+    let xh = hide x and yh = hide y in
+    do_test "floats" (tfloat(x, y)) (tfloat(xh, yh))
+  end;
+  begin
+    let x = 781944104l and y = 308219921l and s = 3 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh))
+  end;
+  begin
+    let x = 1828697041n and y = -521695949n and s = 8 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh))
+  end;
+  begin
+    let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in
+    let xh = hide x and yh = hide y and sh = hide s in
+    do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh))
+  end;
+  begin
+    let x = 1000807289 in
+    let xh = hide x in
+    do_test "integer conversions" (tconvint(x)) (tconvint(xh))
+  end;
+  begin
+    let x = 10486393l in
+    let xh = hide x in
+    do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh))
+  end;
+  begin
+    let x = -131134014n in
+    let xh = hide x in
+    do_test "native integer conversions" (tconvnativeint(x)) (tconvnativeint(xh))
+  end;
+  begin
+    let x = 531871273453404175L in
+    let xh = hide x in
+    do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh))
+  end
+
diff --git a/testsuite/tests/basic/constprop.reference b/testsuite/tests/basic/constprop.reference
new file mode 100644
index 0000000000..59590530ae
--- /dev/null
+++ b/testsuite/tests/basic/constprop.reference
@@ -0,0 +1,10 @@
+booleans: passed
+integers: passed
+floats: passed
+32-bit integers: passed
+native integers: passed
+64-bit integers: passed
+integer conversions: passed
+32-bit integer conversions: passed
+native integer conversions: passed
+64-bit integer conversions: passed
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 6d730f2c3c..59cb661d98 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -65,6 +65,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _labels = option "-labels"
   let _linkall = option "-linkall"
   let _no_app_funct = option "-no-app-funct"
+  let _no_float_const_prop = option "-no-float-const-prop"
   let _noassert = option "-noassert"
   let _noautolink = option "-noautolink"
   let _nodynlink = option "-nodynlink"
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 829393a00d..d0484b7728 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -58,6 +58,7 @@ and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
 and error_size = ref 500                (* -error-size *)
+and float_const_prop = ref true         (* -no-float-const-prop *)
 and transparent_modules = ref false     (* -trans-mod *)
 let dump_source = ref false             (* -dsource *)
 let dump_parsetree = ref false          (* -dparsetree *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 876776acdb..02c378d23f 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -55,6 +55,7 @@ val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
 val error_size : int ref
+val float_const_prop : bool ref
 val transparent_modules : bool ref
 val dump_source : bool ref
 val dump_parsetree : bool ref
diff --git a/utils/config.mlp b/utils/config.mlp
index c83071da14..e4c0d322a8 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -52,8 +52,8 @@ let exec_magic_number = "Caml1999X011"
 and cmi_magic_number = "Caml1999I016"
 and cmo_magic_number = "Caml1999O009"
 and cma_magic_number = "Caml1999A010"
-and cmx_magic_number = "Caml1999Y012"
-and cmxa_magic_number = "Caml1999Z011"
+and cmx_magic_number = "Caml1999Y013"
+and cmxa_magic_number = "Caml1999Z012"
 and ast_impl_magic_number = "Caml1999M016"
 and ast_intf_magic_number = "Caml1999N015"
 and cmxs_magic_number = "Caml2007D001"