Skip to content

Commit 6dc6697

Browse files
hhugoOlivierNicole
hhugo
authored and
OlivierNicole
committed
Compiler: dedicated type for "special" values (#1573)
1 parent de31b5a commit 6dc6697

21 files changed

+61
-34
lines changed

‎compiler/lib/code.ml

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -334,6 +334,10 @@ type prim_arg =
334334
| Pv of Var.t
335335
| Pc of constant
336336

337+
type special =
338+
| Undefined
339+
| Alias_prim of string
340+
337341
type expr =
338342
| Apply of
339343
{ f : Var.t
@@ -345,6 +349,7 @@ type expr =
345349
| Closure of Var.t list * cont
346350
| Constant of constant
347351
| Prim of prim * prim_arg list
352+
| Special of special
348353

349354
type instr =
350355
| Let of Var.t * expr
@@ -476,6 +481,11 @@ module Print = struct
476481
| Ult, [ x; y ] -> Format.fprintf f "%a <= %a" arg x arg y
477482
| _ -> assert false
478483

484+
let special f s =
485+
match s with
486+
| Undefined -> Format.fprintf f "undefined"
487+
| Alias_prim s -> Format.fprintf f "alias %s" s
488+
479489
let expr f e =
480490
match e with
481491
| Apply { f = g; args; exact } ->
@@ -492,6 +502,7 @@ module Print = struct
492502
| Closure (l, c) -> Format.fprintf f "fun(%a){%a}" var_list l cont c
493503
| Constant c -> Format.fprintf f "CONST{%a}" constant c
494504
| Prim (p, l) -> prim f p l
505+
| Special s -> special f s
495506

496507
let instr f (i, _loc) =
497508
match i with
@@ -756,6 +767,7 @@ let invariant { blocks; start; _ } =
756767
check_cont cont
757768
| Constant _ -> ()
758769
| Prim (_, _) -> ()
770+
| Special _ -> ()
759771
in
760772
let check_instr (i, _loc) =
761773
match i with

‎compiler/lib/code.mli

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -181,6 +181,10 @@ type prim_arg =
181181
| Pv of Var.t
182182
| Pc of constant
183183

184+
type special =
185+
| Undefined
186+
| Alias_prim of string
187+
184188
type expr =
185189
| Apply of
186190
{ f : Var.t
@@ -192,6 +196,7 @@ type expr =
192196
| Closure of Var.t list * cont
193197
| Constant of constant
194198
| Prim of prim * prim_arg list
199+
| Special of special
195200

196201
type instr =
197202
| Let of Var.t * expr

‎compiler/lib/deadcode.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ and mark_expr st e =
6464
| Block (_, a, _) -> Array.iter a ~f:(fun x -> mark_var st x)
6565
| Field (x, _) -> mark_var st x
6666
| Closure (_, (pc, _)) -> mark_reachable st pc
67+
| Special _ -> ()
6768
| Prim (_, l) ->
6869
List.iter l ~f:(fun x ->
6970
match x with

‎compiler/lib/eval.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -367,7 +367,7 @@ let the_cond_of info x =
367367
| Float_array _
368368
| Int64 _ )) -> Non_zero
369369
| Expr (Block (_, _, _)) -> Non_zero
370-
| Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown
370+
| Expr (Field _ | Closure _ | Prim _ | Apply _ | Special _) -> Unknown
371371
| Param | Phi _ -> Unknown)
372372
Unknown
373373
(fun u v ->
@@ -416,6 +416,7 @@ let rec do_not_raise pc visited blocks =
416416
match e with
417417
| Block (_, _, _) | Field (_, _) | Constant _ | Closure _ -> ()
418418
| Apply _ -> raise May_raise
419+
| Special _ -> ()
419420
| Prim (Extern name, _) when Primitive.is_pure name -> ()
420421
| Prim (Extern _, _) -> raise May_raise
421422
| Prim (_, _) -> ()));

‎compiler/lib/flow.ml

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,7 @@ let cont_deps blocks vars deps defs (pc, args) =
8989

