Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- 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
  • Loading branch information...
commit 29b34438e08e26ae8f8623eb32bb524386f0532f 1 parent 3775a10
Xavier Leroy xavierleroy authored
Showing with 582 additions and 233 deletions.
  1. +4 −0 Changes
  2. +9 −8 asmcomp/amd64/emit.mlp
  3. +8 −23 asmcomp/amd64/emit_nt.mlp
  4. +7 −6 asmcomp/arm/emit.mlp
  5. +5 −5 asmcomp/arm64/emit.mlp
  6. +5 −3 asmcomp/clambda.ml
  7. +5 −3 asmcomp/clambda.mli
  8. +258 −108 asmcomp/closure.ml
  9. +3 −3 asmcomp/cmm.ml
  10. +3 −3 asmcomp/cmm.mli
  11. +3 −10 asmcomp/emitaux.ml
  12. +3 −3 asmcomp/emitaux.mli
  13. +6 −5 asmcomp/i386/emit.mlp
  14. +8 −23 asmcomp/i386/emit_nt.mlp
  15. +1 −1  asmcomp/mach.ml
  16. +1 −1  asmcomp/mach.mli
  17. +7 −8 asmcomp/power/emit.mlp
  18. +10 −7 asmcomp/printclambda.ml
  19. +3 −3 asmcomp/printcmm.ml
  20. +1 −1  asmcomp/printmach.ml
  21. +5 −5 asmcomp/sparc/emit.mlp
  22. +6 −0 driver/main_args.ml
  23. +1 −0  driver/main_args.mli
  24. +1 −0  driver/optmain.ml
  25. +2 −2 testsuite/tests/asmcomp/parsecmm.mly
  26. +72 −0 testsuite/tests/basic/constprop.ml
  27. +130 −0 testsuite/tests/basic/constprop.mlp
  28. +10 −0 testsuite/tests/basic/constprop.reference
  29. +1 −0  tools/ocamloptp.ml
  30. +1 −0  utils/clflags.ml
  31. +1 −0  utils/clflags.mli
  32. +2 −2 utils/config.mlp
4 Changes
View
@@ -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)
17 asmcomp/amd64/emit.mlp
View
@@ -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 ->
31 asmcomp/amd64/emit_nt.mlp
View
@@ -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`
13 asmcomp/arm/emit.mlp
View
@@ -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
10 asmcomp/arm64/emit.mlp
View
@@ -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
8 asmcomp/clambda.ml
View
@@ -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 *)
8 asmcomp/clambda.mli
View
@@ -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 *)
366 asmcomp/closure.ml
View
@@ -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
6 asmcomp/cmm.ml
View
@@ -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
6 asmcomp/cmm.mli
View
@@ -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
13 asmcomp/emitaux.ml
View
@@ -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 *)
6 asmcomp/emitaux.mli
View
@@ -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
11 asmcomp/i386/emit.mlp
View
@@ -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 ->
31 asmcomp/i386/emit_nt.mlp
View
@@ -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`
2  asmcomp/mach.ml
View
@@ -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
2  asmcomp/mach.mli
View
@@ -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
15 asmcomp/power/emit.mlp
View
@@ -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 ->
17 asmcomp/printclambda.ml
View
@@ -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
6 asmcomp/printcmm.ml
View
@@ -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
2  asmcomp/printmach.ml
View
@@ -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
10 asmcomp/sparc/emit.mlp
View
@@ -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 ->
6 driver/main_args.ml
View
@@ -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;
1  driver/main_args.mli
View
@@ -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
1  driver/optmain.ml
View
@@ -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
4 testsuite/tests/asmcomp/parsecmm.mly
View
@@ -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 }
72 testsuite/tests/basic/constprop.ml
View
@@ -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
130 testsuite/tests/basic/constprop.mlp
View
@@ -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
+
10 testsuite/tests/basic/constprop.reference
View
@@ -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
1  tools/ocamloptp.ml
View
@@ -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"
1  utils/clflags.ml
View
@@ -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 *)
1  utils/clflags.mli
View
@@ -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
4 utils/config.mlp
View
@@ -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"
Please sign in to comment.
Something went wrong with that request. Please try again.