Skip to content

Commit 24254c7

Browse files
vouillonvouillon
committed
Propagate hints in intermediate code
1 parent 9b66d9b commit 24254c7

23 files changed

+689
-315
lines changed

‎compiler/bin-js_of_ocaml/compile.ml‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -245,9 +245,11 @@ let run
245245
let var_k = Code.Var.fresh () in
246246
let var_v = Code.Var.fresh () in
247247
Code.
248-
[ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ]))
249-
; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ]))
250-
; Let (Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
248+
[ Let (var_k, Prim (Extern ("caml_jsstring_of_string", None), [ Pc (String k) ]))
249+
; Let (var_v, Prim (Extern ("caml_jsstring_of_string", None), [ Pc (String v) ]))
250+
; Let
251+
( Var.fresh ()
252+
, Prim (Extern ("caml_set_static_env", None), [ Pv var_k; Pv var_v ]) )
251253
])
252254
in
253255
let output

‎compiler/lib-wasm/generate.ml‎

Lines changed: 35 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1446,12 +1446,12 @@ module Generate (Target : Target_sig.S) = struct
14461446
| _ -> false)
14471447
c
14481448
| Special (Alias_prim _) -> assert false
1449-
| Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) ->
1449+
| Prim (Extern ("caml_alloc_dummy_function", _), [ _; Pc (Int arity) ]) ->
14501450
(* Removed in OCaml 5.2 *)
14511451
Closure.dummy ~cps:(effects_cps ()) ~arity:(Targetint.to_int_exn arity)
1452-
| Prim (Extern "caml_alloc_dummy_infix", _) ->
1452+
| Prim (Extern ("caml_alloc_dummy_infix", _), _) ->
14531453
Closure.dummy ~cps:(effects_cps ()) ~arity:1
1454-
| Prim (Extern "caml_get_global", [ Pc (String name) ]) ->
1454+
| Prim (Extern ("caml_get_global", _), [ Pc (String name) ]) ->
14551455
let* x =
14561456
let* context = get_context in
14571457
match
@@ -1469,7 +1469,7 @@ module Generate (Target : Target_sig.S) = struct
14691469
register_import ~import_module:"OCaml" ~name (Global { mut = true; typ })
14701470
in
14711471
return (W.GlobalGet x)
1472-
| Prim (Extern "caml_set_global", [ Pc (String name); v ]) ->
1472+
| Prim (Extern ("caml_set_global", _), [ Pc (String name); v ]) ->
14731473
let v = transl_prim_arg ctx v in
14741474
let x = Var.fresh_n name in
14751475
let* () =
@@ -1491,16 +1491,16 @@ module Generate (Target : Target_sig.S) = struct
14911491
Memory.array_get
14921492
(transl_prim_arg ctx x)
14931493
(transl_prim_arg ctx ~typ:(Int Normalized) y)
1494-
| Prim (Extern "caml_array_unsafe_get", [ x; y ]) ->
1494+
| Prim (Extern ("caml_array_unsafe_get", _), [ x; y ]) ->
14951495
Memory.gen_array_get
14961496
(transl_prim_arg ctx x)
14971497
(transl_prim_arg ctx ~typ:(Int Normalized) y)
14981498
| Prim (p, l) -> (
14991499
match p with
1500-
| Extern name when String.Hashtbl.mem internal_primitives name ->
1500+
| Extern (name, _) when String.Hashtbl.mem internal_primitives name ->
15011501
snd (String.Hashtbl.find internal_primitives name) ctx context l
15021502
|> box_number_if_needed ctx x
1503-
| Extern name when String.Hashtbl.mem specialized_primitives name ->
1503+
| Extern (name, _) when String.Hashtbl.mem specialized_primitives name ->
15041504
let ((_, arg_typ, _) as typ) =
15051505
String.Hashtbl.find specialized_primitives name
15061506
in
@@ -1529,7 +1529,7 @@ module Generate (Target : Target_sig.S) = struct
15291529
| _ -> (
15301530
let l = List.map ~f:(fun x -> transl_prim_arg ctx x) l in
15311531
match p, l with
1532-
| Extern name, l ->
1532+
| Extern (name, _), l ->
15331533
let* f =
15341534
register_import ~name (Fun (Type.primitive_type (List.length l)))
15351535
in
@@ -1542,8 +1542,8 @@ module Generate (Target : Target_sig.S) = struct
15421542
in
15431543
loop [] l
15441544
| IsInt, [ x ] -> Value.is_int x
1545-
| Vectlength, [ x ] -> Memory.gen_array_length x
1546-
| (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength), _ ->
1545+
| Vectlength _, [ x ] -> Memory.gen_array_length x
1546+
| (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength _), _ ->
15471547
assert false))
15481548

