Review changes of term directory (#602)

Author: chambart

middle_end/flambda2/algorithms/container_types.ml

@@ -161,7 +161,17 @@ module Make_map (T : Thing) (Set : Set_plus_stdlib with type elt = T.t) = struct
 
   let replace _ _ _ : _ t = Misc.fatal_error "Not yet implemented"
 
-  let map_sharing = map
+  let map_sharing f t =
+    let changed = ref false in
+    let t' =
+      map
+        (fun v ->
+          let v' = f v in
+          if not (v == v') then changed := true;
+          v')
+        t
+    in
+    if not !changed then t else t'
 end
 [@@inline always]
 

middle_end/flambda2/algorithms/lmap.ml

@@ -120,16 +120,8 @@ module Make (T : Thing) : S with type key = T.t = struct
 
   let mapi f m = List.map (fun (k, v) -> k, f k v) m
 
-  let rec map_sharing f l0 =
-    match l0 with
-    | a :: l ->
-      let a' = f a in
-      let l' = map_sharing f l in
-      if a' == a && l' == l then l0 else a' :: l'
-    | [] -> []
-
   let map_sharing f m =
-    map_sharing
+    Misc.Stdlib.List.map_sharing
       (fun ((k, v) as pair) ->
         let v' = f v in
         if v' == v then pair else k, v')

middle_end/flambda2/bound_identifiers/bound_parameters.ml

@@ -72,8 +72,8 @@ let free_names t =
     (fun result param -> Name_occurrences.union result (BP.free_names param))
     Name_occurrences.empty t
 
-let apply_renaming t perm =
-  List.map (fun param -> BP.apply_renaming param perm) t
+let apply_renaming t renaming =
+  Misc.Stdlib.List.map_sharing (fun param -> BP.apply_renaming param renaming) t
 
 let all_ids_for_export t =
   Ids_for_export.union_list (List.map BP.all_ids_for_export t)

middle_end/flambda2/simplify/expr_builder.ml

@@ -863,7 +863,7 @@ let add_wrapper_for_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id
         in
         new_wrapper params expr ~free_names ~cost_metrics)
     | Apply_cont apply_cont -> (
-      let apply_cont = Apply_cont.update_continuation apply_cont cont in
+      let apply_cont = Apply_cont.with_continuation apply_cont cont in
       match rewrite_use uacc rewrite ~ctx:Apply_cont use_id apply_cont with
       | Apply_cont apply_cont -> Apply_cont apply_cont
       | Expr build_expr ->
@@ -890,7 +890,7 @@ let add_wrapper_for_switch_arm uacc apply_cont ~use_id arity :
       ~use_id arity
   with
   | This_continuation cont ->
-    Apply_cont (Apply_cont.update_continuation apply_cont cont)
+    Apply_cont (Apply_cont.with_continuation apply_cont cont)
   | Apply_cont apply_cont -> Apply_cont apply_cont
   | New_wrapper (cont, wrapper, free_names_of_handler, cost_metrics) ->
     New_wrapper (cont, wrapper, free_names_of_handler, cost_metrics)

middle_end/flambda2/simplify/simplify_apply_cont_expr.ml

@@ -79,7 +79,7 @@ let rebuild_apply_cont apply_cont ~args ~rewrite_id uacc ~after_rebuild =
        inlined continuation -- before it is wrapped in any [Let]-expressions
        needed as a result of the rewrite. *)
     let rewrite_use_result =
-      let apply_cont = AC.update_continuation_and_args apply_cont cont ~args in
+      let apply_cont = AC.with_continuation_and_args apply_cont cont ~args in
       let apply_cont =
         Simplify_common.clear_demoted_trap_action_and_patch_unused_exn_bucket
           uacc apply_cont

middle_end/flambda2/terms/or_variable.ml renamed to middle_end/flambda2/term_basics/or_variable.ml

@@ -37,11 +37,11 @@ let free_names t =
   | Const _ -> Name_occurrences.empty
   | Var (var, _dbg) -> Name_occurrences.singleton_variable var Name_mode.normal
 
-let apply_renaming t perm =
+let apply_renaming t renaming =
   match t with
   | Const _ -> t
   | Var (var, dbg) ->
-    let var' = Renaming.apply_variable perm var in
+    let var' = Renaming.apply_variable renaming var in
     if var == var' then t else Var (var', dbg)
 
 let value_map t ~default ~f =

middle_end/flambda2/terms/or_variable.mli renamed to middle_end/flambda2/term_basics/or_variable.mli

@@ -125,10 +125,10 @@ let free_names { k; args; trap_action; dbg = _ } =
       (Name_occurrences.union default (Trap_action.free_names trap_action))
       k ~has_traps:true
 
-let apply_renaming ({ k; args; trap_action; dbg } as t) perm =
-  let k' = Renaming.apply_continuation perm k in
-  let args' = Simple.List.apply_renaming args perm in
-  let trap_action' = Trap_action.Option.apply_renaming trap_action perm in
+let apply_renaming ({ k; args; trap_action; dbg } as t) renaming =
+  let k' = Renaming.apply_continuation renaming k in
+  let args' = Simple.List.apply_renaming args renaming in
+  let trap_action' = Trap_action.Option.apply_renaming trap_action renaming in
   if k == k' && args == args' && trap_action == trap_action'
   then t
   else { k = k'; args = args'; trap_action = trap_action'; dbg }
@@ -141,9 +141,9 @@ let all_ids_for_export { k; args; trap_action; dbg = _ } =
        k)
     args
 
-let update_continuation t continuation = { t with k = continuation }
+let with_continuation t continuation = { t with k = continuation }
 
-let update_continuation_and_args t cont ~args =
+let with_continuation_and_args t cont ~args =
   if Continuation.equal t.k cont && args == t.args
   then t
   else { t with k = cont; args }
@@ -156,13 +156,6 @@ let no_args t = match args t with [] -> true | _ :: _ -> false
 
 let is_goto t = no_args t && Option.is_none (trap_action t)
 
-let is_goto_to t k = Continuation.equal (continuation t) k && is_goto t
-
-let to_goto t =
-  if no_args t && Option.is_none (trap_action t)
-  then Some (continuation t)
-  else None
-
 let is_raise t =
   match t.trap_action with
   | Some (Pop { exn_handler; _ }) -> Continuation.equal t.k exn_handler

middle_end/flambda2/terms/apply_cont_expr.ml

@@ -42,11 +42,9 @@ val trap_action : t -> Trap_action.t option
 
 val debuginfo : t -> Debuginfo.t
 
-(* CR mshinwell: Use "with" not "update" *)
-val update_continuation : t -> Continuation.t -> t
+val with_continuation : t -> Continuation.t -> t
 
-val update_continuation_and_args :
-  t -> Continuation.t -> args:Simple.t list -> t
+val with_continuation_and_args : t -> Continuation.t -> args:Simple.t list -> t
 
 val update_args : t -> args:Simple.t list -> t
 
@@ -56,10 +54,6 @@ val is_raise : t -> bool
 
 val is_goto : t -> bool
 
-val is_goto_to : t -> Continuation.t -> bool
-
-val to_goto : t -> Continuation.t option
-
 val clear_trap_action : t -> t
 
 val to_one_arg_without_trap_action : t -> Simple.t option

middle_end/flambda2/terms/apply_cont_expr.mli

@@ -46,9 +46,9 @@ module Result_continuation = struct
     | Return k -> Name_occurrences.singleton_continuation k
     | Never_returns -> Name_occurrences.empty
 
-  let apply_renaming t perm =
+  let apply_renaming t renaming =
     match t with
-    | Return k -> Return (Renaming.apply_continuation perm k)
+    | Return k -> Return (Renaming.apply_continuation renaming k)
     | Never_returns -> Never_returns
 
   let all_ids_for_export t =
@@ -207,14 +207,16 @@ let apply_renaming
        inlining_state;
        probe_name;
        relative_history
-     } as t) perm =
-  let continuation' = Result_continuation.apply_renaming continuation perm in
+     } as t) renaming =
+  let continuation' =
+    Result_continuation.apply_renaming continuation renaming
+  in
   let exn_continuation' =