9090
let expr_deps blocks vars deps defs x e =
9191
match e with
92-
| Constant _ | Apply _ | Prim _ -> ()
92+
| Constant _ | Apply _ | Prim _ | Special _ -> ()
9393
| Closure (l, cont) ->
9494
List.iter l ~f:(fun x -> add_param_def vars defs x);
9595
cont_deps blocks vars deps defs cont
@@ -137,7 +137,8 @@ let propagate1 deps defs st x =
137137
| Phi s -> var_set_lift (fun y -> Var.Tbl.get st y) s
138138
| Expr e -> (
139139
match e with
140-
| Constant _ | Apply _ | Prim _ | Closure _ | Block _ -> Var.Set.singleton x
140+
| Constant _ | Apply _ | Prim _ | Special _ | Closure _ | Block _ ->
141+
Var.Set.singleton x
141142
| Field (y, n) ->
142143
var_set_lift
143144
(fun z ->
@@ -190,7 +191,7 @@ let rec block_escape st x =
190191

191192
let expr_escape st _x e =
192193
match e with
193-
| Constant _ | Closure _ | Block _ | Field _ -> ()
194+
| Special _ | Constant _ | Closure _ | Block _ | Field _ -> ()
194195
| Apply { args; _ } -> List.iter args ~f:(fun x -> block_escape st x)
195196
| Prim (Array_get, [ Pv x; _ ]) -> block_escape st x
196197
| Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> ()
@@ -266,7 +267,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x =
266267
| Phi s -> Var.Set.exists (fun y -> Var.Tbl.get st y) s
267268
| Expr e -> (
268269
match e with
269-
| Constant _ | Closure _ | Apply _ | Prim _ | Block _ -> false
270+
| Constant _ | Closure _ | Apply _ | Prim _ | Block _ | Special _ -> false
270271
| Field (y, n) ->
271272
Var.Tbl.get st y
272273
|| Var.Set.exists

‎compiler/lib/freevars.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ let iter_expr_free_vars f e =
3636
| Block (_, a, _) -> Array.iter ~f a
3737
| Field (x, _) -> f x
3838
| Closure _ -> ()
39+
| Special _ -> ()
3940
| Prim (_, l) ->
4041
List.iter l ~f:(fun x ->
4142
match x with

‎compiler/lib/generate.ml

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -165,7 +165,7 @@ module Share = struct
165165
if (not exact) || cps
166166
then add_apply { arity = List.length args; exact; cps } share
167167
else share
168-
| Let (_, Prim (Extern "%closure", [ Pc (String name) ])) ->
168+
| Let (_, Special (Alias_prim name)) ->
169169
let name = Primitive.resolve name in
170170
let share =
171171
if Primitive.exists name then add_prim name share else share
@@ -1261,6 +1261,11 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
12611261
| Constant c ->
12621262
let js, instrs = constant ~ctx c level in
12631263
(js, const_p, queue), instrs
1264+
| Special (Alias_prim name) ->
1265+
let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
1266+
(prim, const_p, queue), []
1267+
| Special Undefined ->
1268+
(J.(EVar (ident (Utf8_string.of_string_exn "undefined"))), const_p, queue), []
12641269
| Prim (Extern "debugger", _) ->
12651270
let ins =
12661271
if Config.Flag.debugger () then J.Debugger_statement else J.Empty_statement
@@ -1319,10 +1324,6 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
13191324
~init:([], const_p, queue)
13201325
in
13211326
J.array args, prop, queue
1322-
| Extern "%closure", [ Pc (String name) ] ->
1323-
let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
1324-
prim, const_p, queue
1325-
| Extern "%closure", _ -> assert false
13261327
| Extern "%caml_js_opt_call", f :: o :: l ->
13271328
let (pf, cf), queue = access_queue' ~ctx queue f in
13281329
let (po, co), queue = access_queue' ~ctx queue o in
@@ -1393,9 +1394,6 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
13931394
| Extern "caml_js_delete", [ _; Pc (String _) ] -> assert false
13941395
]}
13951396
*)
1396-
| Extern "%overrideMod", [ Pc (String m); Pc (String f) ] ->
1397-
runtime_fun ctx (Printf.sprintf "caml_%s_%s" m f), const_p, queue
1398-
| Extern "%overrideMod", _ -> assert false
13991397
| Extern "%caml_js_opt_object", fields ->
14001398
let rec build_fields queue l =
14011399
match l with

‎compiler/lib/global_flow.ml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,7 @@ let expr_deps blocks st x e =
153153
match e with
154154
| Constant _ | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) | Block _
155155
-> ()
156+
| Special _ -> ()
156157
| Prim
157158
( ( Extern
158159
( "caml_check_bound"
@@ -462,6 +463,7 @@ let propagate st ~update approx x =
462463
block *)
463464
Domain.bot
464465
| Prim (Extern _, _) -> Domain.others
466+
| Special _ -> Domain.others
465467
| Apply { f; args; _ } -> (
466468
match Var.Tbl.get approx f with
467469
| Values { known; others } ->

‎compiler/lib/inline.ml

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -167,6 +167,7 @@ let simple blocks cont mapping =
167167
})
168168
| Prim (prim, args) ->
169169
`Exp (Prim (prim, List.map args ~f:(map_prim_arg mapping)))
170+
| Special _ -> `Exp exp
170171
| Block (tag, args, aon) ->
171172
`Exp (Block (tag, Array.map args ~f:(map_var mapping), aon))
172173
| Field (x, i) -> `Exp (Field (map_var mapping x, i))
@@ -252,9 +253,7 @@ let inline ~first_class_primitives live_vars closures pc (outer, blocks, free_pc
252253
if Code.Var.compare y y' = 0
253254
&& Primitive.has_arity prim len
254255
&& args_equal l args
255-
then
256-
( (Let (x, Prim (Extern "%closure", [ Pc (String prim) ])), loc) :: rem
257-
, state )
256+
then (Let (x, Special (Alias_prim prim)), loc) :: rem, state
258257
else i :: rem, state
259258
| _ -> i :: rem, state)
260259
| _ -> i :: rem, state)

