Compiler: track block mutability (#1603)

Author: hhugo

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;

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

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 _ -> ()

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

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 -> ()

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 ->

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 _ -> ()

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) ->

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 ->

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