Remove basic meet

.github/workflows/build.yml

@@ -58,14 +58,14 @@ jobs:
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 --enable-poll-insertion --enable-flambda-invariants
             os: ubuntu-latest
             build_ocamlparam: ''
-            ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200'
+            ocamlparam: '_,O3=1,flambda2-expert-cont-lifting-budget=200'
 
           - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_debug
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5
             os: ubuntu-latest
             build_ocamlparam: ''
             use_runtime: d
-            ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200'
+            ocamlparam: '_,O3=1,flambda2-expert-cont-lifting-budget=200'
 
           - name: flambda2_frame_pointers_oclassic_polling
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion --enable-flambda-invariants

driver/flambda_backend_args.ml

@@ -254,20 +254,12 @@ let mk_no_flambda2_result_types f =
 
 let mk_flambda2_basic_meet f =
   "-flambda2-basic-meet", Arg.Unit f,
-  Printf.sprintf " Use a basic meet algorithm%s (Flambda 2 only)"
-    (format_default (
-      match Flambda2.Default.meet_algorithm with
-      | Basic -> true
-      | Advanced -> false))
+  Printf.sprintf " Use a basic meet algorithm (deprecated) (Flambda 2 only)"
 ;;
 
 let mk_flambda2_advanced_meet f =
   "-flambda2-advanced-meet", Arg.Unit f,
-  Printf.sprintf " Use an advanced meet algorithm%s (Flambda 2 only)"
-    (format_default (
-      match Flambda2.Default.meet_algorithm with
-      | Basic -> false
-      | Advanced -> true))
+  Printf.sprintf " Use an advanced meet algorithm (deprecated) (Flambda 2 only)"
 ;;
 
 
@@ -1115,10 +1107,8 @@ module Flambda_backend_options_impl = struct
     Flambda2.function_result_types := Flambda_backend_flags.Set Flambda_backend_flags.All_functions
   let no_flambda2_result_types () =
     Flambda2.function_result_types := Flambda_backend_flags.Set Flambda_backend_flags.Never
-  let flambda2_basic_meet () =
-    Flambda2.meet_algorithm := Flambda_backend_flags.Set Flambda_backend_flags.Basic
-  let flambda2_advanced_meet () =
-    Flambda2.meet_algorithm := Flambda_backend_flags.Set Flambda_backend_flags.Advanced
+  let flambda2_basic_meet () = ()
+  let flambda2_advanced_meet () = ()
   let flambda2_unbox_along_intra_function_control_flow =
     set Flambda2.unbox_along_intra_function_control_flow
   let no_flambda2_unbox_along_intra_function_control_flow =
@@ -1444,10 +1434,7 @@ module Extra_params = struct
       true
     | "flambda2-meet-algorithm" ->
       (match String.lowercase_ascii v with
-      | "basic" ->
-        Flambda2.meet_algorithm := Flambda_backend_flags.(Set Basic)
-      | "advanced" ->
-        Flambda2.meet_algorithm := Flambda_backend_flags.(Set Advanced)
+      | "basic" | "advanced" -> ()
       | _ ->
         Misc.fatal_error "Syntax: flambda2-meet_algorithm=basic|advanced");
       true
@@ -1472,7 +1459,6 @@ module Extra_params = struct
     | "flambda2-expert-cont-lifting-budget" ->
       begin match Compenv.check_int ppf name v with
       | Some i ->
-         if i <> 0 then Flambda2.meet_algorithm := Flambda_backend_flags.(Set Advanced);
          Flambda2.Expert.cont_lifting_budget := Flambda_backend_flags.Set i
       | None -> ()
       end;

driver/flambda_backend_flags.ml

