blob: fa6ebb268d809fa9d7aa170c90ecada045e51d81 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
(* TEST
include config;
flags = "-w -55";
ocamlc_flags = "config.cmo";
ocamlopt_flags = "-inline 20 config.cmx";
native;
*)
let eliminate_intermediate_float_record () =
let r = ref 0. in
for n = 1 to 1000 do
let open Complex in
let c = { re = float n; im = 0. } in
(* The following line triggers warning 55 twice when compiled without
flambda. It would be better to disable this warning just here but since
this is a backend-warning, this is not currently possible. Hence the use
of the -w-55 command-line flag for this test *)
r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
done;
ignore (Sys.opaque_identity !r)
module PR_6686 = struct
type t =
| A of float
| B of (int * int)
let rec foo = function
| A x -> x
| B (x, y) -> float x +. float y
let (_ : float) = foo (A 4.)
end
module PR_6770 = struct
type t =
| Constant of float
| Exponent of (float * float)
let to_string = function
| Exponent (_b, _e) ->
ignore _b;
ignore _e;
""
| Constant _ -> ""
let _ = to_string (Constant 4.)
end
let check_noalloc name f =
let a0 = Gc.allocated_bytes () in
let a1 = Gc.allocated_bytes () in
let _x = f () in
let a2 = Gc.allocated_bytes () in
let alloc = (a2 -. 2. *. a1 +. a0) in
match Sys.backend_type with
| Sys.Bytecode -> ()
| Sys.Native ->
if alloc > 100. then
failwith (Printf.sprintf "%s; alloc = %.0f" name alloc)
| _ -> assert false
module GPR_109 = struct
let f () =
let r = ref 0. in
for i = 1 to 1000 do
let x = float i in
let y = if i mod 2 = 0 then x else x +. 1. in
r := !r +. y
done;
!r
let () = check_noalloc "gpr 1O9" f
end
let unbox_classify_float () =
let x = ref 100. in
for i = 1 to 1000 do
assert (classify_float !x = FP_normal);
x := !x +. 1.
done;
ignore (Sys.opaque_identity !x)
let unbox_compare_float () =
let module M = struct type sf = { mutable x: float; y: float; } end in
let x = { M.x=100. ; y=1. } in
for i = 1 to 1000 do
assert (compare x.M.x x.M.y >= 0);
x.M.x <- x.M.x +. 1.
done;
ignore (Sys.opaque_identity x.M.x)
let unbox_float_refs () =
let r = ref nan in
for i = 1 to 1000 do r := !r +. float i done;
ignore (Sys.opaque_identity !r)
let unbox_let_float () =
let r = ref 0. in
for i = 1 to 1000 do
let y =
if i mod 2 = 0 then nan else float i
in
r := !r +. (y *. 2.)
done;
ignore (Sys.opaque_identity !r)
type block =
{ mutable float : float;
mutable int32 : int32 }
let make_some_block record =
{ record with int32 = record.int32 }
let unbox_record_1 record =
(* There is some let lifting problem to handle that case with one
round, this currently requires 2 rounds to be correctly
recognized as a mutable variable pattern *)
(* let block = (make_some_block [@inlined]) record in *)
let block = { record with int32 = record.int32 } in
for i = 1 to 1000 do
let y_float =
if i mod 2 = 0 then nan else Stdlib.float i
in
block.float <- block.float +. (y_float *. 2.);
let y_int32 =
if i mod 2 = 0 then Int32.max_int else Int32.of_int i
in
block.int32 <- Int32.(add block.int32 (mul y_int32 2l))
done;
ignore (Sys.opaque_identity block.float);
ignore (Sys.opaque_identity block.int32)
[@@inline never]
(* Prevent inlining to test that the type is effectively used *)
let float_int32_record = { float = 3.14; int32 = 12l }
let unbox_record () =
unbox_record_1 float_int32_record
let r = ref 0.
let unbox_only_if_useful () =
for i = 1 to 1000 do
let x =
if i mod 2 = 0 then 1.
else 0.
in
r := x; (* would force boxing if the let binding above were unboxed *)
r := x (* use [x] twice to avoid elimination of the let-binding *)
done;
ignore (Sys.opaque_identity !r)
let unbox_minor_words () =
for i = 1 to 1000 do
ignore (Gc.minor_words () = 0.)
done
let ignore_useless_args () =
let f x _y = int_of_float (cos x) in
let rec g a n x =
if n = 0
then a
else g (a + (f [@inlined always]) x (x +. 1.)) (n - 1) x
in
ignore (g 0 10 5.)
let () =
check_noalloc "classify float" unbox_classify_float;
check_noalloc "compare float" unbox_compare_float;
check_noalloc "float refs" unbox_float_refs;
check_noalloc "unbox let float" unbox_let_float;
check_noalloc "unbox only if useful" unbox_only_if_useful;
check_noalloc "ignore useless args" ignore_useless_args;
if Config.flambda then begin
check_noalloc "float and int32 record" unbox_record;
check_noalloc "eliminate intermediate immutable float record"
eliminate_intermediate_float_record;
end;
check_noalloc "Gc.minor_words" unbox_minor_words;
()
|