‎compiler/lib/parse_bytecode.ml

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2507,18 +2507,17 @@ let override_global =
25072507
match Ocaml_version.v with
25082508
| `V4_13 | `V4_14 | `V5_00 | `V5_01 | `V5_02 -> []
25092509
| `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 ->
2510-
let jsmodule name func =
2511-
Prim (Extern "%overrideMod", [ Pc (String name); Pc (String func) ])
2512-
in
25132510
[ ( "CamlinternalMod"
25142511
, fun _orig instrs ->
25152512
let x = Var.fresh_n "internalMod" in
25162513
let init_mod = Var.fresh_n "init_mod" in
25172514
let update_mod = Var.fresh_n "update_mod" in
25182515
( x
25192516
, (Let (x, Block (0, [| init_mod; update_mod |], NotArray)), noloc)
2520-
:: (Let (init_mod, jsmodule "CamlinternalMod" "init_mod"), noloc)
2521-
:: (Let (update_mod, jsmodule "CamlinternalMod" "update_mod"), noloc)
2517+
:: ( Let (init_mod, Special (Alias_prim "caml_CamlinternalMod_init_mod"))
2518+
, noloc )
2519+
:: ( Let (update_mod, Special (Alias_prim "caml_CamlinternalMod_update_mod"))
2520+
, noloc )
25222521
:: instrs ) )
25232522
]
25242523

‎compiler/lib/partial_cps_analysis.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ let block_deps ~info ~vars ~tail_deps ~deps ~blocks ~fun_name pc =
8888
in CPS *)
8989
add_dep deps f x)
9090
| Let (x, Closure _) -> add_var vars x
91-
| Let (_, (Prim _ | Block _ | Constant _ | Field _))
91+
| Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _))
9292
| Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ())
9393

9494
let program_deps ~info ~vars ~tail_deps ~deps p =
@@ -141,7 +141,7 @@ let cps_needed ~info ~in_mutual_recursion ~rev_deps st x =
141141
| Expr (Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) ->
142142
(* Effects primitives are in CPS *)
143143
true
144-
| Expr (Prim _ | Block _ | Constant _ | Field _) | Phi _ -> false
144+
| Expr (Prim _ | Block _ | Constant _ | Field _ | Special _) | Phi _ -> false
145145

