Skip to content

Commit 4a9ba4a

Browse files
vouillonvouillon
committed
Evaluate statically more primitives
1 parent 785e5b4 commit 4a9ba4a

File tree

2 files changed

+179
-7
lines changed

2 files changed

+179
-7
lines changed

‎compiler/lib/eval.ml

Lines changed: 178 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -73,11 +73,71 @@ let bool' b = Int Targetint.(if b then one else zero)
7373

7474
let bool b = Some (bool' b)
7575

76+
let float_unop_bool (l : constant list) (f : float -> bool) =
77+
match l with
78+
| [ Float i ] -> bool (f i)
79+
| [ Int i ] -> bool (f (Targetint.to_float i))
80+
| _ -> None
81+
7682
let float_binop_bool l f =
7783
match float_binop_aux l f with
7884
| Some b -> bool b
7985
| None -> None
8086

87+
let int32 i =
88+
match Config.target () with
89+
| `JavaScript -> Some (Int (Targetint.of_int32_exn i))
90+
| `Wasm -> Some (Int32 i)
91+
92+
let int32_unop (l : constant list) (f : int32 -> int32) : constant option =
93+
match l with
94+
| [ Int32 i ] -> Some (Int32 (f i))
95+
| _ -> None
96+
97+
let int32_binop (l : constant list) (f : int32 -> int32 -> int32) : constant option =
98+
match l with
99+
| [ Int32 i; Int32 j ] -> Some (Int32 (f i j))
100+
| _ -> None
101+
102+
let int32_shiftop (l : constant list) (f : int32 -> int -> int32) : constant option =
103+
match l with
104+
| [ Int32 i; Int j ] -> Some (Int32 (f i (Targetint.to_int_exn j)))
105+
| _ -> None
106+
107+
let int64 i = Some (Int64 i)
108+
109+
let int64_unop (l : constant list) (f : int64 -> int64) : constant option =
110+
match l with
111+
| [ Int64 i ] -> Some (Int64 (f i))
112+
| _ -> None
113+
114+
let int64_binop (l : constant list) (f : int64 -> int64 -> int64) : constant option =
115+
match l with
116+
| [ Int64 i; Int64 j ] -> Some (Int64 (f i j))
117+
| _ -> None
118+
119+
let int64_shiftop (l : constant list) (f : int64 -> int -> int64) : constant option =
120+
match l with
121+
| [ Int64 i; Int j ] -> Some (Int64 (f i (Targetint.to_int_exn j)))
122+
| _ -> None
123+
124+
let nativeint i = Some (NativeInt i)
125+
126+
let nativeint_unop (l : constant list) (f : int32 -> int32) : constant option =
127+
match l with
128+
| [ NativeInt i ] -> Some (NativeInt (f i))
129+
| _ -> None
130+
131+
let nativeint_binop (l : constant list) (f : int32 -> int32 -> int32) : constant option =
132+
match l with
133+
| [ NativeInt i; NativeInt j ] -> Some (NativeInt (f i j))
134+
| _ -> None
135+
136+
let nativeint_shiftop (l : constant list) (f : int32 -> int -> int32) : constant option =
137+
match l with
138+
| [ NativeInt i; Int j ] -> Some (NativeInt (f i (Targetint.to_int_exn j)))
139+
| _ -> None
140+
81141
let eval_prim x =
82142
match x with
83143
| Not, [ Int i ] -> bool (Targetint.is_zero i)
@@ -92,8 +152,7 @@ let eval_prim x =
92152
(* int *)
93153
| "%int_add", _ -> int_binop l Targetint.add
94154
| "%int_sub", _ -> int_binop l Targetint.sub
95-
| "%direct_int_mul", _ -> int_binop l Targetint.mul
96-
| "%direct_int_div", [ _; Int x ] when Targetint.is_zero x -> None
155+
| ("%int_mul" | "%direct_int_mul"), _ -> int_binop l Targetint.mul
97156
| "%direct_int_div", _ -> int_binop l Targetint.div
98157
| "%direct_int_mod", _ -> int_binop l Targetint.rem
99158
| "%int_and", _ -> int_binop l Targetint.logand
@@ -103,6 +162,8 @@ let eval_prim x =
103162
| "%int_lsr", _ -> shift_op l Targetint.shift_right_logical
104163
| "%int_asr", _ -> shift_op l Targetint.shift_right
105164
| "%int_neg", _ -> int_unop l Targetint.neg
165+
| "caml_int_compare", _ ->
166+
int_binop l Targetint.(fun i j -> of_int_exn (compare i j))
106167
(* float *)
107168
| "caml_eq_float", _ -> float_binop_bool l Float.( = )
108169
| "caml_neq_float", _ -> float_binop_bool l Float.( <> )
@@ -119,22 +180,136 @@ let eval_prim x =
119180
match Targetint.of_float_opt f with
120181
| None -> None
121182
| Some f -> Some (Int f))
183+
| "caml_float_of_int", [ Int i ] -> Some (Float (Targetint.to_float i))
122184
(* Math *)
123185
| "caml_neg_float", _ -> float_unop l ( ~-. )
124186
| "caml_abs_float", _ -> float_unop l abs_float
125187
| "caml_acos_float", _ -> float_unop l acos
126188
| "caml_asin_float", _ -> float_unop l asin
127189
| "caml_atan_float", _ -> float_unop l atan
128190
| "caml_atan2_float", _ -> float_binop l atan2
191+
| "caml_hypot_float", _ -> float_binop l hypot
129192
| "caml_ceil_float", _ -> float_unop l ceil
193+
| "caml_floor_float", _ -> float_unop l floor
194+
| "caml_trunc_float", _ -> float_unop l Float.trunc
195+
| "caml_round_float", _ -> float_unop l Float.round
130196
| "caml_cos_float", _ -> float_unop l cos
131197
| "caml_exp_float", _ -> float_unop l exp
132-
| "caml_floor_float", _ -> float_unop l floor
198+
| (("caml_exp2_float", _) [@if ocaml_version >= (4, 13, 0)]) ->
199+
float_unop l Float.exp2
200+
| "caml_expm1_float", _ -> float_unop l expm1
133201
| "caml_log_float", _ -> float_unop l log
202+
| "caml_log1p_float", _ -> float_unop l log1p
203+
| (("caml_log2_float", _) [@if ocaml_version >= (4, 13, 0)]) ->
204+
float_unop l Float.log2
205+
| "caml_log10_float", _ -> float_unop l log10
206+
| "caml_cosh_float", _ -> float_unop l cosh
207+
| "caml_sinh_float", _ -> float_unop l sinh
208+
| "caml_tanh_float", _ -> float_unop l tanh
209+
| (("caml_acosh_float", _) [@if ocaml_version >= (4, 13, 0)]) -> float_unop l acosh
210+
| (("caml_asinh_float", _) [@if ocaml_version >= (4, 13, 0)]) -> float_unop l asinh
211+
| (("caml_atanh_float", _) [@if ocaml_version >= (4, 13, 0)]) -> float_unop l atanh
134212
| "caml_power_float", _ -> float_binop l ( ** )
135213
| "caml_sin_float", _ -> float_unop l sin
136214
| "caml_sqrt_float", _ -> float_unop l sqrt
215+
| (("caml_cbrt_float", _) [@if ocaml_version >= (4, 13, 0)]) ->
216+
float_unop l Float.cbrt
137217
| "caml_tan_float", _ -> float_unop l tan
218+
| "caml_copysign_float", _ -> float_binop l copysign
219+
| "caml_signbit_float", _ -> float_unop_bool l Float.sign_bit
220+
| (("caml_erf_float", _) [@if ocaml_version >= (4, 13, 0)]) ->
221+
float_unop l Float.erf
222+
| (("caml_erfc_float", _) [@if ocaml_version >= (4, 13, 0)]) ->
223+
float_unop l Float.erfc
224+
| "caml_nextafter_float", _ -> float_binop l Float.next_after
225+
| "caml_float_compare", [ Float i; Float j ] ->
226+
Some (Int (Targetint.of_int_exn (Float.compare i j)))
227+
| "caml_ldexp_float", [ Float f; Int i ] ->
228+
Some (Float (ldexp f (Targetint.to_int_exn i)))
229+
(* int32 *)
230+
| "caml_int32_bits_of_float", [ Float f ] -> int32 (Int32.bits_of_float f)
231+
| "caml_int32_float_of_bits", [ Int i ] ->
232+
Some (Float (Int32.float_of_bits (Targetint.to_int32 i)))
233+
| "caml_int32_float_of_bits", [ Int32 i ] -> Some (Float (Int32.float_of_bits i))
234+
| "caml_int32_of_float", [ Float f ] -> int32 (Int32.of_float f)
235+
| "caml_int32_to_float", [ Int32 i ] -> Some (Float (Int32.to_float i))
236+
| "caml_int32_neg", _ -> int32_unop l Int32.neg
237+
| "caml_int32_add", _ -> int32_binop l Int32.add
238+
| "caml_int32_sub", _ -> int32_binop l Int32.sub
239+
| "caml_int32_mul", _ -> int32_binop l Int32.mul
240+
| "caml_int32_and", _ -> int32_binop l Int32.logand
241+
| "caml_int32_or", _ -> int32_binop l Int32.logor
242+
| "caml_int32_xor", _ -> int32_binop l Int32.logxor
243+
| "caml_int32_div", [ _; Int32 i ] when not (Int32.equal i 0l) ->
244+
int32_binop l Int32.div
245+
| "caml_int32_mod", [ _; Int32 i ] when not (Int32.equal i 0l) ->
246+
int32_binop l Int32.rem
247+
| "caml_int32_shift_left", _ -> int32_shiftop l Int32.shift_left
248+
| "caml_int32_shift_right", _ -> int32_shiftop l Int32.shift_right
249+
| "caml_int32_shift_right_unsigned", _ -> int32_shiftop l Int32.shift_right_logical
250+
| "caml_int32_compare", [ Int32 i; Int32 j ] ->
251+
Some (Int (Targetint.of_int_exn (Int32.compare i j)))
252+
| "caml_int32_to_int", [ Int32 i ] -> Some (Int (Targetint.of_int32_truncate i))
253+
| "caml_int32_of_int", [ Int i ] -> int32 (Targetint.to_int32 i)
254+
| "caml_nativeint_of_int32", [ Int32 i ] -> Some (NativeInt i)
255+
| "caml_nativeint_to_int32", [ NativeInt i ] -> Some (Int32 i)
256+
(* nativeint *)
257+
| "caml_nativeint_bits_of_float", [ Float f ] -> nativeint (Int32.bits_of_float f)
258+
| "caml_nativeint_float_of_bits", [ Int i ] ->
259+
Some (Float (Int32.float_of_bits (Targetint.to_int32 i)))
260+
| "caml_nativeint_float_of_bits", [ NativeInt i ] ->
261+
Some (Float (Int32.float_of_bits i))
262+
| "caml_nativeint_of_float", [ Float f ] -> nativeint (Int32.of_float f)
263+
| "caml_nativeint_to_float", [ NativeInt i ] -> Some (Float (Int32.to_float i))
264+
| "caml_nativeint_neg", _ -> nativeint_unop l Int32.neg
265+
| "caml_nativeint_add", _ -> nativeint_binop l Int32.add
266+
| "caml_nativeint_sub", _ -> nativeint_binop l Int32.sub
267+
| "caml_nativeint_mul", _ -> nativeint_binop l Int32.mul
268+
| "caml_nativeint_and", _ -> nativeint_binop l Int32.logand
269+
| "caml_nativeint_or", _ -> nativeint_binop l Int32.logor
270+
| "caml_nativeint_xor", _ -> nativeint_binop l Int32.logxor
271+
| "caml_nativeint_div", [ _; NativeInt i ] when not (Int32.equal i 0l) ->
272+
nativeint_binop l Int32.div
273+
| "caml_nativeint_mod", [ _; NativeInt i ] when not (Int32.equal i 0l) ->
274+
nativeint_binop l Int32.rem
275+
| "caml_nativeint_shift_left", _ -> nativeint_shiftop l Int32.shift_left
276+
| "caml_nativeint_shift_right", _ -> nativeint_shiftop l Int32.shift_right
277+
| "caml_nativeint_shift_right_unsigned", _ ->
278+
nativeint_shiftop l Int32.shift_right_logical
279+
| "caml_nativeint_compare", [ NativeInt i; NativeInt j ] ->
280+
Some (Int (Targetint.of_int_exn (Int32.compare i j)))
281+
| "caml_nativeint_to_int", [ Int32 i ] -> Some (Int (Targetint.of_int32_truncate i))
282+
| "caml_nativeint_of_int", [ Int i ] -> nativeint (Targetint.to_int32 i)
283+
(* int64 *)
284+
| "caml_int64_bits_of_float", [ Float f ] -> int64 (Int64.bits_of_float f)
285+
| "caml_int64_float_of_bits", [ Int64 i ] -> Some (Float (Int64.float_of_bits i))
286+
| "caml_int64_of_float", [ Float f ] -> int64 (Int64.of_float f)
287+
| "caml_int64_to_float", [ Int64 i ] -> Some (Float (Int64.to_float i))
288+
| "caml_int64_neg", _ -> int64_unop l Int64.neg
289+
| "caml_int64_add", _ -> int64_binop l Int64.add
290+
| "caml_int64_sub", _ -> int64_binop l Int64.sub
291+
| "caml_int64_mul", _ -> int64_binop l Int64.mul
292+
| "caml_int64_and", _ -> int64_binop l Int64.logand
293+
| "caml_int64_or", _ -> int64_binop l Int64.logor
294+
| "caml_int64_xor", _ -> int64_binop l Int64.logxor
295+
| "caml_int64_div", [ _; Int64 i ] when not (Int64.equal i 0L) ->
296+
int64_binop l Int64.div
297+
| "caml_int64_mod", [ _; Int64 i ] when not (Int64.equal i 0L) ->
298+
int64_binop l Int64.rem
299+
| "caml_int64_shift_left", _ -> int64_shiftop l Int64.shift_left
300+
| "caml_int64_shift_right", _ -> int64_shiftop l Int64.shift_right
301+
| "caml_int64_shift_right_unsigned", _ -> int64_shiftop l Int64.shift_right_logical
302+
| "caml_int64_compare", [ Int64 i; Int64 j ] ->
303+
Some (Int (Targetint.of_int_exn (Int64.compare i j)))
304+
| "caml_int64_to_int", [ Int64 i ] ->
305+
Some (Int (Targetint.of_int32_truncate (Int64.to_int32 i)))
306+
| ( ("caml_int64_of_int" | "caml_int64_of_int32" | "caml_int64_of_nativeint")
307+
, [ Int i ] ) -> int64 (Int64.of_int32 (Targetint.to_int32 i))
308+
| "caml_int64_to_int32", [ Int64 i ] -> int32 (Int64.to_int32 i)
309+
| "caml_int64_of_int32", [ Int32 i ] -> int64 (Int64.of_int32 i)
310+
| "caml_int64_to_nativeint", [ Int64 i ] -> nativeint (Int64.to_int32 i)
311+
| "caml_int64_of_nativeint", [ NativeInt i ] -> int64 (Int64.of_int32 i)
312+
(* others *)
138313
| ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int pos ] ->
139314
let pos = Targetint.to_int_exn pos in
140315
if Config.Flag.safe_string () && pos >= 0 && pos < String.length s

‎compiler/lib/stdlib.ml

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -413,7 +413,7 @@ module Int64 = struct
413413
end
414414

415415
module Float = struct
416-
type t = float
416+
include Float
417417

418418
let equal (_ : float) (_ : float) = `Use_ieee_equal_or_bitwise_equal
419419

@@ -422,9 +422,6 @@ module Float = struct
422422
let bitwise_equal (a : float) (b : float) =
423423
Int64.equal (Int64.bits_of_float a) (Int64.bits_of_float b)
424424

425-
(* Re-defined here to stay compatible with OCaml 4.02 *)
426-
external classify_float : float -> fpclass = "caml_classify_float"
427-
428425
external ( < ) : t -> t -> bool = "%lessthan"
429426

430427
external ( <= ) : t -> t -> bool = "%lessequal"

0 commit comments

Comments
 (0)