15491549
and translate_instr ctx context i =
@@ -1658,34 +1658,36 @@ module Generate (Target : Target_sig.S) = struct
16581658
( _
16591659
, Prim
16601660
( Extern
1661-
( "caml_string_get"
1662-
| "caml_bytes_get"
1663-
| "caml_string_set"
1664-
| "caml_bytes_set"
1665-
| "caml_check_bound"
1666-
| "caml_check_bound_gen"
1667-
| "caml_check_bound_float"
1668-
| "caml_ba_get_1"
1669-
| "caml_ba_get_2"
1670-
| "caml_ba_get_3"
1671-
| "caml_ba_get_generic"
1672-
| "caml_ba_set_1"
1673-
| "caml_ba_set_2"
1674-
| "caml_ba_set_3"
1675-
| "caml_ba_set_generic" )
1661+
( ( "caml_string_get"
1662+
| "caml_bytes_get"
1663+
| "caml_string_set"
1664+
| "caml_bytes_set"
1665+
| "caml_check_bound"
1666+
| "caml_check_bound_gen"
1667+
| "caml_check_bound_float"
1668+
| "caml_ba_get_1"
1669+
| "caml_ba_get_2"
1670+
| "caml_ba_get_3"
1671+
| "caml_ba_get_generic"
1672+
| "caml_ba_set_1"
1673+
| "caml_ba_set_2"
1674+
| "caml_ba_set_3"
1675+
| "caml_ba_set_generic" )
1676+
, _ )
16761677
, _ ) ) -> fst n, true
16771678
| Let
16781679
( _
16791680
, Prim
16801681
( Extern
1681-
( "%int_div"
1682-
| "%int_mod"
1683-
| "caml_int32_div"
1684-
| "caml_int32_mod"
1685-
| "caml_int64_div"
1686-
| "caml_int64_mod"
1687-
| "caml_nativeint_div"
1688-
| "caml_nativeint_mod" )
1682+
( ( "%int_div"
1683+
| "%int_mod"
1684+
| "caml_int32_div"
1685+
| "caml_int32_mod"
1686+
| "caml_int64_div"
1687+
| "caml_int64_mod"
1688+
| "caml_nativeint_div"
1689+
| "caml_nativeint_mod" )
1690+
, _ )
16891691
, _ ) ) -> true, snd n
16901692
| _ -> n)
16911693
~init:n

‎compiler/lib-wasm/typing.ml‎