146146
module SCC = Strongly_connected_components.Make (struct
147147
type t = Var.t

‎compiler/lib/phisimpl.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,7 @@ let cont_deps blocks vars deps defs (pc, args) =
5050

5151
let expr_deps blocks vars deps defs x e =
5252
match e with
53-
| Constant _ | Apply _ | Prim _ -> ()
53+
| Constant _ | Apply _ | Prim _ | Special _ -> ()
5454
| Closure (_, cont) -> cont_deps blocks vars deps defs cont
5555
| Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
5656
| Field (y, _) -> add_dep deps x y

‎compiler/lib/primitive.ml

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,10 @@ let arity nm = Hashtbl.find arities (resolve nm)
7373

7474
let has_arity nm a = try Hashtbl.find arities (resolve nm) = a with Not_found -> false
7575

76-
let is_pure nm = Poly.(kind nm <> `Mutator)
76+
let is_pure nm =
77+
match nm with
78+
| "%identity" | "%direct_int_div" | "%direct_int_mod" | "%direct_int_mul" -> true
79+
| _ -> Poly.(kind nm <> `Mutator)
7780

7881
let exists p = Hashtbl.mem kinds p
7982

‎compiler/lib/pure_fun.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ open Code
2525
let pure_expr pure_funs e =
2626
match e with
2727
| Block _ | Field _ | Closure _ | Constant _ -> true
28+
| Special (Alias_prim _ | Undefined) -> true
2829
| Apply { f; exact; _ } -> exact && Var.Set.mem f pure_funs
2930
| Prim (p, _l) -> (
3031
match p with

‎compiler/lib/specialize.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ let function_arity info x =
2828
(fun x ->
2929
match info.info_defs.(Var.idx x) with
3030
| Expr (Closure (l, _)) -> Some (List.length l)
31-
| Expr (Prim (Extern "%closure", [ Pc (String prim) ])) -> (
31+
| Expr (Special (Alias_prim prim)) -> (
3232
try Some (Primitive.arity prim) with Not_found -> None)
3333
| Expr (Apply { f; args; _ }) -> (
3434
if List.mem f ~set:acc

‎compiler/lib/subst.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ let expr s e =
3131
| Block (n, a, k) -> Block (n, Array.map a ~f:(fun x -> s x), k)
3232
| Field (x, n) -> Field (s x, n)
3333
| Closure (l, pc) -> Closure (l, subst_cont s pc)
34+
| Special _ -> e
3435
| Prim (p, l) ->
3536
Prim
3637
( p

‎compiler/lib/wasm/wa_generate.ml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -165,6 +165,8 @@ module Generate (Target : Wa_target_sig.S) = struct
165165
~cps:(Var.Set.mem x ctx.in_cps)
166166
x
167167
| Constant c -> Constant.translate c
168+
| Special Undefined -> Constant.translate (Int (Regular, 0l))
169+
| Special (Alias_prim _) -> assert false
168170
| Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int (_, arity)) ])
169171
when Poly.(target = `GC) ->
170172
Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Int32.to_int arity)

‎compiler/lib/wasm/wa_globalize.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ let traverse_expression x e st =
8080
~f:(fun st x -> use x st)
8181
~init:st
8282
(Code.Var.Map.find x st.closures).Wa_closure_conversion.free_variables
83-
| Constant _ -> st
83+
| Constant _ | Special _ -> st
8484
| Prim (_, args) ->
8585
List.fold_left
8686
~f:(fun st a ->

‎compiler/lib/wasm/wa_liveness.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -110,7 +110,7 @@ let expr_used ~context ~closures ~ctx x e s =
110110
| Block (_, a, _) -> add_array ~ctx s a
111111
| Prim (_, l) -> add_prim_args ~ctx s l
112112
| Closure _ -> add_list ~ctx s (function_free_variables ~context ~closures x)
113-
| Constant _ -> s
113+
| Constant _ | Special _ -> s
114114
| Field (x, _) -> add_var ~ctx s x
115115

116116
let propagate_through_instr ~context ~closures ~ctx (i, _) s =
@@ -185,7 +185,7 @@ let compute_instr_info ~blocks ~context ~closures ~domain ~ctx st =
185185
| Apply _ | Prim _ ->
186186
Var.Map.add x (Var.Set.remove x live_vars) live_info
187187
| Block _ | Closure _ -> Var.Map.add x live_vars' live_info
188-
| Constant _ | Field _ -> live_info)
188+
| Constant _ | Field _ | Special _ -> live_info)
189189
| Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> live_info
190190
in
191191
live_vars', live_info)

‎compiler/lib/wasm/wa_spilling.ml

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -167,7 +167,7 @@ let function_deps blocks ~context ~closures pc params =
167167
match i with
168168
| Let (x, e) -> (
169169
match e with
170-
| Constant _ -> mark_non_spillable x
170+
| Constant _ | Special _ -> mark_non_spillable x
171171
| Prim (p, _) when no_pointer p -> mark_non_spillable x
172172
| Closure _
173173
when List.is_empty (function_free_variables ~context ~closures x) ->
@@ -205,7 +205,7 @@ let propagate_through_expr ~context ~closures s x e =
205205
if List.is_empty (function_free_variables ~context ~closures x)
206206
then s
207207
else Var.Set.empty
208-
| Constant _ | Field _ -> s
208+
| Constant _ | Field _ | Special _ -> s
209209

210210
let propagate_through_instr ~context ~closures s (i, _) =
211211
match i with
@@ -310,7 +310,7 @@ let spilled_variables
310310
~f:(fun reloaded x -> check_spilled ~ctx loaded' x reloaded)
311311
fv
312312
~init:Var.Set.empty
313-
| Constant _ -> Var.Set.empty
313+
| Constant _ | Special _ -> Var.Set.empty
314314
| Field (x, _) -> check_spilled ~ctx loaded x Var.Set.empty)
315315
| Assign (_, x) | Offset_ref (x, _) ->
316316
check_spilled ~ctx loaded x Var.Set.empty
@@ -490,7 +490,7 @@ let spilling blocks st env bound_vars spilled_vars live_info pc params =
490490
in
491491
instr_info := Var.Map.add x sp !instr_info;
492492
stack, Var.Set.empty
493-
| Prim _ | Constant _ | Field _ -> stack, vars)
493+
| Prim _ | Constant _ | Field _ | Special _ -> stack, vars)
494494
| Assign _ | Offset_ref _ | Set_field _ | Array_set _ -> stack, vars
495495
in
496496
let vars =

‎compiler/tests-dynlink/export

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,3 @@
11
Stdlib
2-
Stdlib__Buffer
2+
Stdlib__Buffer
3+
Stdlib__buffer

0 commit comments

Comments
 (0)