@@ -94,7 +94,6 @@ let long_frames_threshold = ref max_long_frames_threshold (* -debug-long-frames-
 let caml_apply_inline_fast_path = ref false  (* -caml-apply-inline-fast-path *)
 
 type function_result_types = Never | Functors_only | All_functions
-type meet_algorithm = Basic | Advanced
 type opt_level = Oclassic | O2 | O3
 type 'a or_default = Set of 'a | Default
 
@@ -128,7 +127,6 @@ module Flambda2 = struct
     let cse_depth = 2
     let join_depth = 5
     let function_result_types = Never
-    let meet_algorithm = Basic
     let enable_reaper = false
     let unicode = true
     let kind_checks = false
@@ -142,7 +140,6 @@ module Flambda2 = struct
     cse_depth : int;
     join_depth : int;
     function_result_types : function_result_types;
-    meet_algorithm : meet_algorithm;
     enable_reaper : bool;
     unicode : bool;
     kind_checks : bool;
@@ -156,7 +153,6 @@ module Flambda2 = struct
     cse_depth = Default.cse_depth;
     join_depth = Default.join_depth;
     function_result_types = Default.function_result_types;
-    meet_algorithm = Default.meet_algorithm;
     enable_reaper = Default.enable_reaper;
     unicode = Default.unicode;
     kind_checks = Default.kind_checks;
@@ -192,7 +188,6 @@ module Flambda2 = struct
   let unicode = ref Default
   let kind_checks = ref Default
   let function_result_types = ref Default
-  let meet_algorithm = ref Default
   let enable_reaper = ref Default
 
   module Dump = struct

driver/flambda_backend_flags.mli

@@ -81,7 +81,6 @@ val long_frames_threshold : int ref
 val caml_apply_inline_fast_path : bool ref
 
 type function_result_types = Never | Functors_only | All_functions
-type meet_algorithm = Basic | Advanced
 type opt_level = Oclassic | O2 | O3
 type 'a or_default = Set of 'a | Default
 
@@ -109,7 +108,6 @@ module Flambda2 : sig
     val cse_depth : int
     val join_depth : int
     val function_result_types : function_result_types
-    val meet_algorithm : meet_algorithm
     val enable_reaper : bool
     val unicode : bool
     val kind_checks : bool
@@ -126,7 +124,6 @@ module Flambda2 : sig
     cse_depth : int;
     join_depth : int;
     function_result_types : function_result_types;
-    meet_algorithm : meet_algorithm;
     enable_reaper : bool;
     unicode : bool;
     kind_checks : bool;
@@ -135,7 +132,6 @@ module Flambda2 : sig
   val default_for_opt_level : opt_level or_default -> flags
 
   val function_result_types : function_result_types or_default ref
-  val meet_algorithm : meet_algorithm or_default ref
 
   val classic_mode : bool or_default ref
   val join_points : bool or_default ref

middle_end/flambda2/tests/api_tests/extension_meet.ml

@@ -189,5 +189,4 @@ let _ =
     Compilation_unit.create Compilation_unit.Prefix.empty linkage_name
   in
   Compilation_unit.set_current (Some comp_unit);
-  Flambda_backend_flags.(Flambda2.meet_algorithm := Set Advanced);
   test_double_recursion ()

middle_end/flambda2/tests/meet_test.ml

@@ -269,8 +269,6 @@ let () =
   meet_variants_don't_lose_aliases ();
   Format.eprintf "@.MEET TWO BLOCKS@\n@.";
   test_meet_two_blocks ();
-  (* The following tests require the advanced meet. *)
-  Flambda_backend_flags.(Flambda2.meet_algorithm := Set Advanced);
   Format.eprintf "@.MEET ALIAS TO RECOVER @\n@.";
   test_meet_recover_alias ();
   Format.eprintf "@.MEET BOTTOM AFTER ALIAS@\n@.";

middle_end/flambda2/types/env/typing_env.ml

@@ -271,15 +271,7 @@ type 'a meet_return_value =
   | Both_inputs
   | New_result of 'a
 
-type meet_type_new =
-  t -> TG.t -> TG.t -> (TG.t meet_return_value * t) Or_bottom.t
-
-type meet_type_old =
-  Meet_env.t -> TG.t -> TG.t -> (TG.t * Typing_env_extension.t) Or_bottom.t
-
-type meet_type =
-  | New of meet_type_new
-  | Old of meet_type_old
+type meet_type = t -> TG.t -> TG.t -> (TG.t meet_return_value * t) Or_bottom.t
 
 module Join_env : sig
   type t
@@ -840,7 +832,7 @@ and replace_equation_or_add_alias_to_const t name ty =
     | Bottom ->
       Misc.fatal_error "Unexpected bottom while adding alias to constant.")
 