-    Exn_continuation.apply_renaming exn_continuation perm
+    Exn_continuation.apply_renaming exn_continuation renaming
   in
-  let callee' = Simple.apply_renaming callee perm in
-  let args' = Simple.List.apply_renaming args perm in
-  let call_kind' = Call_kind.apply_renaming call_kind perm in
+  let callee' = Simple.apply_renaming callee renaming in
+  let args' = Simple.List.apply_renaming args renaming in
+  let call_kind' = Call_kind.apply_renaming call_kind renaming in
   if continuation == continuation'
      && exn_continuation == exn_continuation'
      && callee == callee' && args == args' && call_kind == call_kind'

middle_end/flambda2/terms/apply_expr.ml

@@ -156,7 +156,7 @@ let free_names t =
   | Function
       { function_call = Direct { code_id; return_arity = _ }; alloc_mode = _ }
     ->
-    Name_occurrences.add_code_id Name_occurrences.empty code_id Name_mode.normal
+    Name_occurrences.singleton_code_id code_id Name_mode.normal
   | Function { function_call = Indirect_unknown_arity; alloc_mode = _ }
   | Function
       { function_call =
@@ -165,16 +165,12 @@ let free_names t =
       }
   | C_call { alloc = _; param_arity = _; return_arity = _; is_c_builtin = _ } ->
     Name_occurrences.empty