Lines changed: 20 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -244,13 +244,14 @@ let update_deps st { blocks; _ } =
244244
( x
245245
, Prim
246246
( Extern
247-
( "%int_and"
248-
| "%int_or"
249-
| "%int_xor"
250-
| "caml_ba_get_1"
251-
| "caml_ba_get_2"
252-
| "caml_ba_get_3"
253-
| "caml_ba_get_generic" )
247+
( ( "%int_and"
248+
| "%int_or"
249+
| "%int_xor"
250+
| "caml_ba_get_1"
251+
| "caml_ba_get_2"
252+
| "caml_ba_get_3"
253+
| "caml_ba_get_generic" )
254+
, _ )
254255
, lst ) ) ->
255256
(* The return type of these primitives depend on the input type *)
256257
List.iter
@@ -521,9 +522,10 @@ let propagate st approx x : Domain.t =
521522
| Top -> Top
522523
| _ -> Bot)
523524
| Prim
524-
( Extern ("caml_check_bound" | "caml_check_bound_float" | "caml_check_bound_gen")
525+
( Extern
526+
(("caml_check_bound" | "caml_check_bound_float" | "caml_check_bound_gen"), _)
525527
, [ Pv y; _ ] ) -> Var.Tbl.get approx y
526-
| Prim ((Array_get | Extern "caml_array_unsafe_get"), [ Pv y; _ ]) -> (
528+
| Prim ((Array_get | Extern ("caml_array_unsafe_get", _)), [ Pv y; _ ]) -> (
527529
match Var.Tbl.get st.global_flow_info.info_approximation y with
528530
| Values { known; others } ->
529531
Domain.join_set
@@ -549,8 +551,9 @@ let propagate st approx x : Domain.t =
549551
known
550552
| Top -> Top)
551553
| Prim (Array_get, _) -> Top
552-
| Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> Int Normalized
553-
| Prim (Extern prim, args) -> prim_type ~st ~approx prim args
554+
| Prim ((Vectlength _ | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) ->
555+
Int Normalized
556+
| Prim (Extern (prim, _), args) -> prim_type ~st ~approx prim args
554557
| Special _ -> Top
555558
| Apply { f; args; _ } -> (
556559
match Var.Tbl.get st.global_flow_info.info_approximation f with
@@ -566,8 +569,9 @@ let propagate st approx x : Domain.t =
566569
(fun y ->
567570
match st.global_flow_state.defs.(Var.idx y) with
568571
| Expr
569-
(Prim (Extern "caml_ba_create", [ Pv kind; Pv layout; _ ]))
570-
-> (
572+
(Prim
573+
( Extern ("caml_ba_create", _)
574+
, [ Pv kind; Pv layout; _ ] )) -> (
571575
let m =
572576
List.fold_left2
573577
~f:(fun m p a -> Var.Map.add p a m)
@@ -826,7 +830,7 @@ let box_numbers p st types =
826830
| Some (g, _) -> not (can_unbox_parameters st.fun_info g)
827831
then List.iter ~f:box args
828832
| Block (tag, lst, _, _) -> if tag <> 254 then Array.iter ~f:box lst
829-
| Prim (Extern s, args) ->
833+
| Prim (Extern (s, _), args) ->
830834
if
831835
not
832836
(String.Hashtbl.mem primitives_with_unboxed_parameters s
@@ -846,7 +850,7 @@ let box_numbers p st types =
846850
| Pv y -> box y
847851
| Pc _ -> ())
848852
args
849-
| Prim ((Vectlength | Array_get | Not | IsInt | Lt | Le | Ult), _)
853+
| Prim ((Vectlength _ | Array_get | Not | IsInt | Lt | Le | Ult), _)
850854
| Field _ | Closure _ | Constant _ | Special _ -> ())
851855
| Set_field (_, _, Non_float, y) | Array_set (_, _, y) -> box y
852856
| Assign _ | Offset_ref _ | Set_field (_, _, Float, _) | Event _ -> ())
@@ -864,7 +868,7 @@ let box_numbers p st types =
864868

865869
let print_opt types global_flow_state f e =
866870
match e with
867-
| Prim (Extern name, args)
871+
| Prim (Extern (name, _), args)
868872
when type_specialized_primitive types global_flow_state name args ->
869873
Format.fprintf f " OPT"
870874
| _ -> ()

‎compiler/lib/code.ml‎

Lines changed: 18 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -286,9 +286,9 @@ end
286286
type cont = Addr.t * Var.t list
287287

288288
type prim =
289-
| Vectlength
289+
| Vectlength of Optimization_hint.array_kind
290290
| Array_get
291-
| Extern of string
291+
| Extern of string * Optimization_hint.t option
292292
| Not
293293
| IsInt
294294
| Eq
@@ -547,17 +547,23 @@ module Print = struct
547547
| "%int_neg" -> "-"
548548
| _ -> raise Not_found
549549

550+
let hint f h =
551+
match h with
552+
| None -> ()
553+
| Some h -> Format.fprintf f " [hint:%a]" Optimization_hint.print h
554+
550555
let prim f p l =
551556
match p, l with
552-
| Vectlength, [ x ] -> Format.fprintf f "%a.length" arg x
557+
| Vectlength k, [ x ] ->
558+
Format.fprintf f "%a.length%a" arg x hint (Some (Optimization_hint.Hint_array k))
553559
| Array_get, [ x; y ] -> Format.fprintf f "%a[%a]" arg x arg y
554-
| Extern s, [ x; y ] -> (
555-
try Format.fprintf f "%a %s %a" arg x (binop s) arg y
556-
with Not_found -> Format.fprintf f "\"%s\"(%a)" s (list arg) l)
557-
| Extern s, [ x ] -> (
558-
try Format.fprintf f "%s %a" (unop s) arg x
559-
with Not_found -> Format.fprintf f "\"%s\"(%a)" s (list arg) l)
560-
| Extern s, _ -> Format.fprintf f "\"%s\"(%a)" s (list arg) l
560+
| Extern (s, h), [ x; y ] -> (
561+
try Format.fprintf f "%a %s %a%a" arg x (binop s) arg y hint h
562+
with Not_found -> Format.fprintf f "\"%s\"(%a)%a" s (list arg) l hint h)
563+
| Extern (s, h), [ x ] -> (
564+
try Format.fprintf f "%s %a%a" (unop s) arg x hint h
565+
with Not_found -> Format.fprintf f "\"%s\"(%a) %a" s (list arg) l hint h)
566+
| Extern (s, h), _ -> Format.fprintf f "\"%s\"(%a) %a" s (list arg) l hint h
561567
| Not, [ x ] -> Format.fprintf f "!%a" arg x
562568
| IsInt, [ x ] -> Format.fprintf f "is_int(%a)" arg x
563569
| Eq, [ x; y ] -> Format.fprintf f "%a === %a" arg x arg y
@@ -689,7 +695,8 @@ let is_empty p =
689695
match v with
690696
| { body; branch = Stop; params = _ } -> (
691697
match body with
692-
| ([] | [ Let (_, Prim (Extern "caml_get_global_data", _)) ]) when true -> true
698+
| ([] | [ Let (_, Prim (Extern ("caml_get_global_data", None), _)) ]) when true
699+
-> true
693700
| _ -> false)
694701
| _ -> false)
695702
| _ -> false

‎compiler/lib/code.mli‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -112,9 +112,9 @@ end
112112
type cont = Addr.t * Var.t list
113113

114114
type prim =
115-
| Vectlength
115+
| Vectlength of Optimization_hint.array_kind
116116
| Array_get
117-
| Extern of string
117+
| Extern of string * Optimization_hint.t option
118118
| Not
119119
| IsInt
120120
| Eq

‎compiler/lib/deadcode.ml‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -97,7 +97,7 @@ and mark_reachable st pc =
9797
let block = Addr.Map.find pc st.blocks in
9898
List.iter block.body ~f:(fun i ->
9999
match i with
100-
| Let (_, Prim (Extern "caml_update_dummy", [ Pv x; Pv y ])) ->
100+
| Let (_, Prim (Extern ("caml_update_dummy", _), [ Pv x; Pv y ])) ->
101101
if st.live.(Var.idx x) = 0
102102
then
103103
(* We will keep this instruction only if x is live *)
@@ -139,7 +139,8 @@ and mark_reachable st pc =
139139

140140
let live_instr st i =
141141
match i with
142-
| Let (_, Prim (Extern "caml_update_dummy", [ Pv x; Pv _ ])) -> st.live.(Var.idx x) > 0
142+
| Let (_, Prim (Extern ("caml_update_dummy", _), [ Pv x; Pv _ ])) ->
143+
st.live.(Var.idx x) > 0
143144
| Let (x, e) -> st.live.(Var.idx x) > 0 || not (pure_expr st.pure_funs e)
144145
| Assign (x, _) | Set_field (x, _, _, _) -> st.live.(Var.idx x) > 0
145146
| Event _ | Offset_ref _ | Array_set _ -> true

‎compiler/lib/driver.ml‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -112,15 +112,16 @@ let collects_shapes ~shapes (p : Code.program) =
112112
| Code.Let
113113
( _
114114
, Prim
115-
( Extern "caml_register_global"
115+
( Extern ("caml_register_global", _)
116116
, [ _code; Pv block; Pc (NativeString name) ] ) ) ->
117117
let name =
118118
match name with
119119
| Byte s -> s
120120
| Utf (Utf8 s) -> s
121121
in
122122
shapes := StringMap.add name block !shapes
123-
| Code.Let (_, Prim (Extern "caml_set_global", [ Pc (String name); Pv block ]))
123+
| Code.Let
124+
(_, Prim (Extern ("caml_set_global", _), [ Pc (String name); Pv block ]))
124125
-> shapes := StringMap.add name block !shapes
125126
| _ -> ()))
126127
p.blocks;

0 commit comments

Comments
 (0)