-and add_non_alias_equation ~original_name ~raise_on_bottom t lhs_simple rhs_ty
+and add_non_alias_equation ~raise_on_bottom t lhs_simple rhs_ty
     ~(meet_type : meet_type) =
   (* We are about to add a non-alias type on a canonical *simple*. This type
      might have been provided by the caller of [add_equation], or it might come
@@ -860,59 +852,30 @@ and add_non_alias_equation ~original_name ~raise_on_bottom t lhs_simple rhs_ty
      no type to record for [c], however we still need to check that [c] is
      compatible with the previous type of [p].
 
-     Note that, when using the old meet, we only call [meet] if the canonical
-     name after orienting the equation is different from the original name given
-     by the caller. In the situation where the names are the same, we assume
-     that the caller already took care of only giving a type that is more
-     precise than the existing one.
-
      Note also that [p] and [x] may have different name modes! *)
   let[@inline always] name eqn_name ty =
-    match meet_type with
-    | New meet_type_new -> (
-      let existing_ty = find t eqn_name (Some (TG.kind ty)) in
-      match meet_type_new t ty existing_ty with
-      | Bottom ->
-        if raise_on_bottom
-        then raise Bottom_equation
-        else replace_equation t eqn_name (MTC.bottom (TG.kind ty))
-      | Ok (meet_ty, env) -> (
-        match meet_ty with
-        | Left_input -> replace_equation_or_add_alias_to_const env eqn_name ty
-        | Right_input | Both_inputs -> env
-        | New_result ty' ->
-          replace_equation_or_add_alias_to_const env eqn_name ty'))
-    | Old meet_type_old -> (
-      if Name.equal original_name eqn_name
-      then replace_equation_or_add_alias_to_const t eqn_name ty
-      else
-        let env = Meet_env.create t in
-        let existing_ty = find t eqn_name (Some (TG.kind ty)) in
-        match meet_type_old env ty existing_ty with
-        | Bottom -> replace_equation t eqn_name (MTC.bottom (TG.kind ty))
-        | Ok (meet_ty, env_extension) ->
-          let t =
-            add_env_extension ~raise_on_bottom t env_extension ~meet_type
-          in
-          replace_equation_or_add_alias_to_const t eqn_name meet_ty)
+    let existing_ty = find t eqn_name (Some (TG.kind ty)) in
+    match meet_type t ty existing_ty with
+    | Bottom ->
+      if raise_on_bottom
+      then raise Bottom_equation
+      else replace_equation t eqn_name (MTC.bottom (TG.kind ty))
+    | Ok (meet_ty, env) -> (
+      match meet_ty with
+      | Left_input -> replace_equation_or_add_alias_to_const env eqn_name ty
+      | Right_input | Both_inputs -> env
+      | New_result ty' ->
+        replace_equation_or_add_alias_to_const env eqn_name ty')
   in
   let[@inline always] const const ty =
     (* If we are applying an alias-to-constant type to a name, the constant
        becomes canonical and we need to apply the type to the constant instead.
        This merely reduces to checking that the type is compatible (e.g. if we
        are adding [x : (= 0)] in a context where [x : { 1, 2 }] holds). *)
     let existing_ty = MTC.type_for_const const in
-    match meet_type with
-    | New meet_type_new -> (
-      match meet_type_new t ty existing_ty with
-      | Bottom -> if raise_on_bottom then raise Bottom_equation else t
-      | Ok (_, env) -> env)
-    | Old meet_type_old -> (
-      let env = Meet_env.create t in
-      match meet_type_old env ty existing_ty with
-      | Bottom -> t
-      | Ok (_, env_extension) ->
-        add_env_extension ~raise_on_bottom t env_extension ~meet_type)
+    match meet_type t ty existing_ty with
+    | Bottom -> if raise_on_bottom then raise Bottom_equation else t
+    | Ok (_, env) -> env
   in
   pattern_match_equation lhs_simple rhs_ty ~name ~const
 
@@ -1002,8 +965,7 @@ and orient_and_add_equation ~raise_on_bottom t name ty ~meet_type =
   match inputs with
   | None -> t
   | Some (simple, t, ty) ->
-    add_non_alias_equation ~original_name:name ~raise_on_bottom t simple ty
-      ~meet_type
+    add_non_alias_equation ~raise_on_bottom t simple ty ~meet_type
 
 and[@inline always] add_equation ~raise_on_bottom t name ty ~meet_type =
   match orient_and_add_equation ~raise_on_bottom t name ty ~meet_type with

middle_end/flambda2/types/env/typing_env.mli

@@ -101,22 +101,12 @@ type 'a meet_return_value =
   | Both_inputs
   | New_result of 'a
 
-type meet_type_new =
+type meet_type =
   t ->
   Type_grammar.t ->
   Type_grammar.t ->
   (Type_grammar.t meet_return_value * t) Or_bottom.t
 
-type meet_type_old =
-  Meet_env.t ->
-  Type_grammar.t ->
-  Type_grammar.t ->
-  (Type_grammar.t * Typing_env_extension.t) Or_bottom.t
-
-type meet_type =
-  | New of meet_type_new
-  | Old of meet_type_old
-
 val print : Format.formatter -> t -> unit
 
 val create :

middle_end/flambda2/types/flambda2_types.ml

@@ -18,18 +18,18 @@ module Typing_env = struct
   include Typing_env
 
   let add_equation t name ty =
-    add_equation t name ty ~meet_type:(Meet_and_join.meet_type ())
+    add_equation t name ty ~meet_type:Meet_and_join.meet_type
 
   let add_equations_on_params t ~params ~param_types =
     add_equations_on_params t ~params ~param_types
-      ~meet_type:(Meet_and_join.meet_type ())
+      ~meet_type:Meet_and_join.meet_type
 
   let add_env_extension t extension =
-    add_env_extension t extension ~meet_type:(Meet_and_join.meet_type ())
+    add_env_extension t extension ~meet_type:Meet_and_join.meet_type
 
   let add_env_extension_with_extra_variables t extension =
     add_env_extension_with_extra_variables t extension
-      ~meet_type:(Meet_and_join.meet_type ())
+      ~meet_type:Meet_and_join.meet_type
 
   module Alias_set = Aliases.Alias_set
 end
@@ -49,11 +49,5 @@ include Reify
 include Join_levels
 module Code_age_relation = Code_age_relation
 
-let join ?bound_name central_env ~left_env ~left_ty ~right_env ~right_ty =
-  let join_env = Typing_env.Join_env.create central_env ~left_env ~right_env in
-  match (join ()) ?bound_name join_env left_ty right_ty with
-  | Unknown -> unknown_like left_ty
-  | Known ty -> ty
-
 let remove_outermost_alias env ty =
   Expand_head.expand_head env ty |> Expand_head.Expanded_type.to_type

middle_end/flambda2/types/flambda2_types.mli

@@ -249,15 +249,6 @@ val meet : Typing_env.t -> t -> t -> (t * Typing_env.t) Or_bottom.t
 
 val meet_shape : Typing_env.t -> t -> shape:t -> Typing_env.t Or_bottom.t
 
-val join :
-  ?bound_name:Name.t ->
-  Typing_env.t ->
-  left_env:Typing_env.t ->
-  left_ty:t ->
-  right_env:Typing_env.t ->
-  right_ty:t ->
-  t
-
 val cut_and_n_way_join :
   Typing_env.t ->
   (Typing_env.t * Apply_cont_rewrite_id.t * Continuation_use_kind.t) list ->

middle_end/flambda2/types/join_levels.ml

@@ -86,7 +86,7 @@ let join_types ~env_at_fork envs_with_levels =
            could do better. *)
         TE.add_env_extension_maybe_bottom base_env
           (TEE.from_map joined_types)
-          ~meet_type:(Meet_and_join.meet_type ())
+          ~meet_type:Meet_and_join.meet_type
       in
       let join_types name joined_ty use_ty =
         let same_unit =
@@ -143,7 +143,7 @@ let join_types ~env_at_fork envs_with_levels =
             Join_env.create base_env ~left_env ~right_env:env_at_use
           in
           match
-            (Meet_and_join.join ()) ~bound_name:name join_env joined_ty use_ty
+            Meet_and_join.join ~bound_name:name join_env joined_ty use_ty
           with
           | Known joined_ty -> Some joined_ty
           | Unknown -> None
@@ -332,7 +332,7 @@ let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
   in
   let result_env =
     TE.add_env_extension_from_level definition_typing_env level
-      ~meet_type:(Meet_and_join.meet_type ())
+      ~meet_type:Meet_and_join.meet_type
   in
   TE.compute_joined_aliases result_env alias_candidates
     (List.map (fun (env_at_use, _, _, _) -> env_at_use) after_cuts)