-  | Method { kind = _; obj; alloc_mode = _ } ->
-    Simple.pattern_match obj
-      ~name:(fun obj ~coercion:_ ->
-        Name_occurrences.singleton_name obj Name_mode.normal)
-      ~const:(fun _ -> Name_occurrences.empty)
+  | Method { kind = _; obj; alloc_mode = _ } -> Simple.free_names obj
 
-let apply_renaming t perm =
+let apply_renaming t renaming =
   match t with
   | Function { function_call = Direct { code_id; return_arity }; alloc_mode } ->
-    let code_id' = Renaming.apply_code_id perm code_id in
+    let code_id' = Renaming.apply_code_id renaming code_id in
     if code_id == code_id'
     then t
     else
@@ -191,7 +187,7 @@ let apply_renaming t perm =
   | C_call { alloc = _; param_arity = _; return_arity = _; is_c_builtin = _ } ->
     t
   | Method { kind; obj; alloc_mode } ->
-    let obj' = Simple.apply_renaming obj perm in
+    let obj' = Simple.apply_renaming obj renaming in
     if obj == obj' then t else Method { kind; obj = obj'; alloc_mode }
 
 let all_ids_for_export t =

middle_end/flambda2/terms/call_kind.ml

@@ -86,17 +86,6 @@ let create ~print_function_params_and_body code_id ~params_and_body
     ~contains_no_escaping_local_allocs ~stub ~(inline : Inline_attribute.t)
     ~is_a_functor ~recursive ~cost_metrics ~inlining_arguments ~dbg ~is_tupled
     ~is_my_closure_used ~inlining_decision ~absolute_history ~relative_history =
-  begin
-    match stub, inline with
-    | true, (Available_inline | Never_inline | Default_inline)
-    | ( false,
-        ( Never_inline | Default_inline | Always_inline | Available_inline
-        | Unroll _ ) ) ->
-      ()
-    | true, (Always_inline | Unroll _) ->
-      Misc.fatal_error
-        "Stubs may not be annotated as [Always_inline] or [Unroll]"
-  end;
   check_free_names_of_params_and_body ~print_function_params_and_body code_id
     ~params_and_body ~free_names_of_params_and_body;
   let code_metadata =

middle_end/flambda2/terms/code0.ml

@@ -292,17 +292,17 @@ let apply_renaming
        inlining_decision = _;
        absolute_history = _;
        relative_history = _
-     } as t) perm =
+     } as t) renaming =
   (* inlined and modified version of Option.map to preserve sharing *)
   let newer_version_of' =
     match newer_version_of with
     | None -> newer_version_of
     | Some code_id ->
-      let code_id' = Renaming.apply_code_id perm code_id in
+      let code_id' = Renaming.apply_code_id renaming code_id in
       if code_id == code_id' then newer_version_of else Some code_id'
   in
-  let code_id' = Renaming.apply_code_id perm code_id in
-  let result_types' = Result_types.apply_renaming result_types perm in
+  let code_id' = Renaming.apply_code_id renaming code_id in
+  let result_types' = Result_types.apply_renaming result_types renaming in
   if code_id == code_id'
      && newer_version_of == newer_version_of'
      && result_types == result_types'

middle_end/flambda2/terms/code_metadata.ml

@@ -62,11 +62,11 @@ let free_names t =
 let apply_renaming t renaming =
   match t with
   | Code_present code ->
-    let code = Code.apply_renaming code renaming in
-    Code_present code
+    let code' = Code.apply_renaming code renaming in
+    if code == code' then t else Code_present code'
   | Metadata_only code_metadata ->
-    let code_metadata = Code_metadata.apply_renaming code_metadata renaming in
-    Metadata_only code_metadata
+    let code_metadata' = Code_metadata.apply_renaming code_metadata renaming in
+    if code_metadata == code_metadata' then t else Metadata_only code_metadata'
 
 let all_ids_for_export t =
   match t with

middle_end/flambda2/terms/code_or_metadata.ml

@@ -20,11 +20,11 @@ type t = int
 
 let zero = 0
 
-let equal a b = a = b
+let equal (a : t) (b : t) = a = b
 
 let ( + ) (a : t) (b : t) : t = a + b
 
-let ( <= ) a b = a <= b
+let ( <= ) (a : t) (b : t) = a <= b
 
 let arch32 = Targetint_32_64.size = 32 (* are we compiling for a 32-bit arch *)
 
@@ -65,7 +65,10 @@ let unary_int_prim_size kind op =
       (op : Flambda_primitive.unary_int_arith_op) )
   with
   | Tagged_immediate, Neg -> 1
