From 68171920223590289a38b4838075b69bd1fb50f6 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 8 Apr 2024 12:41:18 +0200 Subject: [PATCH] Compiler: track block mutability --- compiler/lib/code.ml | 18 ++++++++++--- compiler/lib/code.mli | 6 ++++- compiler/lib/deadcode.ml | 2 +- compiler/lib/duplicate.ml | 2 +- compiler/lib/eval.ml | 16 ++++++----- compiler/lib/flow.ml | 17 ++++++------ compiler/lib/freevars.ml | 2 +- compiler/lib/generate.ml | 2 +- compiler/lib/global_deadcode.ml | 12 ++++----- compiler/lib/global_flow.ml | 12 ++++----- compiler/lib/parse_bytecode.ml | 48 +++++++++++++++++++++++++-------- compiler/lib/phisimpl.ml | 2 +- compiler/lib/specialize_js.ml | 12 ++++----- compiler/lib/subst.ml | 2 +- 14 files changed, 99 insertions(+), 54 deletions(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 4501c6f500..0558eab6d7 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -333,13 +333,17 @@ type special = | Undefined | Alias_prim of string +type mutability = + | Immutable + | Maybe_mutable + type expr = | Apply of { f : Var.t ; args : Var.t list ; exact : bool } - | Block of int * Var.t array * array_or_not + | Block of int * Var.t array * array_or_not * mutability | Field of Var.t * int | Closure of Var.t list * cont | Constant of constant @@ -479,8 +483,14 @@ module Print = struct if exact then Format.fprintf f "%a!(%a)" Var.print g var_list args else Format.fprintf f "%a(%a)" Var.print g var_list args - | Block (t, a, _) -> - Format.fprintf f "{tag=%d" t; + | Block (t, a, _, mut) -> + Format.fprintf + f + "%s{tag=%d" + (match mut with + | Immutable -> "imm" + | Maybe_mutable -> "") + t; for i = 0 to Array.length a - 1 do Format.fprintf f "; %d = %a" i Var.print a.(i) done; @@ -732,7 +742,7 @@ let invariant { blocks; start; _ } = in let check_expr = function | Apply _ -> () - | Block (_, _, _) -> () + | Block (_, _, _, _) -> () | Field (_, _) -> () | Closure (l, cont) -> List.iter l ~f:define; diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 918846e32c..e11a3c8b0b 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -180,13 +180,17 @@ type special = | Undefined | Alias_prim of string +type mutability = + | Immutable + | Maybe_mutable + type expr = | Apply of { f : Var.t ; args : Var.t list ; exact : bool (* if true, then # of arguments = # of parameters *) } - | Block of int * Var.t array * array_or_not + | Block of int * Var.t array * array_or_not * mutability | Field of Var.t * int | Closure of Var.t list * cont | Constant of constant diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml index 6cf27d6613..91ebd29d37 100644 --- a/compiler/lib/deadcode.ml +++ b/compiler/lib/deadcode.ml @@ -70,7 +70,7 @@ and mark_expr st e = | Apply { f; args; _ } -> mark_var st f; List.iter args ~f:(fun x -> mark_var st x) - | Block (_, a, _) -> Array.iter a ~f:(fun x -> mark_var st x) + | Block (_, a, _, _) -> Array.iter a ~f:(fun x -> mark_var st x) | Field (x, _) -> mark_var st x | Closure (_, (pc, _)) -> mark_reachable st pc | Special _ -> () diff --git a/compiler/lib/duplicate.ml b/compiler/lib/duplicate.ml index 330b106732..1315273b3c 100644 --- a/compiler/lib/duplicate.ml +++ b/compiler/lib/duplicate.ml @@ -26,7 +26,7 @@ let expr s e = | Constant _ -> e | Apply { f; args; exact } -> Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } - | Block (n, a, k) -> Block (n, Array.map a ~f:(fun x -> s x), k) + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) | Field (x, n) -> Field (s x, n) | Closure _ -> failwith "Inlining/Duplicating closure is currenly not supported" | Special x -> Special x diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 9f809f55b2..40df068a7d 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -177,7 +177,7 @@ let is_int info x = (fun x -> match Flow.Info.def info x with | Some (Constant (Int _)) -> Y - | Some (Block (_, _, _) | Constant _) -> N + | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) Unknown (fun u v -> @@ -196,8 +196,12 @@ let the_tag_of info x get = info (fun x -> match Flow.Info.def info x with - | Some (Block (j, _, _)) -> - if Flow.Info.possibly_mutable info x then None else get j + | Some (Block (j, _, _, mut)) -> + if Flow.Info.possibly_mutable info x + then ( + assert (Poly.(mut = Maybe_mutable)); + None) + else get j | Some (Constant (Tuple (j, _, _))) -> get j | None | Some _ -> None) None @@ -278,7 +282,7 @@ let eval_instr info ((x, loc) as i) = | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in [ Let (jsoo, Constant (String "js_of_ocaml")), noloc - ; Let (x, Block (0, [| jsoo |], NotArray)), loc + ; Let (x, Block (0, [| jsoo |], NotArray, Immutable)), loc ] | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) -> [ i ] (* We need that the arguments to this primitives remain variables *) @@ -338,7 +342,7 @@ let the_cond_of info x = | NativeString _ | Float_array _ | Int64 _ )) -> Non_zero - | Some (Block (_, _, _)) -> Non_zero + | Some (Block (_, _, _, _)) -> Non_zero | Some (Field _ | Closure _ | Prim _ | Apply _ | Special _) -> Unknown | None -> Unknown) Unknown @@ -381,7 +385,7 @@ let rec do_not_raise pc visited blocks = | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _) | Assign _ -> () | Let (_, e) -> ( match e with - | Block (_, _, _) | Field (_, _) | Constant _ | Closure _ -> () + | Block (_, _, _, _) | Field (_, _) | Constant _ | Closure _ -> () | Apply _ -> raise May_raise | Special _ -> () | Prim (Extern name, _) when Primitive.is_pure name -> () diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 5217d64cfe..412af3089a 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -103,7 +103,7 @@ let expr_deps blocks vars deps defs x e = | Closure (l, cont) -> List.iter l ~f:(fun x -> add_param_def vars defs x); cont_deps blocks vars deps defs cont - | Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) + | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) | Field (y, _) -> add_dep deps x y let program_deps { blocks; _ } = @@ -152,7 +152,7 @@ let propagate1 deps defs st x = var_set_lift (fun z -> match defs.(Var.idx z) with - | Expr (Block (_, a, _)) when n < Array.length a -> + | Expr (Block (_, a, _, _)) when n < Array.length a -> let t = a.(n) in add_dep deps x t; Var.Tbl.get st t @@ -194,7 +194,7 @@ let rec block_escape st x = Code.Var.ISet.add st.may_escape y; Code.Var.ISet.add st.possibly_mutable y; match st.defs.(Var.idx y) with - | Expr (Block (_, l, _)) -> Array.iter l ~f:(fun z -> block_escape st z) + | Expr (Block (_, l, _, _)) -> Array.iter l ~f:(fun z -> block_escape st z) | _ -> ())) (Var.Tbl.get st.known_origins x) @@ -226,15 +226,16 @@ let expr_escape st _x e = | Pv v, `Shallow_const -> ( match st.defs.(Var.idx v) with | Expr (Constant (Tuple _)) -> () - | Expr (Block (_, a, _)) -> Array.iter a ~f:(fun x -> block_escape st x) + | Expr (Block (_, a, _, _)) -> + Array.iter a ~f:(fun x -> block_escape st x) | _ -> block_escape st v) | Pv v, `Object_literal -> ( match st.defs.(Var.idx v) with | Expr (Constant (Tuple _)) -> () - | Expr (Block (_, a, _)) -> + | Expr (Block (_, a, _, _)) -> Array.iter a ~f:(fun x -> match st.defs.(Var.idx x) with - | Expr (Block (_, [| _k; v |], _)) -> block_escape st v + | Expr (Block (_, [| _k; v |], _, _)) -> block_escape st v | Expr (Constant _) -> () | _ -> block_escape st x) | _ -> block_escape st v) @@ -282,7 +283,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x = || Var.Set.exists (fun z -> match defs.(Var.idx z) with - | Expr (Block (_, a, _)) -> + | Expr (Block (_, a, _, _)) -> n >= Array.length a || Var.ISet.mem possibly_mutable z || Var.Tbl.get st a.(n) @@ -382,7 +383,7 @@ let direct_approx (info : Info.t) x = then None else match info.info_defs.(Var.idx z) with - | Expr (Block (_, a, _)) when n < Array.length a -> Some a.(n) + | Expr (Block (_, a, _, _)) when n < Array.length a -> Some a.(n) | _ -> None) None (fun u v -> diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml index 95c9d51401..d65a54c64c 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -33,7 +33,7 @@ let iter_expr_free_vars f e = | Apply { f = x; args; _ } -> f x; List.iter ~f args - | Block (_, a, _) -> Array.iter ~f a + | Block (_, a, _, _) -> Array.iter ~f a | Field (x, _) -> f x | Closure _ -> () | Special _ -> () diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index d55faf954a..1e5ccc87dd 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1042,7 +1042,7 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list = let prop = or_p prop prop' in let e = apply_fun ctx f args exact cps loc in (e, prop, queue), [] - | Block (tag, a, array_or_not) -> + | Block (tag, a, array_or_not, _mut) -> let contents, prop, queue = List.fold_right ~f:(fun x (args, prop, queue) -> diff --git a/compiler/lib/global_deadcode.ml b/compiler/lib/global_deadcode.ml index 7da4c55a0c..83079a761a 100644 --- a/compiler/lib/global_deadcode.ml +++ b/compiler/lib/global_deadcode.ml @@ -126,7 +126,7 @@ let usages prog (global_info : Global_flow.info) : usage_kind Var.Map.t Var.Tbl. List.iter ~f:(fun a -> if variable_may_escape a global_info then add_use Compute x a) args - | Block (_, vars, _) -> Array.iter ~f:(add_use Compute x) vars + | Block (_, vars, _, _) -> Array.iter ~f:(add_use Compute x) vars | Field (z, _) -> add_use Compute x z | Constant _ -> () | Special _ -> () @@ -172,7 +172,7 @@ let expr_vars e = | Apply { f; args; _ } -> let vars = Var.Set.add f vars in List.fold_left ~f:(fun acc x -> Var.Set.add x acc) ~init:vars args - | Block (_, params, _) -> + | Block (_, params, _, _) -> Array.fold_left ~f:(fun acc x -> Var.Set.add x acc) ~init:vars params | Field (z, _) -> Var.Set.add z vars | Prim (_, args) -> @@ -223,7 +223,7 @@ let liveness prog pure_funs (global_info : Global_flow.info) = List.iter ~f:(fun x -> if variable_may_escape x global_info then add_top x) args - | Block (_, _, _) + | Block (_, _, _, _) | Field (_, _) | Closure (_, _) | Constant _ @@ -286,7 +286,7 @@ let propagate uses defs live_vars live_table x = (* If y is a live block, then x is the join of liveness fields that are x *) | Live fields -> ( match Var.Tbl.get defs y with - | Expr (Block (_, vars, _)) -> + | Expr (Block (_, vars, _, _)) -> let found = ref false in Array.iteri ~f:(fun i v -> @@ -341,7 +341,7 @@ let zero prog sentinal live_table = match instr with | Let (x, e) -> ( match e with - | Block (start, vars, is_array) -> ( + | Block (start, vars, is_array, mut) -> ( match Var.Tbl.get live_table x with | Live fields -> let vars = @@ -350,7 +350,7 @@ let zero prog sentinal live_table = vars |> compact_vars in - let e = Block (start, vars, is_array) in + let e = Block (start, vars, is_array, mut) in Let (x, e) | _ -> instr) | Apply ap -> diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 5f3a21529d..0f90c2b355 100644 --- a/compiler/lib/global_flow.ml +++ b/compiler/lib/global_flow.ml @@ -194,15 +194,15 @@ let expr_deps blocks st x e = | Pv v, `Const -> do_escape st Escape_constant v | Pv v, `Shallow_const -> ( match st.defs.(Var.idx v) with - | Expr (Block (_, a, _)) -> + | Expr (Block (_, a, _, _)) -> Array.iter a ~f:(fun x -> do_escape st Escape x) | _ -> do_escape st Escape v) | Pv v, `Object_literal -> ( match st.defs.(Var.idx v) with - | Expr (Block (_, a, _)) -> + | Expr (Block (_, a, _, _)) -> Array.iter a ~f:(fun x -> match st.defs.(Var.idx x) with - | Expr (Block (_, [| _k; v |], _)) -> do_escape st Escape v + | Expr (Block (_, [| _k; v |], _, _)) -> do_escape st Escape v | _ -> do_escape st Escape x) | _ -> do_escape st Escape v) | Pv v, `Mutable -> do_escape st Escape v); @@ -325,7 +325,7 @@ module Domain = struct then ( st.may_escape.(idx) <- s; match st.defs.(idx) with - | Expr (Block (_, a, _)) -> ( + | Expr (Block (_, a, _, _)) -> ( Array.iter ~f:(fun y -> variable_escape ~update ~st ~approx s y) a; match s with | Escape -> @@ -410,7 +410,7 @@ let propagate st ~update approx x = ~approx (fun z -> match st.defs.(Var.idx z) with - | Expr (Block (t, a, _)) + | Expr (Block (t, a, _, _)) when n < Array.length a && match tags with @@ -440,7 +440,7 @@ let propagate st ~update approx x = ~others (fun z -> match st.defs.(Var.idx z) with - | Expr (Block (_, lst, _)) -> + | Expr (Block (_, lst, _, _)) -> Array.iter ~f:(fun t -> add_dep st x t) lst; let a = Array.fold_left diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index f4e7f0a630..b9e4b1e8c9 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -1383,26 +1383,42 @@ and compile infos pc state instrs = let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x; - compile infos (pc + 1) state ((Let (x, Block (0, [||], Unknown)), loc) :: instrs) + compile + infos + (pc + 1) + state + ((Let (x, Block (0, [||], Unknown, Maybe_mutable)), loc) :: instrs) | ATOM -> let i = getu code (pc + 1) in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i; - compile infos (pc + 2) state ((Let (x, Block (i, [||], NotArray)), loc) :: instrs) + compile + infos + (pc + 2) + state + ((Let (x, Block (i, [||], Unknown, Maybe_mutable)), loc) :: instrs) | PUSHATOM0 -> let state = State.push state loc in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = ATOM(0)@." Var.print x; - compile infos (pc + 1) state ((Let (x, Block (0, [||], Unknown)), loc) :: instrs) + compile + infos + (pc + 1) + state + ((Let (x, Block (0, [||], Unknown, Maybe_mutable)), loc) :: instrs) | PUSHATOM -> let state = State.push state loc in let i = getu code (pc + 1) in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = ATOM(%d)@." Var.print x i; - compile infos (pc + 2) state ((Let (x, Block (i, [||], NotArray)), loc) :: instrs) + compile + infos + (pc + 2) + state + ((Let (x, Block (i, [||], Unknown, Maybe_mutable)), loc) :: instrs) | MAKEBLOCK -> let size = getu code (pc + 1) in let tag = getu code (pc + 2) in @@ -1421,7 +1437,12 @@ and compile infos pc state instrs = infos (pc + 3) state - ((Let (x, Block (tag, Array.of_list (List.map ~f:fst contents), Unknown)), loc) + (( Let + ( x + , Block + (tag, Array.of_list (List.map ~f:fst contents), Unknown, Maybe_mutable) + ) + , loc ) :: instrs) | MAKEBLOCK1 -> let tag = getu code (pc + 1) in @@ -1433,7 +1454,7 @@ and compile infos pc state instrs = infos (pc + 2) state - ((Let (x, Block (tag, [| y |], NotArray)), loc) :: instrs) + ((Let (x, Block (tag, [| y |], Unknown, Maybe_mutable)), loc) :: instrs) | MAKEBLOCK2 -> let tag = getu code (pc + 1) in let y, _ = State.accu state in @@ -1447,7 +1468,7 @@ and compile infos pc state instrs = infos (pc + 2) (State.pop 1 state) - ((Let (x, Block (tag, [| y; z |], NotArray)), loc) :: instrs) + ((Let (x, Block (tag, [| y; z |], Unknown, Maybe_mutable)), loc) :: instrs) | MAKEBLOCK3 -> let tag = getu code (pc + 1) in let y, _ = State.accu state in @@ -1471,7 +1492,7 @@ and compile infos pc state instrs = infos (pc + 2) (State.pop 2 state) - ((Let (x, Block (tag, [| y; z; t |], NotArray)), loc) :: instrs) + ((Let (x, Block (tag, [| y; z; t |], Unknown, Maybe_mutable)), loc) :: instrs) | MAKEFLOATBLOCK -> let size = getu code (pc + 1) in let state = State.push state loc in @@ -1489,7 +1510,12 @@ and compile infos pc state instrs = infos (pc + 2) state - ((Let (x, Block (254, Array.of_list (List.map ~f:fst contents), Unknown)), loc) + (( Let + ( x + , Block + (254, Array.of_list (List.map ~f:fst contents), Unknown, Maybe_mutable) + ) + , loc ) :: instrs) | GETFIELD0 -> let y, _ = State.accu state in @@ -2516,7 +2542,7 @@ let override_global = let init_mod = Var.fresh_n "init_mod" in let update_mod = Var.fresh_n "update_mod" in ( x - , (Let (x, Block (0, [| init_mod; update_mod |], NotArray)), noloc) + , (Let (x, Block (0, [| init_mod; update_mod |], NotArray, Immutable)), noloc) :: ( Let (init_mod, Special (Alias_prim "caml_CamlinternalMod_init_mod")) , noloc ) :: ( Let (update_mod, Special (Alias_prim "caml_CamlinternalMod_update_mod")) @@ -3090,7 +3116,7 @@ let predefined_exceptions () = Int32.of_int (-index - 1))) ) , noloc ) - ; Let (exn, Block (248, [| v_name; v_index |], NotArray)), noloc + ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc ; ( Let ( Var.fresh () , Prim diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index b8e730e4be..bbb3537af9 100644 --- a/compiler/lib/phisimpl.ml +++ b/compiler/lib/phisimpl.ml @@ -53,7 +53,7 @@ let expr_deps blocks vars deps defs x e = match e with | Constant _ | Apply _ | Prim _ | Special _ -> () | Closure (_, cont) -> cont_deps blocks vars deps defs cont - | Block (_, a, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) + | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) | Field (y, _) -> add_dep deps x y let program_deps { blocks; _ } = diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 6cc3388c7f..84d4c8626f 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -53,13 +53,13 @@ let specialize_instr info i = | None -> i) | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])) -> ( match the_def_of info a with - | Some (Block (_, a, _)) -> + | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])) -> ( match the_def_of info a with - | Some (Block (_, a, _)) -> + | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) @@ -67,7 +67,7 @@ let specialize_instr info i = match the_string_of info m with | Some m when Javascript.is_ident m -> ( match the_def_of info a with - | Some (Block (_, a, _)) -> + | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let ( x @@ -80,7 +80,7 @@ let specialize_instr info i = | _ -> i) | Let (x, Prim (Extern "caml_js_new", [ c; a ])) -> ( match the_def_of info a with - | Some (Block (_, a, _)) -> + | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i) @@ -88,13 +88,13 @@ let specialize_instr info i = try let a = match the_def_of info a with - | Some (Block (_, a, _)) -> a + | Some (Block (_, a, _, _)) -> a | _ -> raise Exit in let a = Array.map a ~f:(fun x -> match the_def_of info (Pv x) with - | Some (Block (_, [| k; v |], _)) -> + | Some (Block (_, [| k; v |], _, _)) -> let k = match the_string_of info (Pv k) with | Some s when String.is_valid_utf_8 s -> diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 1f76c7376e..4e735576c3 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -28,7 +28,7 @@ let expr s e = | Constant _ -> e | Apply { f; args; exact } -> Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } - | Block (n, a, k) -> Block (n, Array.map a ~f:(fun x -> s x), k) + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) | Field (x, n) -> Field (s x, n) | Closure (l, pc) -> Closure (l, subst_cont s pc) | Special _ -> e