diff --git a/.depend b/.depend index 00ff4e745702..fa5f8a223a3b 100644 --- a/.depend +++ b/.depend @@ -2028,11 +2028,9 @@ asmcomp/afl_instrument.cmi : \ asmcomp/cmm.cmi asmcomp/arch.cmo : \ utils/config.cmi \ - asmcomp/cmm.cmi \ utils/clflags.cmi asmcomp/arch.cmx : \ utils/config.cmx \ - asmcomp/cmm.cmx \ utils/clflags.cmx asmcomp/asmgen.cmo : \ middle_end/flambda/to_cmm/un_cps.cmi \ @@ -4424,17 +4422,20 @@ middle_end/flambda/basic/name.cmo : \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/compilenv_deps/reg_width_things.cmi \ utils/misc.cmi \ + utils/identifiable.cmi \ middle_end/flambda/basic/name.cmi middle_end/flambda/basic/name.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/compilenv_deps/reg_width_things.cmx \ utils/misc.cmx \ + utils/identifiable.cmx \ middle_end/flambda/basic/name.cmi middle_end/flambda/basic/name.cmi : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/compilenv_deps/reg_width_things.cmi \ + utils/identifiable.cmi \ middle_end/flambda/compilenv_deps/compilation_unit.cmi middle_end/flambda/basic/num_continuation_uses.cmo : \ middle_end/flambda/basic/num_continuation_uses.cmi @@ -4974,11 +4975,13 @@ middle_end/flambda/from_lambda/closure_conversion_aux.cmi : \ middle_end/flambda/basic/closure_id.cmi \ middle_end/flambda/naming/bindable_let_bound.cmi middle_end/flambda/from_lambda/cps_conversion.cmo : \ + lambda/tag.cmi \ lambda/printlambda.cmi \ - middle_end/flambda/from_lambda/prepare_lambda.cmi \ + typing/primitive.cmi \ utils/numbers.cmi \ utils/misc.cmi \ parsing/location.cmi \ + middle_end/flambda/from_lambda/lambda_conversions.cmi \ lambda/lambda.cmi \ middle_end/flambda/from_lambda/ilambda.cmi \ typing/ident.cmi \ @@ -4986,11 +4989,13 @@ middle_end/flambda/from_lambda/cps_conversion.cmo : \ parsing/asttypes.cmi \ middle_end/flambda/from_lambda/cps_conversion.cmi middle_end/flambda/from_lambda/cps_conversion.cmx : \ + lambda/tag.cmx \ lambda/printlambda.cmx \ - middle_end/flambda/from_lambda/prepare_lambda.cmx \ + typing/primitive.cmx \ utils/numbers.cmx \ utils/misc.cmx \ parsing/location.cmx \ + middle_end/flambda/from_lambda/lambda_conversions.cmx \ lambda/lambda.cmx \ middle_end/flambda/from_lambda/ilambda.cmx \ typing/ident.cmx \ @@ -5188,11 +5193,9 @@ middle_end/flambda/from_lambda/prepare_lambda.cmo : \ lambda/tag.cmi \ lambda/simplif.cmi \ lambda/printlambda.cmi \ - typing/primitive.cmi \ utils/numbers.cmi \ utils/misc.cmi \ lambda/matching.cmi \ - middle_end/flambda/from_lambda/lambda_conversions.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ middle_end/flambda/compilenv_deps/compilation_unit.cmi \ @@ -5202,11 +5205,9 @@ middle_end/flambda/from_lambda/prepare_lambda.cmx : \ lambda/tag.cmx \ lambda/simplif.cmx \ lambda/printlambda.cmx \ - typing/primitive.cmx \ utils/numbers.cmx \ utils/misc.cmx \ lambda/matching.cmx \ - middle_end/flambda/from_lambda/lambda_conversions.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ middle_end/flambda/compilenv_deps/compilation_unit.cmx \ @@ -6067,6 +6068,7 @@ middle_end/flambda/simplify/common_subexpression_elimination.cmo : \ middle_end/flambda/compilenv_deps/flambda_features.cmi \ middle_end/flambda/basic/continuation_extra_params_and_args.cmi \ middle_end/flambda/basic/apply_cont_rewrite_id.cmi \ + middle_end/flambda/types/env/aliases.cmi \ middle_end/flambda/simplify/common_subexpression_elimination.cmi middle_end/flambda/simplify/common_subexpression_elimination.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ @@ -6084,6 +6086,7 @@ middle_end/flambda/simplify/common_subexpression_elimination.cmx : \ middle_end/flambda/compilenv_deps/flambda_features.cmx \ middle_end/flambda/basic/continuation_extra_params_and_args.cmx \ middle_end/flambda/basic/apply_cont_rewrite_id.cmx \ + middle_end/flambda/types/env/aliases.cmx \ middle_end/flambda/simplify/common_subexpression_elimination.cmi middle_end/flambda/simplify/common_subexpression_elimination.cmi : \ middle_end/flambda/basic/simple.cmi \ @@ -6629,6 +6632,7 @@ middle_end/flambda/simplify/simplify_import.cmo : \ middle_end/flambda/simplify/env/upwards_env.cmi \ middle_end/flambda/simplify/env/upwards_acc.cmi \ middle_end/flambda/simplify/simplify_simple.cmi \ + middle_end/flambda/basic/reg_width_const.cmi \ middle_end/flambda/simplify/rebuilt_expr.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/lifting/lifted_constant_state.cmi \ @@ -6652,6 +6656,7 @@ middle_end/flambda/simplify/simplify_import.cmx : \ middle_end/flambda/simplify/env/upwards_env.cmx \ middle_end/flambda/simplify/env/upwards_acc.cmx \ middle_end/flambda/simplify/simplify_simple.cmx \ + middle_end/flambda/basic/reg_width_const.cmx \ middle_end/flambda/simplify/rebuilt_expr.cmx \ middle_end/flambda/naming/name_mode.cmx \ middle_end/flambda/lifting/lifted_constant_state.cmx \ @@ -6675,6 +6680,7 @@ middle_end/flambda/simplify/simplify_import.cmi : \ middle_end/flambda/simplify/env/upwards_env.cmi \ middle_end/flambda/simplify/env/upwards_acc.cmi \ middle_end/flambda/simplify/simplify_simple.cmi \ + middle_end/flambda/basic/reg_width_const.cmi \ middle_end/flambda/simplify/rebuilt_expr.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/lifting/lifted_constant_state.cmi \ @@ -9205,7 +9211,8 @@ middle_end/flambda/types/flambda_type.cmi : \ middle_end/flambda/basic/code_id.cmi \ middle_end/flambda/types/structures/code_age_relation.cmi \ middle_end/flambda/basic/closure_id.cmi \ - middle_end/flambda/basic/apply_cont_rewrite_id.cmi + middle_end/flambda/basic/apply_cont_rewrite_id.cmi \ + middle_end/flambda/types/env/aliases.cmi middle_end/flambda/types/resolved_type.rec.cmo : \ middle_end/flambda/basic/reg_width_const.cmi \ middle_end/flambda/types/basic/or_unknown_or_bottom.cmi \ @@ -9233,6 +9240,7 @@ middle_end/flambda/types/type_descr.rec.cmo : \ middle_end/flambda/cmx/ids_for_export.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ utils/clflags.cmi \ + middle_end/flambda/types/env/aliases.cmi \ middle_end/flambda/types/type_descr.rec.cmi middle_end/flambda/types/type_descr.rec.cmx : \ middle_end/flambda/naming/with_delayed_permutation.cmx \ @@ -9250,6 +9258,7 @@ middle_end/flambda/types/type_descr.rec.cmx : \ middle_end/flambda/cmx/ids_for_export.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ utils/clflags.cmx \ + middle_end/flambda/types/env/aliases.cmx \ middle_end/flambda/types/type_descr.rec.cmi middle_end/flambda/types/type_descr.rec.cmi : \ middle_end/flambda/types/type_head_intf.cmo \ @@ -9517,10 +9526,12 @@ middle_end/flambda/types/env/aliases.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/naming/renaming.cmi \ + middle_end/flambda/compilenv_deps/reg_width_things.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/basic/name.cmi \ utils/misc.cmi \ middle_end/flambda/cmx/ids_for_export.cmi \ + middle_end/flambda/compilenv_deps/flambda_colours.cmi \ utils/clflags.cmi \ middle_end/flambda/types/env/binding_time.cmi \ middle_end/flambda/types/env/aliases.cmi @@ -9528,10 +9539,12 @@ middle_end/flambda/types/env/aliases.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/naming/renaming.cmx \ + middle_end/flambda/compilenv_deps/reg_width_things.cmx \ middle_end/flambda/naming/name_mode.cmx \ middle_end/flambda/basic/name.cmx \ utils/misc.cmx \ middle_end/flambda/cmx/ids_for_export.cmx \ + middle_end/flambda/compilenv_deps/flambda_colours.cmx \ utils/clflags.cmx \ middle_end/flambda/types/env/binding_time.cmx \ middle_end/flambda/types/env/aliases.cmi @@ -9567,10 +9580,12 @@ middle_end/flambda/types/env/join_env.rec.cmi : \ middle_end/flambda/basic/simple.cmi middle_end/flambda/types/env/meet_env.rec.cmo : \ middle_end/flambda/basic/simple.cmi \ + middle_end/flambda/basic/name.cmi \ utils/misc.cmi \ middle_end/flambda/types/env/meet_env.rec.cmi middle_end/flambda/types/env/meet_env.rec.cmx : \ middle_end/flambda/basic/simple.cmx \ + middle_end/flambda/basic/name.cmx \ utils/misc.cmx \ middle_end/flambda/types/env/meet_env.rec.cmi middle_end/flambda/types/env/meet_env.rec.cmi : \ @@ -9639,7 +9654,8 @@ middle_end/flambda/types/env/typing_env.rec.cmi : \ middle_end/flambda/compilenv_deps/compilation_unit.cmi \ middle_end/flambda/basic/code_id.cmi \ middle_end/flambda/types/structures/code_age_relation.cmi \ - middle_end/flambda/basic/apply_cont_rewrite_id.cmi + middle_end/flambda/basic/apply_cont_rewrite_id.cmi \ + middle_end/flambda/types/env/aliases.cmi middle_end/flambda/types/env/typing_env_extension.rec.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/renaming.cmi \ @@ -10154,25 +10170,21 @@ middle_end/flambda/types/type_of_kind/boilerplate/type_of_kind_value.rec.cmi : \ middle_end/flambda/types/type_descr_intf.cmo middle_end/flambda/unboxing/build_unboxing_denv.cmo : \ middle_end/flambda/basic/var_within_closure.cmi \ - middle_end/flambda/naming/var_in_binding_pos.cmi \ middle_end/flambda/unboxing/unboxing_types.cmi \ lambda/tag.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/naming/name_mode.cmi \ utils/misc.cmi \ - middle_end/flambda/types/flambda_type.cmi \ middle_end/flambda/unboxing/build_unboxing_denv.cmi middle_end/flambda/unboxing/build_unboxing_denv.cmx : \ middle_end/flambda/basic/var_within_closure.cmx \ - middle_end/flambda/naming/var_in_binding_pos.cmx \ middle_end/flambda/unboxing/unboxing_types.cmx \ lambda/tag.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/naming/name_mode.cmx \ utils/misc.cmx \ - middle_end/flambda/types/flambda_type.cmx \ middle_end/flambda/unboxing/build_unboxing_denv.cmi middle_end/flambda/unboxing/build_unboxing_denv.cmi : \ middle_end/flambda/compilenv_deps/variable.cmi \ @@ -10207,7 +10219,6 @@ middle_end/flambda/unboxing/optimistic_unboxing_decision.cmo : \ middle_end/flambda/naming/name_in_binding_pos.cmi \ middle_end/flambda/basic/name.cmi \ utils/misc.cmi \ - middle_end/flambda/types/flambda_type.cmi \ middle_end/flambda/unboxing/optimistic_unboxing_decision.cmi middle_end/flambda/unboxing/optimistic_unboxing_decision.cmx : \ middle_end/flambda/basic/var_within_closure.cmx \ @@ -10222,7 +10233,6 @@ middle_end/flambda/unboxing/optimistic_unboxing_decision.cmx : \ middle_end/flambda/naming/name_in_binding_pos.cmx \ middle_end/flambda/basic/name.cmx \ utils/misc.cmx \ - middle_end/flambda/types/flambda_type.cmx \ middle_end/flambda/unboxing/optimistic_unboxing_decision.cmi middle_end/flambda/unboxing/optimistic_unboxing_decision.cmi : \ middle_end/flambda/unboxing/unboxing_types.cmi \ @@ -10256,7 +10266,6 @@ middle_end/flambda/unboxing/unbox_continuation_params.cmi : \ middle_end/flambda/simplify/env/continuation_env_and_param_types.cmi \ middle_end/flambda/basic/apply_cont_rewrite_id.cmi middle_end/flambda/unboxing/unboxers.cmo : \ - middle_end/flambda/unboxing/unboxing_types.cmi \ utils/targetint.cmi \ middle_end/flambda/compilenv_deps/target_imm.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ @@ -10265,7 +10274,6 @@ middle_end/flambda/unboxing/unboxers.cmo : \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/unboxing/unboxers.cmi middle_end/flambda/unboxing/unboxers.cmx : \ - middle_end/flambda/unboxing/unboxing_types.cmx \ utils/targetint.cmx \ middle_end/flambda/compilenv_deps/target_imm.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ @@ -10275,7 +10283,6 @@ middle_end/flambda/unboxing/unboxers.cmx : \ middle_end/flambda/unboxing/unboxers.cmi middle_end/flambda/unboxing/unboxers.cmi : \ middle_end/flambda/basic/var_within_closure.cmi \ - middle_end/flambda/unboxing/unboxing_types.cmi \ middle_end/flambda/compilenv_deps/target_imm.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ @@ -10325,7 +10332,6 @@ middle_end/flambda/unboxing/unboxing_types.cmo : \ middle_end/flambda/basic/var_within_closure.cmi \ lambda/tag.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ - middle_end/flambda/compilenv_deps/reg_width_things.cmi \ middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/basic/closure_id.cmi \ middle_end/flambda/basic/apply_cont_rewrite_id.cmi \ @@ -10335,7 +10341,6 @@ middle_end/flambda/unboxing/unboxing_types.cmx : \ middle_end/flambda/basic/var_within_closure.cmx \ lambda/tag.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ - middle_end/flambda/compilenv_deps/reg_width_things.cmx \ middle_end/flambda/types/kinds/flambda_kind.cmx \ middle_end/flambda/basic/closure_id.cmx \ middle_end/flambda/basic/apply_cont_rewrite_id.cmx \ @@ -10345,7 +10350,6 @@ middle_end/flambda/unboxing/unboxing_types.cmi : \ middle_end/flambda/basic/var_within_closure.cmi \ lambda/tag.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ - middle_end/flambda/compilenv_deps/reg_width_things.cmi \ middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/basic/closure_id.cmi \ middle_end/flambda/basic/apply_cont_rewrite_id.cmi diff --git a/middle_end/flambda/basic/kinded_parameter.ml b/middle_end/flambda/basic/kinded_parameter.ml index adf17eb9d340..f7ceeec23810 100644 --- a/middle_end/flambda/basic/kinded_parameter.ml +++ b/middle_end/flambda/basic/kinded_parameter.ml @@ -111,8 +111,6 @@ module List = struct let name_set t = Name.Set.of_list (List.map Name.var (vars t)) - let simple_set t = Simple.Set.of_list (simples t) - let rename t = List.map (fun t -> rename t) t let arity t = List.map (fun t -> Flambda_kind.With_subkind.kind (kind t)) t diff --git a/middle_end/flambda/basic/kinded_parameter.mli b/middle_end/flambda/basic/kinded_parameter.mli index 53c4f20e4d09..bc2a5533e0de 100644 --- a/middle_end/flambda/basic/kinded_parameter.mli +++ b/middle_end/flambda/basic/kinded_parameter.mli @@ -68,8 +68,6 @@ module List : sig (** As for [var_set] but returns a set of [Name]s. *) val name_set : t -> Name.Set.t - val simple_set : t -> Simple.Set.t - val equal_vars : t -> Variable.t list -> bool val rename : t -> t diff --git a/middle_end/flambda/basic/name.ml b/middle_end/flambda/basic/name.ml index 349b0c0e875e..73631dcee13a 100644 --- a/middle_end/flambda/basic/name.ml +++ b/middle_end/flambda/basic/name.ml @@ -104,3 +104,11 @@ let must_be_symbol_opt t = pattern_match t ~var:(fun _ -> None) ~symbol:(fun sym -> Some sym) + +module Pair = struct + include Identifiable.Make_pair + (Reg_width_things.Name) + (Reg_width_things.Name) + + type nonrec t = t * t +end diff --git a/middle_end/flambda/basic/name.mli b/middle_end/flambda/basic/name.mli index 2975d1f41d9c..3a1066112fd7 100644 --- a/middle_end/flambda/basic/name.mli +++ b/middle_end/flambda/basic/name.mli @@ -55,3 +55,10 @@ val must_be_var_opt : t -> Variable.t option val must_be_symbol_opt : t -> Symbol.t option val rename : t -> t + +module Pair : sig + type nonrec t = t * t + + include Identifiable.S with type t := t +end + diff --git a/middle_end/flambda/basic/simple.ml b/middle_end/flambda/basic/simple.ml index 72cf656c7673..87a2d08ef23b 100644 --- a/middle_end/flambda/basic/simple.ml +++ b/middle_end/flambda/basic/simple.ml @@ -158,14 +158,6 @@ module List = struct else result end -module Pair = struct - include Identifiable.Make_pair - (Reg_width_things.Simple) - (Reg_width_things.Simple) - - type nonrec t = t * t -end - module With_kind = struct type nonrec t = t * Flambda_kind.t diff --git a/middle_end/flambda/basic/simple.mli b/middle_end/flambda/basic/simple.mli index 13cf022f211d..2c353d341acf 100644 --- a/middle_end/flambda/basic/simple.mli +++ b/middle_end/flambda/basic/simple.mli @@ -94,12 +94,6 @@ module List : sig include Identifiable.S with type t := t end -module Pair : sig - type nonrec t = t * t - - include Identifiable.S with type t := t -end - module With_kind : sig type nonrec t = t * Flambda_kind.t diff --git a/middle_end/flambda/cmx/flambda_cmx_format.ml b/middle_end/flambda/cmx/flambda_cmx_format.ml index 0c70ff5a4e5b..901f51b1257f 100644 --- a/middle_end/flambda/cmx/flambda_cmx_format.ml +++ b/middle_end/flambda/cmx/flambda_cmx_format.ml @@ -62,7 +62,7 @@ let create ~final_typing_env ~all_code ~exported_offsets ~used_closure_vars = Variable.Map.empty in let simples = - Simple.Set.fold (fun simple simples -> + Reg_width_things.Simple.Set.fold (fun simple simples -> Simple.Map.add simple (Simple.export simple) simples) exported_ids.simples Simple.Map.empty diff --git a/middle_end/flambda/compare/compare.ml b/middle_end/flambda/compare/compare.ml index f80d9b7314dd..e011999175d2 100644 --- a/middle_end/flambda/compare/compare.ml +++ b/middle_end/flambda/compare/compare.ml @@ -766,6 +766,35 @@ let function_decls env decl1 decl2 : unit Comparison.t = else Different { approximant = () } ;; +(** Match up equal elements in two lists and iterate through both of them, + using [f] analogously to [Map.S.merge] *) +let iter2_merged l1 l2 ~compare ~f = + let l1 = List.sort compare l1 in + let l2 = List.sort compare l2 in + let rec go l1 l2 = + match l1, l2 with + | [], [] -> () + | a1 :: l1, [] -> + f (Some a1) None; + go l1 [] + | [], a2 :: l2 -> + f None (Some a2); + go [] l2 + | a1 :: l1, a2 :: l2 -> + begin match compare a1 a2 with + | 0 -> + f (Some a1) (Some a2); + go l1 l2 + | c when c < 0 -> + f (Some a1) None; + go l1 (a2 :: l2) + | _ -> + f None (Some a2); + go (a1 :: l1) l2 + end + in + go l1 l2 + let sets_of_closures env set1 set2 : Set_of_closures.t Comparison.t = (* Need to do unification on closure vars and closure ids, we we're going to * invert both maps, figuring the closure vars with the same value should be @@ -777,28 +806,28 @@ let sets_of_closures env set1 set2 : Set_of_closures.t Comparison.t = |> List.map (fun (var, value) -> subst_simple env value, var ) - |> Simple.Map.of_list in (* We want to process the whole map to find new correspondences between * closure vars, so we need to remember whether we've found any mismatches *) let ok = ref true in - (* Using merge here as a map version of [List.iter2]; always returning None - * means the returned map is always empty, so this shouldn't waste much *) - let _ : unit Simple.Map.t = - Simple.Map.merge (fun _value var1 var2 -> - begin - match var1, var2 with - | None, None -> () - | Some _, None | None, Some _ -> ok := false - | Some var1, Some var2 -> - begin - match closure_vars env var1 var2 with - | Equivalent -> () - | Different { approximant = _ } -> ok := false - end - end; - None - ) (closure_vars_by_value set1) (closure_vars_by_value set2) + let () = + let compare (value1, _var1) (value2, _var2) = + Simple.compare value1 value2 + in + iter2_merged (closure_vars_by_value set1) (closure_vars_by_value set2) + ~compare + ~f:(fun elt1 elt2 -> + begin + match elt1, elt2 with + | None, None -> () + | Some _, None | None, Some _ -> ok := false + | Some (_value1, var1), Some (_value2, var2) -> + begin + match closure_vars env var1 var2 with + | Equivalent -> () + | Different { approximant = _ } -> ok := false + end + end) in let closure_ids_and_fun_decls_by_code_id set = let map = Function_declarations.funs (Set_of_closures.function_decls set) in @@ -809,6 +838,8 @@ let sets_of_closures env set1 set2 : Set_of_closures.t Comparison.t = ) |> Code_id.Map.of_list in + (* Using merge here as a map version of [List.iter2]; always returning None + * means the returned map is always empty, so this shouldn't waste much *) let _ : unit Code_id.Map.t = Code_id.Map.merge (fun _code_id value1 value2 -> begin diff --git a/middle_end/flambda/simplify/common_subexpression_elimination.ml b/middle_end/flambda/simplify/common_subexpression_elimination.ml index ae91a05d45cb..4c435c2d7437 100644 --- a/middle_end/flambda/simplify/common_subexpression_elimination.ml +++ b/middle_end/flambda/simplify/common_subexpression_elimination.ml @@ -117,7 +117,12 @@ end let cse_with_eligible_lhs ~typing_env_at_fork ~cse_at_each_use ~params prev_cse (extra_bindings: EPA.t) extra_equations = - let params = KP.List.simple_set params in + let params = KP.List.name_set params in + let is_param simple = + Simple.pattern_match simple + ~name:(fun name -> Name.Set.mem name params) + ~const:(fun _ -> false) + in List.fold_left cse_at_each_use ~init:EP.Map.empty ~f:(fun eligible (env_at_use, id, cse) -> let find_new_name = @@ -185,15 +190,17 @@ let cse_with_eligible_lhs ~typing_env_at_fork ~cse_at_each_use ~params prev_cse since they are defined in [env_at_fork]. However these aren't bound at the use sites, so we must choose another alias that is. *) - if not (Simple.Set.mem bound_to params) then Some bound_to + if not (is_param bound_to) then Some bound_to else let aliases = TE.aliases_of_simple env_at_use ~min_name_mode:NM.normal bound_to - |> Simple.Set.filter (fun simple -> - not (Simple.Set.mem simple params)) + |> Aliases.Alias_set.filter ~f:(fun simple -> + not (is_param simple)) in - Simple.Set.get_singleton aliases + (* CR lmaurer: Do we need to make sure there's only one alias? + If not, we can use [Aliases.Alias_set.find_best] here. *) + Aliases.Alias_set.get_singleton aliases in match bound_to with | None -> eligible diff --git a/middle_end/flambda/types/env/aliases.ml b/middle_end/flambda/types/env/aliases.ml index a863a366fda4..a60dd93bee08 100644 --- a/middle_end/flambda/types/env/aliases.ml +++ b/middle_end/flambda/types/env/aliases.ml @@ -14,6 +14,8 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] +module Const = Reg_width_things.Const + module Aliases_of_canonical_element : sig type t @@ -24,61 +26,61 @@ module Aliases_of_canonical_element : sig val empty : t val is_empty : t -> bool - val add : t -> Simple.t -> Name_mode.t -> t + val add : t -> Name.t -> Name_mode.t -> t val find_earliest_candidates : t - -> filter_by_scope:(Name_mode.t -> Simple.Set.t -> Simple.Set.t) + -> filter_by_scope:(Name_mode.t -> Name.Set.t -> Name.Set.t) -> min_name_mode:Name_mode.t - -> Simple.Set.t option + -> Name.Set.t option - val all : t -> Simple.Set.t + val all : t -> Name.Set.t - val mem : t -> Simple.t -> bool + val mem : t -> Name.t -> bool val union : t -> t -> t val inter : t -> t -> t - val rename : (Simple.t -> Simple.t) -> t -> t + val rename : (Name.t -> Name.t) -> t -> t val merge : t -> t -> t end = struct type t = { - aliases : Simple.Set.t Name_mode.Map.t; - all : Simple.Set.t; + aliases : Name.Set.t Name_mode.Map.t; + all : Name.Set.t; } let invariant _t = () let print ppf { aliases; all = _; } = - Name_mode.Map.print Simple.Set.print ppf aliases + Name_mode.Map.print Name.Set.print ppf aliases let empty = { aliases = Name_mode.Map.empty; - all = Simple.Set.empty; + all = Name.Set.empty; } - let is_empty t = Simple.Set.is_empty t.all + let is_empty t = Name.Set.is_empty t.all let add t elt name_mode = - if Simple.Set.mem elt t.all then begin + if Name.Set.mem elt t.all then begin Misc.fatal_errorf "%a already added to [Aliases_of_canonical_element]: \ %a" - Simple.print elt + Name.print elt print t end; let aliases = Name_mode.Map.update name_mode (function - | None -> Some (Simple.Set.singleton elt) + | None -> Some (Name.Set.singleton elt) | Some elts -> if !Clflags.flambda_invariant_checks then begin - assert (not (Simple.Set.mem elt elts)) + assert (not (Name.Set.mem elt elts)) end; - Some (Simple.Set.add elt elts)) + Some (Name.Set.add elt elts)) t.aliases in - let all = Simple.Set.add elt t.all in + let all = Name.Set.add elt t.all in { aliases; all; } @@ -96,26 +98,26 @@ end = struct | Some result -> if result >= 0 then let aliases = filter_by_scope order aliases in - if Simple.Set.is_empty aliases then None else Some aliases + if Name.Set.is_empty aliases then None else Some aliases else None end) t.aliases None let mem t elt = - Simple.Set.mem elt t.all + Name.Set.mem elt t.all let all t = t.all let union t1 t2 = let aliases = Name_mode.Map.union (fun _order elts1 elts2 -> - Some (Simple.Set.union elts1 elts2)) + Some (Name.Set.union elts1 elts2)) t1.aliases t2.aliases in let t = { aliases; - all = Simple.Set.union t1.all t2.all; + all = Name.Set.union t1.all t2.all; } in invariant t; @@ -126,107 +128,223 @@ end = struct Name_mode.Map.merge (fun _order elts1 elts2 -> match elts1, elts2 with | None, None | Some _, None | None, Some _ -> None - | Some elts1, Some elts2 -> Some (Simple.Set.inter elts1 elts2)) + | Some elts1, Some elts2 -> Some (Name.Set.inter elts1 elts2)) t1.aliases t2.aliases in let t = { aliases; - all = Simple.Set.inter t1.all t2.all; + all = Name.Set.inter t1.all t2.all; } in invariant t; t - let rename rename_simple { aliases; all } = + let rename rename_name { aliases; all } = let aliases = - Name_mode.Map.map (fun elts -> Simple.Set.map rename_simple elts) + Name_mode.Map.map (fun elts -> Name.Set.map rename_name elts) aliases in - let all = Simple.Set.map rename_simple all in + let all = Name.Set.map rename_name all in { aliases; all } let merge t1 t2 = let aliases = Name_mode.Map.union (fun _mode set1 set2 -> - Some (Simple.Set.union set1 set2)) + Some (Name.Set.union set1 set2)) t1.aliases t2.aliases in - let all = Simple.Set.union t1.all t2.all in + let all = Name.Set.union t1.all t2.all in { aliases; all; } end +module Alias_set = struct + type t = { + const : Const.t option; + names : Name.Set.t; + } + + let empty = { const = None; names = Name.Set.empty; } + + let create ~canonical_element ~alias_names = + Simple.pattern_match canonical_element + ~const:(fun canonical_const -> + let const = Some canonical_const in + let names = alias_names in + { const; names }) + ~name:(fun canonical_name -> + let const = None in + let names = Name.Set.add canonical_name alias_names in + { const; names }) + + let singleton simple = + Simple.pattern_match simple + ~const:(fun const -> + { const = Some const; names = Name.Set.empty; }) + ~name:(fun name -> + { const = None; names = Name.Set.singleton name }) + + let get_singleton { const; names; } = + match const with + | Some const -> + if Name.Set.is_empty names then Some (Simple.const const) else None + | None -> + Name.Set.get_singleton names + |> Option.map Simple.name + + let print ppf { const; names; } = + let none ppf () = + Format.fprintf ppf "@<0>%s()" (Flambda_colours.elide ()) + in + Format.fprintf ppf + "@[(\ + @[(const@ %a)@]@ \ + @[(names@ %a)@]\ + @]" + (Format.pp_print_option Const.print ~none) const + Name.Set.print names + + let inter + { const = const1; names = names1; } + { const = const2; names = names2; } = + let const = + match const1, const2 with + | Some const1, Some const2 when Const.equal const1 const2 -> Some const1 + | _, _ -> None + in + let names = Name.Set.inter names1 names2 in + { const; names; } + + let filter { const; names; } ~f = + let const = + match const with + | Some const when f (Simple.const const) -> Some const + | _ -> None + in + let names = + Name.Set.filter (fun name -> f (Simple.name name)) names + in + { const; names; } + + let find_best { const; names; } = + match const with + | Some const -> Some (Simple.const const) + | None -> + let (symbols, vars) = Name.Set.partition Name.is_symbol names in + match Name.Set.min_elt_opt symbols with + | Some symbol -> + Some (Simple.name symbol) + | None -> + match Name.Set.min_elt_opt vars with + | Some var -> + Some (Simple.name var) + | None -> + None +end + + type t = { - canonical_elements : Simple.t Simple.Map.t; + canonical_elements : Simple.t Name.Map.t; (* Canonical elements that have no known aliases are not included in [canonical_elements]. *) - aliases_of_canonical_elements : Aliases_of_canonical_element.t Simple.Map.t; - (* For [elt |-> aliases] in [aliases_of_canonical_elements], then + aliases_of_canonical_names : Aliases_of_canonical_element.t Name.Map.t; + (* For [elt |-> aliases] in [aliases_of_canonical_names], then [aliases] never includes [elt]. *) (* CR mshinwell: check this always holds *) - binding_times_and_modes : Binding_time.With_name_mode.t Simple.Map.t; + aliases_of_consts : Aliases_of_canonical_element.t Const.Map.t; + binding_times_and_modes : Binding_time.With_name_mode.t Name.Map.t; (* Binding times and name modes define an order on the elements. The canonical element for a set of aliases is always the minimal element for this order, which is different from the order used for creating sets and maps. *) } -let print ppf { canonical_elements; aliases_of_canonical_elements; - binding_times_and_modes; } = +let print ppf { canonical_elements; aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } = Format.fprintf ppf "@[(\ @[(canonical_elements@ %a)@]@ \ - @[(aliases_of_canonical_elements@ %a)@]@ \ + @[(aliases_of_canonical_names@ %a)@]@ \ + @[(aliases_of_consts@ %a)@]@ \ @[(binding_times_and_modes@ %a)@]\ )@]" - (Simple.Map.print Simple.print) canonical_elements - (Simple.Map.print Aliases_of_canonical_element.print) - aliases_of_canonical_elements - (Simple.Map.print Binding_time.With_name_mode.print) + (Name.Map.print Simple.print) canonical_elements + (Name.Map.print Aliases_of_canonical_element.print) + aliases_of_canonical_names + (Const.Map.print Aliases_of_canonical_element.print) + aliases_of_consts + (Name.Map.print Binding_time.With_name_mode.print) binding_times_and_modes -let defined_earlier t alias ~than = - let info1 = Simple.Map.find alias t.binding_times_and_modes in - let info2 = Simple.Map.find than t.binding_times_and_modes in +let name_defined_earlier t alias ~than = + let info1 = Name.Map.find alias t.binding_times_and_modes in + let info2 = Name.Map.find than t.binding_times_and_modes in Binding_time.strictly_earlier (Binding_time.With_name_mode.binding_time info1) ~than:(Binding_time.With_name_mode.binding_time info2) +let defined_earlier t alias ~than = + Simple.pattern_match than + ~const:(fun _ -> false) + ~name:(fun than -> + Simple.pattern_match alias + ~const:(fun _ -> true) + ~name:(fun alias -> name_defined_earlier t alias ~than)) + +let binding_time_and_name_mode t elt = + Simple.pattern_match elt + ~const:(fun _ -> + Binding_time.With_name_mode.create + Binding_time.consts_and_discriminants + Name_mode.normal) + ~name:(fun elt -> Name.Map.find elt t.binding_times_and_modes) + let name_mode_unscoped t elt = - Binding_time.With_name_mode.name_mode - (Simple.Map.find elt t.binding_times_and_modes) + Binding_time.With_name_mode.name_mode (binding_time_and_name_mode t elt) let name_mode t elt ~min_binding_time = Binding_time.With_name_mode.scoped_name_mode - (Simple.Map.find elt t.binding_times_and_modes) + (binding_time_and_name_mode t elt) ~min_binding_time let invariant t = if !Clflags.flambda_invariant_checks then begin - let _all_aliases : Simple.Set.t = - Simple.Map.fold (fun canonical_element aliases all_aliases -> + let all_aliases_of_names : Name.Set.t = + Name.Map.fold (fun canonical_element aliases all_aliases -> Aliases_of_canonical_element.invariant aliases; let aliases = Aliases_of_canonical_element.all aliases in - if not (Simple.Set.for_all (fun elt -> - defined_earlier t canonical_element ~than:elt) aliases) + if not (Name.Set.for_all (fun elt -> + name_defined_earlier t canonical_element ~than:elt) aliases) then begin Misc.fatal_errorf "Canonical element %a is not earlier than \ all of its aliases:@ %a" - Simple.print canonical_element + Name.print canonical_element print t end; - if Simple.Set.mem canonical_element aliases then begin + if Name.Set.mem canonical_element aliases then begin Misc.fatal_errorf "Canonical element %a occurs in alias set:@ %a" - Simple.print canonical_element - Simple.Set.print aliases + Name.print canonical_element + Name.Set.print aliases + end; + if not (Name.Set.intersection_is_empty aliases all_aliases) then + begin + Misc.fatal_errorf "Overlapping alias sets:@ %a" print t end; - if not (Simple.Set.is_empty (Simple.Set.inter aliases all_aliases)) then + Name.Set.union aliases all_aliases) + t.aliases_of_canonical_names + Name.Set.empty + in + let _all_aliases : Name.Set.t = + Const.Map.fold (fun _const aliases all_aliases -> + Aliases_of_canonical_element.invariant aliases; + let aliases = Aliases_of_canonical_element.all aliases in + if not (Name.Set.intersection_is_empty aliases all_aliases) then begin Misc.fatal_errorf "Overlapping alias sets:@ %a" print t end; - Simple.Set.union aliases all_aliases) - t.aliases_of_canonical_elements - Simple.Set.empty + Name.Set.union aliases all_aliases) + t.aliases_of_consts + all_aliases_of_names in () end @@ -234,26 +352,36 @@ let invariant t = let empty = { (* CR mshinwell: Rename canonical_elements, maybe to aliases_to_canonical_elements. *) - canonical_elements = Simple.Map.empty; - aliases_of_canonical_elements = Simple.Map.empty; - binding_times_and_modes = Simple.Map.empty; + canonical_elements = Name.Map.empty; + aliases_of_canonical_names = Name.Map.empty; + aliases_of_consts = Const.Map.empty; + binding_times_and_modes = Name.Map.empty; } type canonical = | Is_canonical of Simple.t - | Alias_of_canonical of { element : Simple.t; canonical_element : Simple.t; } + | Alias_of_canonical of { element : Name.t; canonical_element : Simple.t; } let canonical t element : canonical = - match Simple.Map.find element t.canonical_elements with - | exception Not_found -> Is_canonical element - | canonical_element -> - if !Clflags.flambda_invariant_checks then begin - assert (not (Simple.equal element canonical_element)) - end; - Alias_of_canonical { element; canonical_element; } + Simple.pattern_match element + ~const:(fun _ -> Is_canonical element) + ~name:(fun name -> + match Name.Map.find name t.canonical_elements with + | exception Not_found -> Is_canonical element + | canonical_element -> + if !Clflags.flambda_invariant_checks then begin + assert (not (Simple.equal element canonical_element)) + end; + Alias_of_canonical { element = name; canonical_element; }) let get_aliases_of_canonical_element t ~canonical_element = - match Simple.Map.find canonical_element t.aliases_of_canonical_elements with + let name name = + Name.Map.find name t.aliases_of_canonical_names + in + let const const = + Const.Map.find const t.aliases_of_consts + in + match Simple.pattern_match canonical_element ~name ~const with | exception Not_found -> Aliases_of_canonical_element.empty | aliases -> aliases @@ -261,26 +389,38 @@ let add_alias_between_canonical_elements t ~canonical_element ~to_be_demoted = if Simple.equal canonical_element to_be_demoted then t else + let name_to_be_demoted = + Simple.pattern_match to_be_demoted + ~const:(fun c -> + Misc.fatal_errorf + "Can't demote const %a@ (while adding alias to@ %a)" + Const.print c + Simple.print canonical_element) + ~name:(fun name -> name) + in let aliases_of_to_be_demoted = get_aliases_of_canonical_element t ~canonical_element:to_be_demoted in if !Clflags.flambda_invariant_checks then begin - assert (not (Aliases_of_canonical_element.mem - aliases_of_to_be_demoted canonical_element)) + Simple.pattern_match canonical_element + ~const:(fun _ -> ()) + ~name:(fun canonical_element -> + assert (not (Aliases_of_canonical_element.mem + aliases_of_to_be_demoted canonical_element))) end; let canonical_elements = t.canonical_elements - |> Simple.Set.fold (fun alias canonical_elements -> - Simple.Map.add alias canonical_element canonical_elements) + |> Name.Set.fold (fun alias canonical_elements -> + Name.Map.add alias canonical_element canonical_elements) (Aliases_of_canonical_element.all aliases_of_to_be_demoted) - |> Simple.Map.add to_be_demoted canonical_element + |> Name.Map.add name_to_be_demoted canonical_element in let aliases_of_canonical_element = get_aliases_of_canonical_element t ~canonical_element in if !Clflags.flambda_invariant_checks then begin assert (not (Aliases_of_canonical_element.mem - aliases_of_canonical_element to_be_demoted)); + aliases_of_canonical_element name_to_be_demoted)); assert (Aliases_of_canonical_element.is_empty ( Aliases_of_canonical_element.inter aliases_of_canonical_element aliases_of_to_be_demoted)) @@ -289,127 +429,170 @@ let add_alias_between_canonical_elements t ~canonical_element ~to_be_demoted = Aliases_of_canonical_element.add (Aliases_of_canonical_element.union aliases_of_to_be_demoted aliases_of_canonical_element) - to_be_demoted (name_mode_unscoped t to_be_demoted) + name_to_be_demoted (name_mode_unscoped t to_be_demoted) in - let aliases_of_canonical_elements = - t.aliases_of_canonical_elements - |> Simple.Map.remove to_be_demoted - |> Simple.Map.add (* replace *) canonical_element aliases + let aliases_of_canonical_names = + Name.Map.remove name_to_be_demoted t.aliases_of_canonical_names + in + let aliases_of_canonical_names, aliases_of_consts = + Simple.pattern_match canonical_element + ~name:(fun name -> + Name.Map.add (* replace *) name aliases aliases_of_canonical_names, + t.aliases_of_consts) + ~const:(fun const -> + aliases_of_canonical_names, + Const.Map.add (* replace *) const aliases t.aliases_of_consts) in { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes = t.binding_times_and_modes; } -type to_be_demoted = { - canonical_element : Simple.t; - to_be_demoted : Simple.t; -} +type to_be_demoted = Demote_canonical_element1 | Demote_canonical_element2 let choose_canonical_element_to_be_demoted t ~canonical_element1 ~canonical_element2 = if defined_earlier t canonical_element1 ~than:canonical_element2 - then - { canonical_element = canonical_element1; - to_be_demoted = canonical_element2; - } - else - { canonical_element = canonical_element2; - to_be_demoted = canonical_element1; - } + then Demote_canonical_element2 else Demote_canonical_element1 (* CR mshinwell: add submodule *) type add_result = { t : t; canonical_element : Simple.t; - alias_of : Simple.t; + alias_of_demoted_element : Simple.t; } -let invariant_add_result ~original_t { canonical_element; alias_of; t; } = +let invariant_add_result ~original_t { canonical_element; alias_of_demoted_element; t; } = if !Clflags.flambda_invariant_checks then begin invariant t; - if not (Simple.equal canonical_element alias_of) then begin - if not (defined_earlier t canonical_element ~than:alias_of) then begin - Misc.fatal_errorf "Canonical element %a should be defined earlier \ - than %a after alias addition.@ Original alias tracker:@ %a@ \ + if not (defined_earlier t canonical_element ~than:alias_of_demoted_element) then begin + Misc.fatal_errorf "Canonical element %a should be defined earlier \ + than %a after alias addition.@ Original alias tracker:@ %a@ \ + Resulting alias tracker:@ %a" + Simple.print canonical_element + Simple.print alias_of_demoted_element + print original_t + print t + end; + match canonical t alias_of_demoted_element with + | Is_canonical _ -> + Misc.fatal_errorf "Alias %a must not be must not be canonical \ + anymore.@ \ + Original alias tracker:@ %a@ \ Resulting alias tracker:@ %a" - Simple.print canonical_element - Simple.print alias_of + Simple.print alias_of_demoted_element print original_t print t - end - end + | Alias_of_canonical _ -> () end let add_alias t element1 element2 = match canonical t element1, canonical t element2 with - | Is_canonical canonical_element1, Is_canonical canonical_element2 -> - let { canonical_element; to_be_demoted; } = - choose_canonical_element_to_be_demoted t ~canonical_element1 - ~canonical_element2 - in - let t = - add_alias_between_canonical_elements t ~canonical_element - ~to_be_demoted - in - { t; - canonical_element; - (* CR mshinwell: [alias_of] is not a good name. *) - alias_of = to_be_demoted; - } + | Is_canonical canonical_element1, Is_canonical canonical_element2 | Alias_of_canonical - { element = element1; canonical_element = canonical_element1; }, + { element = _; canonical_element = canonical_element1; }, Is_canonical canonical_element2 - | Is_canonical canonical_element2, + | Is_canonical canonical_element1, Alias_of_canonical - { element = element1; canonical_element = canonical_element1; } -> - let { canonical_element; to_be_demoted; } = - choose_canonical_element_to_be_demoted t ~canonical_element1 - ~canonical_element2 - in - let alias_of = - if Simple.equal to_be_demoted canonical_element1 then element1 - else canonical_element2 - in - let t = - add_alias_between_canonical_elements t ~canonical_element - ~to_be_demoted - in - { t; - canonical_element; - alias_of; - } + { element = _; canonical_element = canonical_element2; } | Alias_of_canonical - { element = element1; canonical_element = canonical_element1; }, + { element = _; canonical_element = canonical_element1; }, Alias_of_canonical - { element = element2; canonical_element = canonical_element2; } + { element = _; canonical_element = canonical_element2; } -> - let { canonical_element; to_be_demoted; } = - choose_canonical_element_to_be_demoted t ~canonical_element1 - ~canonical_element2 - in - let alias_of = - if Simple.equal to_be_demoted canonical_element1 then element1 - else element2 - in - let t = - add_alias_between_canonical_elements t ~canonical_element - ~to_be_demoted - in - { t; - canonical_element; - alias_of; - } + if Simple.equal canonical_element1 canonical_element2 + then + let canonical_element = canonical_element1 in + (* We don't have to change anything: since [element1] and [element2] have + the same canonical element, they must already be aliases. But what to + return? According to the contract for [add], + [alias_of_demoted_element] must not be canonical and must equal either + [element1] or [element2]. Thus we must choose whichever of [element1] + and [element2] is not canonical. (They cannot both be canonical: if + [element1] is canonical then it's equal to [canonical_element], and + the same goes for [element2], but they can't both be equal to + [canonical_element] since we assume in [add] that they're different. *) + (* CR lmaurer: These elaborate postconditions are there to avoid breaking + [Typing_env.add_equations]. It would be better to decouple these + functions. Per discussions with poechsel and vlaviron, the + information that [Typing_env] is after (besides the updated [Aliases.t]) + is really: + + 1. What aliases need to be updated? + 2. What do those aliases point to now? + + Currently #1 is always exactly one element, but it could be zero in + this case since nothing needs to be updated. + + So the new [add_result] could be something like: + {[ + type add_result = { + t : t; + updated_aliases : Name.t list; + new_canonical_element : Simple.t; + } + ]} + + (It's not actually necessary that [new_canonical_element] is canonical + as far as [Typing_env] is concerned, but I think this is easier + to explain than "representative_of_new_alias_class" or some such.) *) + let alias_of_demoted_element = + if Simple.equal element1 canonical_element then element2 else element1 + in + { t; canonical_element; alias_of_demoted_element; } + else + let canonical_element, to_be_demoted, alias_of_demoted_element = + let which_element = + choose_canonical_element_to_be_demoted t + ~canonical_element1 ~canonical_element2 + in + match which_element with + | Demote_canonical_element1 -> + canonical_element2, canonical_element1, element1 + | Demote_canonical_element2 -> + canonical_element1, canonical_element2, element2 + in + let t = + add_alias_between_canonical_elements t ~canonical_element + ~to_be_demoted + in + { t; + canonical_element; + alias_of_demoted_element; + } let add t element1 binding_time_and_mode1 element2 binding_time_and_mode2 = + if !Clflags.flambda_invariant_checks then begin + if Simple.equal element1 element2 then begin + Misc.fatal_errorf + "Cannot alias an element to itself: %a" Simple.print element1 + end; + Simple.pattern_match element1 + ~name:(fun _ -> ()) + ~const:(fun const1 -> + Simple.pattern_match element2 + ~name:(fun _ -> ()) + ~const:(fun const2 -> + Misc.fatal_errorf + "Cannot add alias between two consts: %a, %a" + Const.print const1 + Const.print const2 + )); + end; let original_t = t in let element1 = Simple.without_rec_info element1 in let element2 = Simple.without_rec_info element2 in + let add_if_name simple data map = + Simple.pattern_match simple + ~const:(fun _ -> map) + ~name:(fun name -> Name.Map.add name data map) + in let t = { t with binding_times_and_modes = - Simple.Map.add element1 binding_time_and_mode1 - (Simple.Map.add element2 binding_time_and_mode2 + add_if_name element1 binding_time_and_mode1 + (add_if_name element2 binding_time_and_mode2 t.binding_times_and_modes); } in @@ -420,7 +603,11 @@ let add t element1 binding_time_and_mode1 add_result let mem t element = - Simple.Map.mem element t.binding_times_and_modes + Simple.pattern_match element + ~const:(fun const -> + Const.Map.mem const t.aliases_of_consts) + ~name:(fun name -> + Name.Map.mem name t.binding_times_and_modes) (* CR mshinwell: This needs documenting. For the moment we allow relations between canonical elements that are actually incomparable @@ -446,174 +633,193 @@ let mem t element = let get_canonical_element_exn t element elt_name_mode ~min_name_mode ~min_binding_time = - match Simple.Map.find element t.canonical_elements with - | exception Not_found -> - begin match - Name_mode.compare_partial_order elt_name_mode min_name_mode - with - | None -> raise Not_found - | Some c -> - if c >= 0 then element - else raise Not_found - end - | canonical_element -> + let canonical_element, name_mode = + match canonical t element with + | Is_canonical _ -> + element, elt_name_mode + | Alias_of_canonical { canonical_element; _ } -> + let name_mode = name_mode t canonical_element ~min_binding_time in + canonical_element, name_mode + in (* Format.eprintf "looking for canonical for %a, candidate canonical %a, min order %a\n%!" Simple.print element Simple.print canonical_element Name_mode.print min_name_mode; *) - let find_earliest () = - let aliases = get_aliases_of_canonical_element t ~canonical_element in - let filter_by_scope name_mode simples = - if Name_mode.equal name_mode Name_mode.in_types then simples - else - Simple.Set.filter (fun simple -> - let binding_time_and_mode = - Simple.Map.find simple t.binding_times_and_modes - in - let scoped_name_mode = - Binding_time.With_name_mode.scoped_name_mode - binding_time_and_mode - ~min_binding_time - in - Name_mode.equal name_mode scoped_name_mode) - simples - in - match - Aliases_of_canonical_element.find_earliest_candidates aliases - ~filter_by_scope ~min_name_mode - with - | Some at_earliest_mode -> - (* Aliases_of_canonical_element.find_earliest_candidates only returns - non-empty sets *) - assert (not (Simple.Set.is_empty at_earliest_mode)); - Simple.Set.fold (fun elt min_elt -> - if defined_earlier t elt ~than:min_elt - then elt - else min_elt) - at_earliest_mode - (Simple.Set.min_elt at_earliest_mode) - | None -> raise Not_found + let find_earliest () = + (* There used to be a shortcut that avoided consulting the aliases in the + common case that [element] is itself canonical and has no aliases, since + then it does not appear in [canonical_elements]. However, this shortcut + was broken: a canonical element *with* known aliases may still not appear + in [canonical_elements]. See tests/flambda2-aliases for a test that gave + incorrect output (saying x/39 had no aliases). It may be worth restoring + the shortcut, perhaps by returning more information from [canonical]. *) + let aliases = get_aliases_of_canonical_element t ~canonical_element in + let filter_by_scope name_mode names = + if Name_mode.equal name_mode Name_mode.in_types then names + else + Name.Set.filter (fun name -> + let binding_time_and_mode = + Name.Map.find name t.binding_times_and_modes + in + let scoped_name_mode = + Binding_time.With_name_mode.scoped_name_mode + binding_time_and_mode + ~min_binding_time + in + Name_mode.equal name_mode scoped_name_mode) + names in match - Name_mode.compare_partial_order - (name_mode t canonical_element ~min_binding_time) - min_name_mode + Aliases_of_canonical_element.find_earliest_candidates aliases + ~filter_by_scope ~min_name_mode with - | None -> find_earliest () - | Some c -> - if c >= 0 then canonical_element - else find_earliest () + | Some at_earliest_mode -> + (* Aliases_of_canonical_element.find_earliest_candidates only returns + non-empty sets *) + assert (not (Name.Set.is_empty at_earliest_mode)); + Name.Set.fold (fun elt min_elt -> + if name_defined_earlier t elt ~than:min_elt + then elt + else min_elt) + at_earliest_mode + (Name.Set.min_elt at_earliest_mode) + |> Simple.name + | None -> raise Not_found + in + match + Name_mode.compare_partial_order name_mode min_name_mode + with + | None -> find_earliest () + | Some c -> + if c >= 0 then canonical_element + else find_earliest () let get_aliases t element = match canonical t element with | Is_canonical canonical_element -> - let aliases = + let alias_names = Aliases_of_canonical_element.all (get_aliases_of_canonical_element t ~canonical_element) in - Simple.Set.add element aliases - | Alias_of_canonical { element = _; canonical_element; } -> + Alias_set.create ~canonical_element ~alias_names + | Alias_of_canonical { element; canonical_element; } -> if !Clflags.flambda_invariant_checks then begin - assert (not (Simple.equal element canonical_element)) + assert (not (Simple.equal (Simple.name element) canonical_element)) end; - let aliases = + let alias_names = Aliases_of_canonical_element.all (get_aliases_of_canonical_element t ~canonical_element) in if !Clflags.flambda_invariant_checks then begin - assert (Simple.Set.mem element aliases) + assert (Name.Set.mem element alias_names) end; - Simple.Set.add canonical_element aliases + Alias_set.create ~canonical_element ~alias_names let all_ids_for_export { canonical_elements = _; - aliases_of_canonical_elements = _; + aliases_of_canonical_names = _; + aliases_of_consts = _; binding_times_and_modes; } = - Simple.Map.fold (fun simple _binding_time_and_mode ids -> - Ids_for_export.add_simple ids simple) + Name.Map.fold (fun name _binding_time_and_mode ids -> + Ids_for_export.add_name ids name) binding_times_and_modes Ids_for_export.empty let apply_renaming { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } renaming = + let rename_name = Renaming.apply_name renaming in let rename_simple = Renaming.apply_simple renaming in let canonical_elements = - Simple.Map.fold (fun elt canonical acc -> - Simple.Map.add (rename_simple elt) (rename_simple canonical) acc) + Name.Map.fold (fun elt canonical acc -> + Name.Map.add (rename_name elt) (rename_simple canonical) acc) canonical_elements - Simple.Map.empty + Name.Map.empty in - let aliases_of_canonical_elements = - Simple.Map.fold (fun canonical aliases acc -> - Simple.Map.add (rename_simple canonical) - (Aliases_of_canonical_element.rename rename_simple aliases) + let aliases_of_canonical_names = + Name.Map.fold (fun canonical aliases acc -> + Name.Map.add (rename_name canonical) + (Aliases_of_canonical_element.rename rename_name aliases) acc) - aliases_of_canonical_elements - Simple.Map.empty + aliases_of_canonical_names + Name.Map.empty + in + let aliases_of_consts = + Const.Map.map (Aliases_of_canonical_element.rename rename_name) + aliases_of_consts in let binding_times_and_modes = - Simple.Map.fold (fun simple binding_time_and_mode acc -> - Simple.Map.add (rename_simple simple) binding_time_and_mode acc) + Name.Map.fold (fun name binding_time_and_mode acc -> + Name.Map.add (rename_name name) binding_time_and_mode acc) binding_times_and_modes - Simple.Map.empty + Name.Map.empty in { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } let merge t1 t2 = let canonical_elements = - Simple.Map.disjoint_union + Name.Map.disjoint_union t1.canonical_elements t2.canonical_elements in - let aliases_of_canonical_elements = - (* Warning: here the keys of the map can come from other - compilation units, so we cannot assume the keys are disjoint *) - Simple.Map.union (fun _simple aliases1 aliases2 -> - Some (Aliases_of_canonical_element.merge aliases1 aliases2)) - t1.aliases_of_canonical_elements - t2.aliases_of_canonical_elements + (* Warning: we assume that the aliases in the two alias trackers are disjoint, + but nothing stops them from sharing a canonical element. For instance, if + multiple compilation units define aliases to the same canonical symbol, + that symbol will be a canonical element in both of the units' alias + trackers, and thus their [aliases_of_canonical_names] will have a key in + common. *) + let merge_aliases _canonical aliases1 aliases2 = + Some (Aliases_of_canonical_element.merge aliases1 aliases2) + in + let aliases_of_canonical_names = + Name.Map.union merge_aliases + t1.aliases_of_canonical_names + t2.aliases_of_canonical_names in + let aliases_of_consts = + Const.Map.union merge_aliases + t1.aliases_of_consts + t2.aliases_of_consts + in + let symbol_data = Binding_time.With_name_mode.create Binding_time.symbols Name_mode.normal in let binding_times_and_modes = - Simple.Map.union (fun simple data1 data2 -> - Simple.pattern_match simple - ~const:(fun _ -> - assert (Binding_time.With_name_mode.equal data1 data2); - Some data1) - ~name:(fun name -> - Name.pattern_match name - ~var:(fun var -> - (* TODO: filter variables on export and restore fatal_error *) - if Binding_time.(equal (With_name_mode.binding_time data1) - imported_variables) - then Some data2 - else if Binding_time.(equal (With_name_mode.binding_time data2) - imported_variables) - then Some data1 - else - Misc.fatal_errorf - "Variable %a is present in multiple environments" - Variable.print var) - ~symbol:(fun _sym -> - assert (Binding_time.With_name_mode.equal data1 symbol_data); - assert (Binding_time.With_name_mode.equal data2 symbol_data); - Some data1))) + Name.Map.union (fun name data1 data2 -> + Name.pattern_match name + ~var:(fun var -> + (* TODO: filter variables on export and restore fatal_error *) + if Binding_time.(equal (With_name_mode.binding_time data1) + imported_variables) + then Some data2 + else if Binding_time.(equal (With_name_mode.binding_time data2) + imported_variables) + then Some data1 + else + Misc.fatal_errorf + "Variable %a is present in multiple environments" + Variable.print var) + ~symbol:(fun _sym -> + assert (Binding_time.With_name_mode.equal data1 symbol_data); + assert (Binding_time.With_name_mode.equal data2 symbol_data); + Some data1)) t1.binding_times_and_modes t2.binding_times_and_modes in { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } @@ -625,11 +831,13 @@ let get_canonical_ignoring_name_mode t name = let clean_for_export { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } = (* CR vlaviron: This function is kept as a reminder that we'd like to remove unreachable entries at some point. *) { canonical_elements; - aliases_of_canonical_elements; + aliases_of_canonical_names; + aliases_of_consts; binding_times_and_modes; } diff --git a/middle_end/flambda/types/env/aliases.mli b/middle_end/flambda/types/env/aliases.mli index 518e03d42024..deaad40e1339 100644 --- a/middle_end/flambda/types/env/aliases.mli +++ b/middle_end/flambda/types/env/aliases.mli @@ -31,9 +31,18 @@ val empty : t type add_result = private { t : t; canonical_element : Simple.t; - alias_of : Simple.t; + alias_of_demoted_element : Simple.t; } +(** Add an alias relationship to the tracker. The two simple expressions + must be different and not both constants. If [add t s1 mode1 s2 mode2] + returns [{ t = t'; canonical_element; alias_of_demoted_element }], then + according to [t'], + - [canonical_element] is the canonical element of both [s1] and [s2]; + - [alias_of_demoted_element] is either [s1] or [s2]; and + - in the case that [alias_of_demoted_element] was canonical before + (meaning that either [s1] or [s2] happened to be canonical), it is + no longer canonical. *) val add : t -> Simple.t @@ -54,8 +63,32 @@ val get_canonical_element_exn -> min_binding_time:Binding_time.t -> Simple.t +module Alias_set : sig + (** The set of aliases of one particular [Simple.t], or an intersection of + such sets. *) + type t + + val empty : t + + val singleton : Simple.t -> t + + val get_singleton : t -> Simple.t option + + val inter : t -> t -> t + + val filter : t -> f:(Simple.t -> bool) -> t + + (** Return the best alias in the set, where constants are better than + symbols, which are better than variables, and ties are broken + (arbitrarily) by [Simple.compare]. Returns [None] if the alias set is + empty. *) + val find_best : t -> Simple.t option + + val print : Format.formatter -> t -> unit +end + (** [get_aliases] always returns the supplied element in the result set. *) -val get_aliases : t -> Simple.t -> Simple.Set.t +val get_aliases : t -> Simple.t -> Alias_set.t val get_canonical_ignoring_name_mode : t -> Name.t -> Simple.t diff --git a/middle_end/flambda/types/env/meet_env.rec.ml b/middle_end/flambda/types/env/meet_env.rec.ml index 84c8dc0332f4..6eed5395eb6c 100644 --- a/middle_end/flambda/types/env/meet_env.rec.ml +++ b/middle_end/flambda/types/env/meet_env.rec.ml @@ -18,7 +18,7 @@ type t = { env : Typing_env.t; - already_meeting : Simple.Pair.Set.t; + already_meeting : Name.Pair.Set.t; } let print ppf { env; already_meeting; } = @@ -27,33 +27,45 @@ let print ppf { env; already_meeting; } = @[(env@ %a)@]@ \ @[(already_meeting@ %a)@])@]" Typing_env.print env - Simple.Pair.Set.print already_meeting + Name.Pair.Set.print already_meeting let create env = { env; - already_meeting = Simple.Pair.Set.empty; + already_meeting = Name.Pair.Set.empty; } let env t = t.env + +let already_meeting_names t name1 name2 = + Name.Pair.Set.mem (name1, name2) t.already_meeting + || Name.Pair.Set.mem (name2, name1) t.already_meeting let already_meeting t simple1 simple2 = - Simple.Pair.Set.mem (simple1, simple2) t.already_meeting - || Simple.Pair.Set.mem (simple2, simple1) t.already_meeting + let const _const = false in + Simple.pattern_match simple1 ~const ~name:(fun name1 -> + Simple.pattern_match simple2 ~const ~name:(fun name2 -> + already_meeting_names t name1 name2)) -let now_meeting t simple1 simple2 = - if already_meeting t simple1 simple2 then begin +let now_meeting_names t name1 name2 = + if already_meeting_names t name1 name2 then begin Misc.fatal_errorf "Already meeting %a and %a:@ %a" - Simple.print simple1 - Simple.print simple2 + Name.print name1 + Name.print name2 print t end; let already_meeting = - Simple.Pair.Set.add (simple1, simple2) t.already_meeting + Name.Pair.Set.add (name1, name2) t.already_meeting in { t with already_meeting; } +let now_meeting t simple1 simple2 = + let const _const = t in + Simple.pattern_match simple1 ~const ~name:(fun name1 -> + Simple.pattern_match simple2 ~const ~name:(fun name2 -> + now_meeting_names t name1 name2)) + (* let with_typing_env t typing_env = * { t with * env = typing_env; diff --git a/middle_end/flambda/types/env/typing_env.rec.ml b/middle_end/flambda/types/env/typing_env.rec.ml index 7263444762c1..a4c6e67ae31a 100644 --- a/middle_end/flambda/types/env/typing_env.rec.ml +++ b/middle_end/flambda/types/env/typing_env.rec.ml @@ -1003,14 +1003,15 @@ and add_equation t name ty = let binding_time_and_mode_alias_of = binding_time_and_mode_of_simple t alias_of in - let ({ canonical_element; alias_of; t = aliases; } : Aliases.add_result) = + let ({ canonical_element; alias_of_demoted_element; t = aliases; } + : Aliases.add_result) = Aliases.add aliases alias binding_time_and_mode_alias alias_of binding_time_and_mode_alias_of in let ty = Type_grammar.alias_type_of kind canonical_element in - aliases, alias_of, t, ty + aliases, alias_of_demoted_element, t, ty in (* Beware: if we're about to add the equation on a name which is different from the one that the caller passed in, then we need to make sure that the @@ -1330,7 +1331,7 @@ let get_alias_then_canonical_simple_exn t ?min_name_mode let aliases_of_simple t ~min_name_mode simple = Aliases.get_aliases (aliases t) simple - |> Simple.Set.filter (fun alias -> + |> Aliases.Alias_set.filter ~f:(fun alias -> let name_mode = Binding_time.With_name_mode.name_mode (binding_time_and_mode_of_simple t alias) diff --git a/middle_end/flambda/types/env/typing_env.rec.mli b/middle_end/flambda/types/env/typing_env.rec.mli index b29889f569b0..14418ce6f9ce 100644 --- a/middle_end/flambda/types/env/typing_env.rec.mli +++ b/middle_end/flambda/types/env/typing_env.rec.mli @@ -124,9 +124,9 @@ val aliases_of_simple : t -> min_name_mode:Name_mode.t -> Simple.t - -> Simple.Set.t + -> Aliases.Alias_set.t -val aliases_of_simple_allowable_in_types : t -> Simple.t -> Simple.Set.t +val aliases_of_simple_allowable_in_types : t -> Simple.t -> Aliases.Alias_set.t val add_to_code_age_relation : t -> newer:Code_id.t -> older:Code_id.t -> t diff --git a/middle_end/flambda/types/flambda_type.mli b/middle_end/flambda/types/flambda_type.mli index 1a4f71aabdd5..554905195ba0 100644 --- a/middle_end/flambda/types/flambda_type.mli +++ b/middle_end/flambda/types/flambda_type.mli @@ -189,7 +189,7 @@ module Typing_env : sig : t -> min_name_mode:Name_mode.t -> Simple.t - -> Simple.Set.t + -> Aliases.Alias_set.t val clean_for_export : t -> reachable_names:Name_occurrences.t -> t diff --git a/middle_end/flambda/types/type_descr.rec.ml b/middle_end/flambda/types/type_descr.rec.ml index 713e2c0599e9..c232a08b2ac4 100644 --- a/middle_end/flambda/types/type_descr.rec.ml +++ b/middle_end/flambda/types/type_descr.rec.ml @@ -236,18 +236,17 @@ module Make (Head : Type_head_intf.S let all_aliases_of env simple_opt ~in_env = match simple_opt with - | None -> Simple.Set.empty + | None -> Aliases.Alias_set.empty | Some simple -> let simples = - Simple.Set.add simple ( - TE.aliases_of_simple_allowable_in_types env simple) + TE.aliases_of_simple_allowable_in_types env simple in (* Format.eprintf "Aliases of %a are: %a\n%!" Simple.print simple Simple.Set.print simples; *) - Simple.Set.filter (fun simple -> + Aliases.Alias_set.filter ~f:(fun simple -> Typing_env.mem_simple in_env simple) simples @@ -471,47 +470,23 @@ module Make (Head : Type_head_intf.S ~right_env:(Join_env.right_join_env join_env) ~right_ty:t2 in - let choose_shared_alias ~shared_aliases = - match Simple.Set.elements shared_aliases with - | [] -> None - | shared_aliases -> - (* We prefer [Const]s, and if not, [Symbol]s. *) - (* CR mshinwell: Add this as a supported ordering in [Simple] *) - let shared_aliases = - List.sort (fun simple1 simple2 -> - let is_const1 = Simple.is_const simple1 in - let is_const2 = Simple.is_const simple2 in - match is_const1, is_const2 with - | true, false -> -1 - | false, true -> 1 - | true, true | false, false -> - let is_symbol1 = Simple.is_symbol simple1 in - let is_symbol2 = Simple.is_symbol simple2 in - match is_symbol1, is_symbol2 with - | true, false -> -1 - | false, true -> 1 - | true, true | false, false -> - Simple.compare simple1 simple2) - shared_aliases - in - Some (create_equals (List.hd shared_aliases)) - in + (* CR mshinwell: Add shortcut when the canonical simples are equal *) let shared_aliases = let shared_aliases = match canonical_simple1, head1, canonical_simple2, head2 with | None, _, None, _ | None, (Ok _ | Unknown), _, _ - | _, _, None, (Ok _ | Unknown) -> Simple.Set.empty + | _, _, None, (Ok _ | Unknown) -> Aliases.Alias_set.empty | Some simple1, _, _, Bottom -> - Simple.Set.singleton simple1 + Aliases.Alias_set.singleton simple1 | _, Bottom, Some simple2, _ -> - Simple.Set.singleton simple2 + Aliases.Alias_set.singleton simple2 | Some simple1, _, Some simple2, _ -> if Simple.same simple1 simple2 - then Simple.Set.singleton simple1 + then Aliases.Alias_set.singleton simple1 else - Simple.Set.inter + Aliases.Alias_set.inter (all_aliases_of (Join_env.left_join_env join_env) canonical_simple1 ~in_env:(Join_env.target_join_env join_env)) @@ -525,7 +500,7 @@ module Make (Head : Type_head_intf.S (* CR vlaviron: this ensures that we're not creating an alias to a different simple that is just bound_name with different rec_info. Such an alias is forbidden. *) - Simple.Set.filter (fun simple -> + Aliases.Alias_set.filter ~f:(fun simple -> not (Simple.same simple (Simple.name bound_name))) shared_aliases in @@ -533,8 +508,8 @@ module Make (Head : Type_head_intf.S Format.eprintf "Shared aliases:@ %a\n%!" Simple.Set.print shared_aliases; *) - match choose_shared_alias ~shared_aliases with - | Some joined_ty -> Known (to_type joined_ty) + match Aliases.Alias_set.find_best shared_aliases with + | Some alias -> Known (to_type (create_equals alias)) | None -> match canonical_simple1, canonical_simple2 with | Some simple1, Some simple2