-  | Tagged_immediate, Swap_byte_endianness -> 2 + nonalloc_extcall_size + 1
+  | Tagged_immediate, Swap_byte_endianness ->
+    (* CR pchambart: size depends a lot of the architecture. If the backend
+       handles it, this is a single arith op. *)
+    2 + nonalloc_extcall_size + 1
   | Naked_immediate, Neg -> 1
   | Naked_immediate, Swap_byte_endianness -> nonalloc_extcall_size + 1
   | Naked_int64, Neg when arch32 -> nonalloc_extcall_size + 1
@@ -140,18 +143,17 @@ let array_load (kind : Flambda_primitive.Array_kind.t) =
 
 let block_set (kind : Flambda_primitive.Block_access_kind.t)
     (init : Flambda_primitive.Init_or_assign.t) =
-  (* XXX these need checking for [Local_assignment] *)
   match kind, init with
-  | Values _, (Assignment _ | Initialization) -> 1 (* cadda + store *)
+  | Values _, Assignment Heap -> nonalloc_extcall_size (* caml_modify *)
+  | Values _, (Assignment Local | Initialization) -> 1 (* cadda + store *)
   | Naked_floats _, (Assignment _ | Initialization) -> 1
 
 let array_set (kind : Flambda_primitive.Array_kind.t)
-    (_init : Flambda_primitive.Init_or_assign.t) =
-  (* CR mshinwell: Check whether [init] should matter *)
-  match kind with
-  | Immediates -> 1 (* cadda + store *)
-  | Naked_floats -> 1
-  | Values -> 1
+    (init : Flambda_primitive.Init_or_assign.t) =
+  match kind, init with
+  | Values, Assignment Heap -> nonalloc_extcall_size
+  | Values, (Assignment Local | Initialization) -> 1
+  | (Immediates | Naked_floats), (Assignment _ | Initialization) -> 1
 
 let string_or_bigstring_load kind width =
   let start_address_load =
@@ -390,6 +392,7 @@ let prim (prim : Flambda_primitive.t) =
   | Variadic (p, args) -> variadic_prim_size p args
 
 let simple simple =
+  (* CR pchambart: some large const on ARM might be considered larger *)
   Simple.pattern_match simple ~const:(fun _ -> 1) ~name:(fun _ ~coercion:_ -> 0)
 
 let static_consts _ = 0

middle_end/flambda2/terms/code_size.ml

@@ -87,15 +87,24 @@ let free_names { exn_handler; extra_args } =
     (Name_occurrences.singleton_continuation exn_handler)
     (Simple.List.free_names extra_args)
 
-let apply_renaming ({ exn_handler; extra_args } as t) perm =
-  let exn_handler' = Renaming.apply_continuation perm exn_handler in
-  let extra_args' =
+let apply_renaming ({ exn_handler; extra_args } as t) renaming =
+  let exn_handler' = Renaming.apply_continuation renaming exn_handler in
+  let extra_args_changed = ref false in
+  let new_extra_args =
     List.map
       (fun ((simple, kind) as extra_arg) ->
-        let simple' = Simple.apply_renaming simple perm in
-        if simple == simple' then extra_arg else simple', kind)
+        let simple' = Simple.apply_renaming simple renaming in
+        if simple == simple'
+        then extra_arg
+        else begin
+          extra_args_changed := true;
+          simple', kind
+        end)
       extra_args
   in
+  let extra_args' =
+    if !extra_args_changed then new_extra_args else extra_args
+  in
   if exn_handler == exn_handler' && extra_args == extra_args'
   then t
   else { exn_handler = exn_handler'; extra_args = extra_args' }

middle_end/flambda2/terms/exn_continuation.ml

@@ -48,9 +48,21 @@ include Container_types.Make (struct
 
   let print ppf t =
     match t with
-    | Symbol symbol -> Symbol.print ppf symbol
-    | Tagged_immediate immediate -> Targetint_31_63.print ppf immediate
-    | Dynamically_computed (var, _dbg) -> Variable.print ppf var
+    | Symbol symbol ->
+      Format.fprintf ppf "%s%a%s"
+        (Flambda_colours.symbol ())
+        Symbol.print symbol
+        (Flambda_colours.normal ())
+    | Tagged_immediate immediate ->
+      Format.fprintf ppf "%s%a%s"
+        (Flambda_colours.tagged_immediate ())
+        Targetint_31_63.print immediate
+        (Flambda_colours.normal ())
+    | Dynamically_computed (var, _dbg) ->
+      Format.fprintf ppf "%s%a%s"
+        (Flambda_colours.variable ())
+        Variable.print var
+        (Flambda_colours.normal ())
 end)
 
 let apply_renaming t renaming =