From 768ace745f6b6f116fee08f68d6521684d2f4fb0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Mon, 24 Mar 2025 16:20:40 +0100
Subject: [PATCH 01/12] Add Meet_and_n_way_join as copy of Meet_and_join
---
.../flambda2/types/meet_and_n_way_join.ml | 2307 +++++++++++++++++
.../flambda2/types/meet_and_n_way_join.mli | 44 +
2 files changed, 2351 insertions(+)
create mode 100644 middle_end/flambda2/types/meet_and_n_way_join.ml
create mode 100644 middle_end/flambda2/types/meet_and_n_way_join.mli
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml
new file mode 100644
index 00000000000..269f37da343
--- /dev/null
+++ b/middle_end/flambda2/types/meet_and_n_way_join.ml
@@ -0,0 +1,2307 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2021 OCamlPro SAS *)
+(* Copyright 2014--2021 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+module Join_env = Typing_env.Join_env
+module ET = Expand_head.Expanded_type
+module K = Flambda_kind
+module MTC = More_type_creators
+module TG = Type_grammar
+module TE = Typing_env
+module TEE = Typing_env_extension
+module Vec128 = Vector_types.Vec128.Bit_pattern
+open Or_unknown.Let_syntax
+
+let all_aliases_of env simple_opt ~in_env =
+ match simple_opt with
+ | None -> Aliases.Alias_set.empty
+ | Some simple ->
+ let simples = TE.aliases_of_simple_allowable_in_types env simple in
+ Aliases.Alias_set.filter
+ ~f:(fun simple -> TE.mem_simple in_env simple)
+ simples
+
+type 'a meet_return_value = 'a TE.meet_return_value =
+ | Left_input
+ | Right_input
+ | Both_inputs
+ | New_result of 'a
+
+let map_return_value f (x : _ meet_return_value) =
+ match x with
+ | Left_input -> Left_input
+ | Right_input -> Right_input
+ | Both_inputs -> Both_inputs
+ | New_result x -> New_result (f x)
+
+type 'a meet_result =
+ | Bottom of unit meet_return_value
+ | Ok of 'a meet_return_value * TE.t
+
+let add_equation (simple : Simple.t) ty_of_simple env ~meet_type :
+ unit meet_result =
+ let name name ~coercion:coercion_from_name_to_simple =
+ let coercion_from_simple_to_name =
+ Coercion.inverse coercion_from_name_to_simple
+ in
+ let ty_of_name =
+ TG.apply_coercion ty_of_simple coercion_from_simple_to_name
+ in
+ match TE.add_equation_strict env name ty_of_name ~meet_type with
+ | Ok env -> Ok (New_result (), env)
+ | Bottom -> Bottom (New_result ())
+ in
+ Simple.pattern_match simple ~name ~const:(fun const ->
+ (* A constant is its own most precise type, but we still need to check
+ that is matches the assigned type. *)
+ if Flambda_features.check_light_invariants ()
+ then assert (TG.get_alias_opt ty_of_simple == None);
+ let expanded =
+ Expand_head.expand_head0 env (MTC.type_for_const const)
+ ~known_canonical_simple_at_in_types_mode:(Some simple)
+ in
+ match meet_type env (ET.to_type expanded) ty_of_simple with
+ | Or_bottom.Ok (_, env) -> Ok (New_result (), env)
+ | Or_bottom.Bottom -> Bottom (New_result ()))
+
+let map_result ~f = function
+ | Bottom r -> Bottom r
+ | Ok (Left_input, env) -> Ok (Left_input, env)
+ | Ok (Right_input, env) -> Ok (Right_input, env)
+ | Ok (Both_inputs, env) -> Ok (Both_inputs, env)
+ | Ok (New_result x, env) -> Ok (New_result (f x), env)
+
+let map_env ~f = function
+ | Bottom r -> Bottom r
+ | Ok (r, env) -> (
+ match (f env : _ Or_bottom.t) with
+ | Bottom -> Bottom (map_return_value (fun _ -> ()) r)
+ | Ok env -> Ok (r, env))
+
+let extract_value res left right =
+ match res with
+ | Left_input -> left
+ | Right_input -> right
+ | Both_inputs -> left
+ | New_result value -> value
+
+let combine_meet_return_values a b compute_value =
+ match a, b with
+ | Both_inputs, Both_inputs -> Both_inputs
+ | (Left_input | Both_inputs), (Left_input | Both_inputs) -> Left_input
+ | (Right_input | Both_inputs), (Right_input | Both_inputs) -> Right_input
+ | New_result _, _
+ | _, New_result _
+ | Left_input, Right_input
+ | Right_input, Left_input ->
+ New_result (compute_value ())
+
+let set_meet (type a b) (module S : Container_types_intf.Set with type t = a)
+ ~(of_set : a -> b) env (s1 : a) (s2 : a) : b meet_result =
+ match S.subset s1 s2, S.subset s2 s1 with
+ | true, true -> Ok (Both_inputs, env)
+ | true, false -> Ok (Left_input, env)
+ | false, true -> Ok (Right_input, env)
+ | false, false ->
+ let s = S.inter s1 s2 in
+ if S.is_empty s
+ then Bottom (New_result ())
+ else Ok (New_result (of_set s), env)
+
+type ('key, 'data, 'mapping) fold2 =
+ { fold2 :
+ 'acc.
+ ('key -> 'data option -> 'data option -> 'acc -> 'acc) ->
+ 'mapping ->
+ 'mapping ->
+ 'acc ->
+ 'acc
+ }
+
+let meet_mapping (type key data mapping)
+ ~(meet_data : TE.t -> data -> data -> data meet_result)
+ ~(fold2 : (key, data, mapping) fold2) ~env ~(left : mapping)
+ ~(right : mapping) ~(rebuild : (key * data) list -> mapping) :
+ mapping meet_result =
+ let { fold2 } = fold2 in
+ let open struct
+ type t =
+ { all_left : bool;
+ all_right : bool;
+ mapping : (key * data) list;
+ env : TE.t
+ }
+
+ exception Bottom_result
+ end in
+ try
+ let res =
+ fold2
+ (fun key data_left_opt data_right_opt
+ { all_left; all_right; mapping; env } ->
+ match data_left_opt, data_right_opt with
+ | None, None -> assert false
+ | Some data_left, None ->
+ { all_left;
+ all_right = false;
+ mapping = (key, data_left) :: mapping;
+ env
+ }
+ | None, Some data_right ->
+ { all_left = false;
+ all_right;
+ mapping = (key, data_right) :: mapping;
+ env
+ }
+ | Some data_left, Some data_right -> (
+ match meet_data env data_left data_right with
+ | Bottom _ -> raise Bottom_result
+ | Ok (res, env) -> (
+ let[@local] result ~all_left ~all_right data =
+ { all_left; all_right; mapping = (key, data) :: mapping; env }
+ in
+ match res with
+ | Both_inputs -> result ~all_left ~all_right data_left
+ | Left_input -> result ~all_left ~all_right:false data_left
+ | Right_input -> result ~all_left:false ~all_right data_right
+ | New_result data -> result ~all_left:false ~all_right:false data)
+ ))
+ left right
+ { all_left = true; all_right = true; mapping = []; env }
+ in
+ let result =
+ match res.all_left, res.all_right with
+ | true, true -> Both_inputs
+ | true, false -> Left_input
+ | false, true -> Right_input
+ | false, false -> New_result (rebuild res.mapping)
+ in
+ Ok (result, res.env)
+ with Bottom_result -> Bottom (New_result ())
+
+module Map_meet (M : Container_types_intf.Map) = struct
+ let meet ~(meet_data : TE.t -> 'a -> 'a -> 'a meet_result) env (left : 'a M.t)
+ (right : 'a M.t) : 'a M.t meet_result =
+ let fold2 f m1 m2 init =
+ let r = ref init in
+ let _m =
+ M.merge
+ (fun key left right ->
+ r := f key left right !r;
+ None)
+ m1 m2
+ in
+ !r
+ in
+ let rebuild l =
+ List.fold_left (fun m (key, data) -> M.add key data m) M.empty l
+ in
+ let fold2 = { fold2 } in
+ meet_mapping ~meet_data ~fold2 ~env ~left ~right ~rebuild
+end
+
+module Function_slot_map_meet = Map_meet (Function_slot.Map)
+module Value_slot_map_meet = Map_meet (Value_slot.Map)
+
+module Combine_results_meet_ops = struct
+ type _ t =
+ | [] : unit t
+ | ( :: ) : ((TE.t -> 'a -> 'a -> 'a meet_result) * 'b t) -> ('a * 'b) t
+end
+
+module Combine_results_inputs = struct
+ type _ t =
+ | [] : unit t
+ | ( :: ) : ('a * 'b t) -> ('a * 'b) t
+end
+
+let rec build_values : type a. a Combine_results_inputs.t -> a = function
+ | input :: next -> input, build_values next
+ | [] -> ()
+
+let extract_values res left right =
+ match res with
+ | Left_input -> build_values left
+ | Right_input -> build_values right
+ | Both_inputs -> build_values left
+ | New_result value -> value
+
+let combine_results env ~(meet_ops : 'a Combine_results_meet_ops.t)
+ ~(left_inputs : 'a Combine_results_inputs.t)
+ ~(right_inputs : 'a Combine_results_inputs.t) ~(rebuild : 'a -> 'b) :
+ 'b meet_result =
+ let rec do_meets :
+ type a.
+ TE.t ->
+ a Combine_results_meet_ops.t ->
+ a Combine_results_inputs.t ->
+ a Combine_results_inputs.t ->
+ a meet_result =
+ fun env meet_ops left right : a meet_result ->
+ match meet_ops, left, right with
+ | [], [], [] -> Ok (Both_inputs, env)
+ | meet :: next_meet, left_input :: next_left, right_input :: next_right -> (
+ match meet env left_input right_input with
+ | Bottom r -> Bottom r
+ | Ok (result_hd, env) -> (
+ match do_meets env next_meet next_left next_right with
+ | Bottom r -> Bottom r
+ | Ok (result_tl, env) ->
+ let return_value =
+ combine_meet_return_values result_hd result_tl (fun () ->
+ let result_hd =
+ extract_value result_hd left_input right_input
+ in
+ let result_tl = extract_values result_tl next_left next_right in
+ result_hd, result_tl)
+ in
+ Ok (return_value, env)))
+ in
+ map_result ~f:rebuild (do_meets env meet_ops left_inputs right_inputs)
+
+let combine_results2 env ~meet_a ~meet_b ~left_a ~right_a ~left_b ~right_b
+ ~rebuild =
+ combine_results env ~meet_ops:[meet_a; meet_b] ~left_inputs:[left_a; left_b]
+ ~right_inputs:[right_a; right_b] ~rebuild:(fun (a, (b, ())) -> rebuild a b)
+
+type ext =
+ | No_extensions
+ | Ext of
+ { when_a : TEE.t;
+ when_b : TEE.t
+ }
+
+let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
+ ~join_env_extension initial_env val_a1 val_b1 extensions1 val_a2 val_b2
+ extensions2 =
+ let join_scope = TE.current_scope initial_env in
+ let env = TE.increment_scope initial_env in
+ let to_extension scoped_env =
+ TE.cut scoped_env ~cut_after:join_scope
+ |> Typing_env_level.as_extension_without_bindings
+ in
+ let direct_return r =
+ map_env r ~f:(fun scoped_env ->
+ TE.add_env_extension_strict initial_env (to_extension scoped_env)
+ ~meet_type)
+ in
+ let env_a, env_b = Or_bottom.Ok env, Or_bottom.Ok env in
+ let env_a, env_b =
+ match extensions1 with
+ | No_extensions -> env_a, env_b
+ | Ext { when_a; when_b } ->
+ ( Or_bottom.bind env_a ~f:(fun env ->
+ TE.add_env_extension_strict env when_a ~meet_type),
+ Or_bottom.bind env_b ~f:(fun env ->
+ TE.add_env_extension_strict env when_b ~meet_type) )
+ in
+ let env_a, env_b =
+ match extensions2 with
+ | No_extensions -> env_a, env_b
+ | Ext { when_a; when_b } ->
+ ( Or_bottom.bind env_a ~f:(fun env ->
+ TE.add_env_extension_strict env when_a ~meet_type),
+ Or_bottom.bind env_b ~f:(fun env ->
+ TE.add_env_extension_strict env when_b ~meet_type) )
+ in
+ let a_result : _ meet_result =
+ match env_a with
+ | Bottom -> Bottom (New_result ())
+ | Ok env -> meet_a env val_a1 val_a2
+ in
+ let b_result : _ meet_result =
+ match env_b with
+ | Bottom -> Bottom (New_result ())
+ | Ok env -> meet_b env val_b1 val_b2
+ in
+ match a_result, b_result with
+ | Bottom r1, Bottom r2 ->
+ Bottom (combine_meet_return_values r1 r2 (fun () -> ()))
+ | Ok (a_result, env), Bottom b ->
+ let result =
+ combine_meet_return_values a_result b (fun () ->
+ let val_a = extract_value a_result val_a1 val_a2 in
+ let val_b = bottom_b () in
+ val_a, val_b, No_extensions)
+ in
+ direct_return (Ok (result, env))
+ | Bottom a, Ok (b_result, env) ->
+ let result =
+ combine_meet_return_values a b_result (fun () ->
+ let val_b = extract_value b_result val_b1 val_b2 in
+ let val_a = bottom_a () in
+ val_a, val_b, No_extensions)
+ in
+ direct_return (Ok (result, env))
+ | Ok (a_result, env_a), Ok (b_result, env_b) ->
+ let when_a = to_extension env_a in
+ let when_b = to_extension env_b in
+ let extensions =
+ if TEE.is_empty when_a && TEE.is_empty when_b
+ then
+ No_extensions
+ (* CR vlaviron: If both extensions have equations in common, the join
+ below will add them to the result environment. Keeping those common
+ equations in the variant extensions then becomes redundant, but we
+ don't have an easy way to detect redundancy. *)
+ else Ext { when_a; when_b }
+ in
+ let env_extension_result =
+ (* We only catch the cases where empty extensions are preserved *)
+ match extensions, extensions1, extensions2 with
+ | No_extensions, No_extensions, No_extensions -> Both_inputs
+ | No_extensions, No_extensions, Ext _ -> Left_input
+ | No_extensions, Ext _, No_extensions -> Right_input
+ | (No_extensions | Ext _), _, _ ->
+ (* This goes through combine_meet_return_values, so the value is not
+ needed *)
+ New_result ()
+ in
+ let result =
+ combine_meet_return_values
+ (combine_meet_return_values a_result b_result (fun () -> ()))
+ env_extension_result
+ (fun () ->
+ let val_a = extract_value a_result val_a1 val_a2 in
+ let val_b = extract_value b_result val_b1 val_b2 in
+ val_a, val_b, extensions)
+ in
+ let join_env =
+ Join_env.create initial_env ~left_env:env_a ~right_env:env_b
+ in
+ let result_extension = join_env_extension join_env when_a when_b in
+ let result_env =
+ (* Not strict, as we don't expect to be able to get bottom equations from
+ joining non-bottom ones *)
+ TE.add_env_extension initial_env result_extension ~meet_type
+ in
+ Ok (result, result_env)
+
+let meet_code_id (env : TE.t) (code_id1 : Code_id.t) (code_id2 : Code_id.t) :
+ Code_id.t meet_result =
+ if Code_id.equal code_id1 code_id2
+ then Ok (Both_inputs, env)
+ else
+ match
+ Code_age_relation.meet (TE.code_age_relation env)
+ ~resolver:(TE.code_age_relation_resolver env)
+ code_id1 code_id2
+ with
+ | Bottom -> Bottom (New_result ())
+ | Ok code_id ->
+ if Code_id.equal code_id code_id1
+ then Ok (Left_input, env)
+ else if Code_id.equal code_id code_id2
+ then Ok (Right_input, env)
+ else Ok (New_result code_id, env)
+
+type meet_keep_side =
+ | Left
+ | Right
+
+(* type meet_expanded_head_result =
+ * | Left_head_unchanged
+ * | Right_head_unchanged
+ * | New_head of ET.t * TEE.t *)
+
+let meet_alloc_mode env (alloc_mode1 : Alloc_mode.For_types.t)
+ (alloc_mode2 : Alloc_mode.For_types.t) : Alloc_mode.For_types.t meet_result
+ =
+ match alloc_mode1, alloc_mode2 with
+ | (Heap_or_local | Local), (Heap_or_local | Local) | Heap, Heap ->
+ Ok (Both_inputs, env)
+ | (Heap_or_local | Local), _ -> Ok (Right_input, env)
+ | _, (Heap_or_local | Local) -> Ok (Left_input, env)
+
+let join_alloc_mode (alloc_mode1 : Alloc_mode.For_types.t)
+ (alloc_mode2 : Alloc_mode.For_types.t) : Alloc_mode.For_types.t =
+ match alloc_mode1, alloc_mode2 with
+ | (Heap_or_local | Local), _ | _, (Heap_or_local | Local) ->
+ Alloc_mode.For_types.unknown ()
+ | Heap, Heap -> Alloc_mode.For_types.heap
+
+let[@inline always] meet_unknown meet_contents ~contents_is_bottom env
+ (or_unknown1 : _ Or_unknown.t) (or_unknown2 : _ Or_unknown.t) :
+ _ Or_unknown.t meet_result =
+ match or_unknown1, or_unknown2 with
+ | Unknown, Unknown -> Ok (Both_inputs, env)
+ | Known contents1, Known contents2
+ when contents_is_bottom contents1 && contents_is_bottom contents2 ->
+ Bottom Both_inputs
+ | Known contents, _ when contents_is_bottom contents -> Bottom Left_input
+ | _, Known contents when contents_is_bottom contents -> Bottom Right_input
+ | _, Unknown -> Ok (Left_input, env)
+ | Unknown, _ -> Ok (Right_input, env)
+ | Known contents1, Known contents2 ->
+ map_result ~f:Or_unknown.known (meet_contents env contents1 contents2)
+
+let[@inline always] join_unknown join_contents (env : Join_env.t)
+ (or_unknown1 : _ Or_unknown.t) (or_unknown2 : _ Or_unknown.t) :
+ _ Or_unknown.t =
+ match or_unknown1, or_unknown2 with
+ | _, Unknown | Unknown, _ -> Unknown
+ | Known contents1, Known contents2 -> join_contents env contents1 contents2
+
+(* Note: Bottom is a valid element kind for empty arrays, so this function never
+ leads to a general Bottom result *)
+let meet_array_element_kinds (element_kind1 : _ Or_unknown_or_bottom.t)
+ (element_kind2 : _ Or_unknown_or_bottom.t) : _ Or_unknown_or_bottom.t =
+ match element_kind1, element_kind2 with
+ | Unknown, Unknown -> Unknown
+ | Bottom, _ | _, Bottom -> Bottom
+ | Unknown, Ok kind | Ok kind, Unknown -> Ok kind
+ | Ok element_kind1, Ok element_kind2 ->
+ if Flambda_kind.With_subkind.compatible element_kind1
+ ~when_used_at:element_kind2
+ then Ok element_kind1
+ else if Flambda_kind.With_subkind.compatible element_kind2
+ ~when_used_at:element_kind1
+ then Ok element_kind2
+ else Bottom
+
+let join_array_element_kinds (element_kind1 : _ Or_unknown_or_bottom.t)
+ (element_kind2 : _ Or_unknown_or_bottom.t) : _ Or_unknown_or_bottom.t =
+ match element_kind1, element_kind2 with
+ | Unknown, _ | _, Unknown -> Unknown
+ | Bottom, element_kind | element_kind, Bottom -> element_kind
+ | Ok element_kind1, Ok element_kind2 ->
+ if Flambda_kind.With_subkind.compatible element_kind1
+ ~when_used_at:element_kind2
+ then Ok element_kind2
+ else if Flambda_kind.With_subkind.compatible element_kind2
+ ~when_used_at:element_kind1
+ then Ok element_kind1
+ else Unknown
+
+let rec meet env (t1 : TG.t) (t2 : TG.t) : TG.t meet_result =
+ (* Kind mismatches should have been caught (either turned into Invalid or a
+ fatal error) before we get here. *)
+ if not (K.equal (TG.kind t1) (TG.kind t2))
+ then
+ Misc.fatal_errorf "Kind mismatch upon meet:@ %a@ versus@ %a" TG.print t1
+ TG.print t2;
+ let kind = TG.kind t1 in
+ let simple1 =
+ match
+ TE.get_alias_then_canonical_simple_exn env t1
+ ~min_name_mode:Name_mode.in_types
+ with
+ | exception Not_found -> None
+ | canonical_simple -> Some canonical_simple
+ in
+ let simple2 =
+ match
+ TE.get_alias_then_canonical_simple_exn env t2
+ ~min_name_mode:Name_mode.in_types
+ with
+ | exception Not_found -> None
+ | canonical_simple -> Some canonical_simple
+ in
+ match simple1 with
+ | None -> (
+ let expanded1 =
+ Expand_head.expand_head0 env t1
+ ~known_canonical_simple_at_in_types_mode:simple1
+ in
+ match simple2 with
+ | None ->
+ let expanded2 =
+ Expand_head.expand_head0 env t2
+ ~known_canonical_simple_at_in_types_mode:simple2
+ in
+ map_result ~f:ET.to_type (meet_expanded_head env expanded1 expanded2)
+ | Some simple2 -> (
+ (* Here we are meeting a non-alias type on the left with an alias on the
+ right. In all cases, the return type is the alias, so we will always
+ return [Right_input]; the interesting part will be the environment.
+
+ [add_equation] will meet [expanded1] with the existing type of
+ [simple2]. *)
+ let env : unit meet_result =
+ add_equation simple2 (ET.to_type expanded1) env ~meet_type
+ in
+ match env with
+ | Ok (_, env) -> Ok (Right_input, env)
+ | Bottom r -> Bottom r))
+ | Some simple1 -> (
+ match simple2 with
+ | None -> (
+ let expanded2 =
+ Expand_head.expand_head0 env t2
+ ~known_canonical_simple_at_in_types_mode:simple2
+ in
+ (* We always return [Left_input] (see comment above) *)
+ let env : unit meet_result =
+ add_equation simple1 (ET.to_type expanded2) env ~meet_type
+ in
+ match env with
+ | Ok (_, env) -> Ok (Left_input, env)
+ | Bottom r -> Bottom r)
+ | Some simple2 -> (
+ if (* We are doing a meet between two alias types. Whatever happens, the
+ resulting environment will contain an alias equation between the two
+ inputs, so both the left-hand alias and the right-hand alias are
+ correct results for the meet, allowing us to return [Both_inputs] in
+ all cases. *)
+ Simple.equal simple1 simple2
+ then
+ (* The alias is already present; no need to add any equation here *)
+ Ok (Both_inputs, env)
+ else
+ let env =
+ Simple.pattern_match simple2
+ ~name:(fun _ ~coercion:_ ->
+ add_equation simple2
+ (TG.alias_type_of kind simple1)
+ env ~meet_type)
+ ~const:(fun const2 ->
+ Simple.pattern_match simple1
+ ~name:(fun _ ~coercion:_ ->
+ add_equation simple1
+ (TG.alias_type_of kind simple2)
+ env ~meet_type)
+ ~const:(fun const1 : unit meet_result ->
+ if Reg_width_const.equal const1 const2
+ then Ok (New_result (), env)
+ else Bottom (New_result ())))
+ in
+ (* [add_equation] will have called [meet] on the underlying types, so
+ [env] now contains all extra equations arising from meeting the
+ expanded heads. *)
+ match env with
+ | Ok (_, env) -> Ok (Both_inputs, env)
+ | Bottom r -> Bottom r))
+
+and meet_or_unknown_or_bottom :
+ type a b.
+ (TE.t -> a -> a -> b meet_result) ->
+ TE.t ->
+ a Or_unknown_or_bottom.t ->
+ a Or_unknown_or_bottom.t ->
+ b meet_result =
+ fun meet_elt env (input1 : a Or_unknown_or_bottom.t)
+ (input2 : a Or_unknown_or_bottom.t) ->
+ match input1, input2 with
+ | Unknown, Unknown -> Ok (Both_inputs, env)
+ | _, Unknown -> Ok (Left_input, env)
+ | Unknown, _ -> Ok (Right_input, env)
+ | Bottom, Bottom -> Bottom Both_inputs
+ | Bottom, _ -> Bottom Left_input
+ | _, Bottom -> Bottom Right_input
+ | Ok elt1, Ok elt2 -> meet_elt env elt1 elt2
+
+and meet_expanded_head env (expanded1 : ET.t) (expanded2 : ET.t) :
+ ET.t meet_result =
+ meet_or_unknown_or_bottom meet_expanded_head0 env (ET.descr expanded1)
+ (ET.descr expanded2)
+
+and meet_expanded_head0 env (descr1 : ET.descr) (descr2 : ET.descr) :
+ ET.t meet_result =
+ match descr1, descr2 with
+ | Value head1, Value head2 ->
+ map_result ~f:ET.create_value (meet_head_of_kind_value env head1 head2)
+ | Naked_immediate head1, Naked_immediate head2 ->
+ map_result ~f:ET.create_naked_immediate
+ (meet_head_of_kind_naked_immediate env head1 head2)
+ | Naked_float32 head1, Naked_float32 head2 ->
+ map_result ~f:ET.create_naked_float32
+ (meet_head_of_kind_naked_float32 env head1 head2)
+ | Naked_float head1, Naked_float head2 ->
+ map_result ~f:ET.create_naked_float
+ (meet_head_of_kind_naked_float env head1 head2)
+ | Naked_int32 head1, Naked_int32 head2 ->
+ map_result ~f:ET.create_naked_int32
+ (meet_head_of_kind_naked_int32 env head1 head2)
+ | Naked_int64 head1, Naked_int64 head2 ->
+ map_result ~f:ET.create_naked_int64
+ (meet_head_of_kind_naked_int64 env head1 head2)
+ | Naked_nativeint head1, Naked_nativeint head2 ->
+ map_result ~f:ET.create_naked_nativeint
+ (meet_head_of_kind_naked_nativeint env head1 head2)
+ | Naked_vec128 head1, Naked_vec128 head2 ->
+ map_result ~f:ET.create_naked_vec128
+ (meet_head_of_kind_naked_vec128 env head1 head2)
+ | Rec_info head1, Rec_info head2 ->
+ map_result ~f:ET.create_rec_info
+ (meet_head_of_kind_rec_info env head1 head2)
+ | Region head1, Region head2 ->
+ map_result ~f:ET.create_region (meet_head_of_kind_region env head1 head2)
+ | ( ( Value _ | Naked_immediate _ | Naked_float _ | Naked_float32 _
+ | Naked_int32 _ | Naked_vec128 _ | Naked_int64 _ | Naked_nativeint _
+ | Rec_info _ | Region _ ),
+ _ ) ->
+ assert false
+
+and meet_head_of_kind_value env
+ ({ non_null = non_null1; is_null = is_null1 } : TG.head_of_kind_value)
+ ({ non_null = non_null2; is_null = is_null2 } : TG.head_of_kind_value) :
+ TG.head_of_kind_value meet_result =
+ let meet_a =
+ let meet_elt env elt1 elt2 =
+ map_result
+ ~f:(fun x -> Or_unknown_or_bottom.Ok x)
+ (meet_head_of_kind_value_non_null env elt1 elt2)
+ in
+ meet_or_unknown_or_bottom meet_elt
+ in
+ let meet_b env (is_null1 : TG.is_null) (is_null2 : TG.is_null) =
+ match is_null1, is_null2 with
+ | Not_null, Not_null -> Bottom Both_inputs
+ | Maybe_null, Maybe_null -> Ok (Both_inputs, env)
+ | Not_null, Maybe_null -> Bottom Left_input
+ | Maybe_null, Not_null -> Bottom Right_input
+ in
+ let bottom_a () = Or_unknown_or_bottom.Bottom in
+ let bottom_b () : TG.is_null = Not_null in
+ map_result
+ ~f:(fun (non_null, is_null, _extensions) : TG.head_of_kind_value ->
+ { non_null; is_null })
+ (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
+ ~join_env_extension env non_null1 is_null1 No_extensions non_null2
+ is_null2 No_extensions)
+
+and meet_head_of_kind_value_non_null env
+ (head1 : TG.head_of_kind_value_non_null)
+ (head2 : TG.head_of_kind_value_non_null) :
+ TG.head_of_kind_value_non_null meet_result =
+ match head1, head2 with
+ | ( Variant
+ { blocks = blocks1;
+ immediates = imms1;
+ extensions = extensions1;
+ is_unique = is_unique1
+ },
+ Variant
+ { blocks = blocks2;
+ immediates = imms2;
+ extensions = extensions2;
+ is_unique = is_unique2
+ } ) ->
+ (* Uniqueness tracks whether duplication/lifting is allowed. It must always
+ be propagated, both for meet and join. *)
+ let is_unique = is_unique1 || is_unique2 in
+ map_result
+ ~f:(fun (blocks, immediates, extensions) ->
+ TG.Head_of_kind_value_non_null.create_variant ~is_unique ~blocks
+ ~immediates ~extensions)
+ (meet_variant env ~blocks1 ~imms1 ~blocks2 ~imms2 ~extensions1
+ ~extensions2)
+ | ( Mutable_block { alloc_mode = alloc_mode1 },
+ Mutable_block { alloc_mode = alloc_mode2 } ) ->
+ map_result
+ ~f:(fun alloc_mode ->
+ TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode)
+ (meet_alloc_mode env alloc_mode1 alloc_mode2)
+ | Variant { blocks; _ }, Mutable_block { alloc_mode = alloc_mode_right } -> (
+ match blocks with
+ | Unknown -> Ok (Right_input, env)
+ | Known { alloc_mode = alloc_mode_left; _ } -> (
+ (* CR vlaviron: This is not nice. We're more or less treating
+ [Mutable_block] as more precise than [Variant], while losing precision
+ on the way (the row_like equations on known immutable fields). Here is
+ an example where it matters: *)
+ (* type r = { a : int; mutable b : int }
+ * let f r =
+ * let a1 = r.a in
+ * let a2 = r.a in
+ * (a1, a2)
+ *
+ * let g a =
+ * let r = { a; b = 0 } in
+ * let a1 = r.a in
+ * let a2 = r.a in
+ * (a1, a2) *)
+ (* In [f], the two accesses will be shared because the type for those
+ loads is [Variant]. But in [g], we get a more precise type
+ ([Mutable_block]), and this prevents us from sharing the immutable
+ loads.
+
+ I have several ideas to fix this, but none of them are simple so we
+ will need to have a proper discussion before I commit to implementing
+ one. *)
+ match meet_alloc_mode env alloc_mode_left alloc_mode_right with
+ | Bottom r -> Bottom r
+ | Ok ((Both_inputs | Right_input), env) -> Ok (Right_input, env)
+ | Ok (Left_input, env) ->
+ Ok
+ ( New_result
+ (TG.Head_of_kind_value_non_null.create_mutable_block
+ alloc_mode_left),
+ env )
+ | Ok (New_result alloc_mode, env) ->
+ Ok
+ ( New_result
+ (TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode),
+ env )))
+ | Mutable_block { alloc_mode = alloc_mode_left }, Variant { blocks; _ } -> (
+ match blocks with
+ | Unknown -> Ok (Left_input, env)
+ | Known { alloc_mode = alloc_mode_right; _ } -> (
+ (* CR vlaviron: see symmetric case above *)
+ match meet_alloc_mode env alloc_mode_left alloc_mode_right with
+ | Bottom r -> Bottom r
+ | Ok ((Both_inputs | Left_input), env) -> Ok (Left_input, env)
+ | Ok (Right_input, env) ->
+ Ok
+ ( New_result
+ (TG.Head_of_kind_value_non_null.create_mutable_block
+ alloc_mode_right),
+ env )
+ | Ok (New_result alloc_mode, env) ->
+ Ok
+ ( New_result
+ (TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode),
+ env )))
+ | Boxed_float32 (n1, alloc_mode1), Boxed_float32 (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_float32 ~meet_a:meet
+ ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | Boxed_float (n1, alloc_mode1), Boxed_float (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_float ~meet_a:meet
+ ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | Boxed_int32 (n1, alloc_mode1), Boxed_int32 (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_int32 ~meet_a:meet
+ ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | Boxed_int64 (n1, alloc_mode1), Boxed_int64 (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_int64 ~meet_a:meet
+ ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | Boxed_nativeint (n1, alloc_mode1), Boxed_nativeint (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_nativeint
+ ~meet_a:meet ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2
+ ~left_b:alloc_mode1 ~right_b:alloc_mode2
+ | Boxed_vec128 (n1, alloc_mode1), Boxed_vec128 (n2, alloc_mode2) ->
+ combine_results2 env
+ ~rebuild:TG.Head_of_kind_value_non_null.create_boxed_vec128 ~meet_a:meet
+ ~meet_b:meet_alloc_mode ~left_a:n1 ~right_a:n2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | ( Closures { by_function_slot = by_function_slot1; alloc_mode = alloc_mode1 },
+ Closures
+ { by_function_slot = by_function_slot2; alloc_mode = alloc_mode2 } ) ->
+ combine_results2 env ~rebuild:TG.Head_of_kind_value_non_null.create_closures
+ ~meet_a:meet_row_like_for_closures ~meet_b:meet_alloc_mode
+ ~left_a:by_function_slot1 ~right_a:by_function_slot2 ~left_b:alloc_mode1
+ ~right_b:alloc_mode2
+ | String strs1, String strs2 ->
+ map_result ~f:TG.Head_of_kind_value_non_null.create_string
+ (set_meet (module String_info.Set) env strs1 strs2 ~of_set:Fun.id)
+ | ( Array
+ { element_kind = element_kind1;
+ length = length1;
+ contents = contents1;
+ alloc_mode = alloc_mode1
+ },
+ Array
+ { element_kind = element_kind2;
+ length = length2;
+ contents = contents2;
+ alloc_mode = alloc_mode2
+ } ) ->
+ meet_array_type env
+ (element_kind1, length1, contents1, alloc_mode1)
+ (element_kind2, length2, contents2, alloc_mode2)
+ | ( ( Variant _ | Mutable_block _ | Boxed_float _ | Boxed_float32 _
+ | Boxed_int32 _ | Boxed_vec128 _ | Boxed_int64 _ | Boxed_nativeint _
+ | Closures _ | String _ | Array _ ),
+ _ ) ->
+ (* This assumes that all the different constructors are incompatible. This
+ could break very hard for dubious uses of Obj. *)
+ Bottom (New_result ())
+
+and meet_array_type env (element_kind1, length1, contents1, alloc_mode1)
+ (element_kind2, length2, contents2, alloc_mode2) =
+ let element_kind = meet_array_element_kinds element_kind1 element_kind2 in
+ combine_results env
+ ~rebuild:(fun (length, (contents, (alloc_mode, ()))) ->
+ TG.Head_of_kind_value_non_null.create_array_with_contents ~element_kind
+ ~length contents alloc_mode)
+ ~meet_ops:
+ [ meet;
+ meet_array_contents ~meet_element_kind:element_kind;
+ meet_alloc_mode ]
+ ~left_inputs:[length1; contents1; alloc_mode1]
+ ~right_inputs:[length2; contents2; alloc_mode2]
+
+and meet_array_contents env (array_contents1 : TG.array_contents Or_unknown.t)
+ (array_contents2 : TG.array_contents Or_unknown.t)
+ ~(meet_element_kind : _ Or_unknown_or_bottom.t) =
+ meet_unknown
+ (fun env (array_contents1 : TG.array_contents)
+ (array_contents2 : TG.array_contents) : TG.array_contents meet_result ->
+ match array_contents1, array_contents2 with
+ | Mutable, Mutable -> Ok (Both_inputs, env)
+ | Mutable, Immutable _ | Immutable _, Mutable -> Bottom (New_result ())
+ | Immutable { fields = fields1 }, Immutable { fields = fields2 } -> (
+ if Array.length fields1 <> Array.length fields2
+ then Bottom (New_result ())
+ else
+ match meet_element_kind with
+ | Bottom ->
+ if Array.length fields1 = 0
+ then
+ (* Both empty arrays. Returning [Both_inputs] would be correct but
+ may not propagate the Bottom element kind as far as we can.
+ Using a New_result might lead us to extra work is one or both
+ of the inputs already have Bottom kind. We choose the
+ New_result solution because it's a case that is unlikely to
+ happen, so the extra cost is likely very small (while losing
+ precision might be noticeable). *)
+ Ok (New_result (Immutable { fields = [||] }), env)
+ else Bottom (New_result ())
+ | Unknown ->
+ (* vlaviron: If the meet of the kinds is Unknown, then both inputs
+ had Unknown kinds. I don't see how we could end up with an array
+ type where the contents are known but we don't know the kind, but
+ in that case we wouldn't be able to call meet because the two
+ sides may have different kinds. So we'll just return the first
+ input, which is guaranteed to be a correct approximation of the
+ meet. *)
+ Ok (Left_input, env)
+ | Ok _ ->
+ map_result
+ ~f:(fun fields : TG.array_contents -> Immutable { fields })
+ (meet_array_of_types env fields1 fields2
+ ~length:(Array.length fields1))))
+ ~contents_is_bottom:(fun (array_contents : TG.array_contents) ->
+ match array_contents with
+ | Mutable -> false
+ | Immutable { fields } -> Array.exists TG.is_obviously_bottom fields)
+ env array_contents1 array_contents2
+
+and meet_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t)
+ ~(imms1 : TG.t Or_unknown.t)
+ ~(blocks2 : TG.Row_like_for_blocks.t Or_unknown.t)
+ ~(imms2 : TG.t Or_unknown.t) ~(extensions1 : TG.variant_extensions)
+ ~(extensions2 : TG.variant_extensions) :
+ (TG.Row_like_for_blocks.t Or_unknown.t
+ * TG.t Or_unknown.t
+ * TG.variant_extensions)
+ meet_result =
+ let meet_a = meet_unknown meet ~contents_is_bottom:TG.is_obviously_bottom in
+ let meet_b =
+ meet_unknown meet_row_like_for_blocks
+ ~contents_is_bottom:TG.Row_like_for_blocks.is_bottom
+ in
+ let bottom_a () = Or_unknown.Known TG.bottom_naked_immediate in
+ let bottom_b () = Or_unknown.Known TG.Row_like_for_blocks.bottom in
+ let extensions1 =
+ match extensions1 with
+ | No_extensions -> No_extensions
+ | Ext { when_immediate; when_block } ->
+ Ext { when_a = when_immediate; when_b = when_block }
+ in
+ let extensions2 =
+ match extensions2 with
+ | No_extensions -> No_extensions
+ | Ext { when_immediate; when_block } ->
+ Ext { when_a = when_immediate; when_b = when_block }
+ in
+ map_result
+ ~f:(fun (imms, blocks, extensions) ->
+ let extensions : TG.variant_extensions =
+ match extensions with
+ | No_extensions -> No_extensions
+ | Ext { when_a = when_immediate; when_b = when_block } ->
+ Ext { when_immediate; when_block }
+ in
+ blocks, imms, extensions)
+ (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
+ ~join_env_extension env imms1 blocks1 extensions1 imms2 blocks2
+ extensions2)
+
+and meet_head_of_kind_naked_immediate env (t1 : TG.head_of_kind_naked_immediate)
+ (t2 : TG.head_of_kind_naked_immediate) :
+ TG.head_of_kind_naked_immediate meet_result =
+ let module I = Targetint_31_63 in
+ let keep_side side : _ meet_result =
+ match side with
+ | Left -> Ok (Left_input, env)
+ | Right -> Ok (Right_input, env)
+ in
+ let bottom_other_side side : _ meet_result =
+ match side with Left -> Bottom Right_input | Right -> Bottom Left_input
+ in
+ let meet_with_shape ~rebuild ty shape side =
+ map_result ~f:rebuild
+ (match side with Left -> meet env ty shape | Right -> meet env shape ty)
+ in
+ let is_int_immediate ~is_int_ty ~immediates ~is_int_side =
+ if I.Set.is_empty immediates
+ then bottom_other_side is_int_side
+ else
+ let rebuild = TG.Head_of_kind_naked_immediate.create_is_int in
+ match I.Set.mem I.zero immediates, I.Set.mem I.one immediates with
+ | false, false -> Bottom (New_result ())
+ | true, true -> keep_side is_int_side
+ | true, false ->
+ meet_with_shape ~rebuild is_int_ty MTC.any_block is_int_side
+ | false, true ->
+ meet_with_shape ~rebuild is_int_ty MTC.any_tagged_immediate is_int_side
+ in
+ let is_null_immediate ~is_null_ty ~immediates ~is_null_side =
+ if I.Set.is_empty immediates
+ then bottom_other_side is_null_side
+ else
+ let rebuild = TG.Head_of_kind_naked_immediate.create_is_null in
+ match I.Set.mem I.zero immediates, I.Set.mem I.one immediates with
+ | false, false -> Bottom (New_result ())
+ | true, true -> keep_side is_null_side
+ | true, false ->
+ meet_with_shape ~rebuild is_null_ty TG.any_non_null_value is_null_side
+ | false, true -> meet_with_shape ~rebuild is_null_ty TG.null is_null_side
+ in
+ let get_tag_immediate ~get_tag_ty ~immediates ~get_tag_side =
+ if I.Set.is_empty immediates
+ then bottom_other_side get_tag_side
+ else
+ let tags =
+ I.Set.fold
+ (fun tag tags ->
+ match Tag.create_from_targetint tag with
+ | Some tag -> Tag.Set.add tag tags
+ | None -> tags (* No blocks exist with this tag *))
+ immediates Tag.Set.empty
+ in
+ if Tag.Set.is_empty tags
+ then Bottom (New_result ())
+ else
+ match
+ MTC.blocks_with_these_tags tags (Alloc_mode.For_types.unknown ())
+ with
+ | Known shape ->
+ meet_with_shape
+ ~rebuild:TG.Head_of_kind_naked_immediate.create_get_tag get_tag_ty
+ shape get_tag_side
+ | Unknown -> keep_side get_tag_side
+ in
+ match t1, t2 with
+ | Naked_immediates is1, Naked_immediates is2 ->
+ map_result
+ ~f:TG.Head_of_kind_naked_immediate.create_naked_immediates_non_empty
+ (set_meet (module I.Set) env is1 is2 ~of_set:Fun.id)
+ | Is_int is_int_ty, Naked_immediates immediates ->
+ is_int_immediate ~is_int_ty ~immediates ~is_int_side:Left
+ | Naked_immediates immediates, Is_int is_int_ty ->
+ is_int_immediate ~is_int_ty ~immediates ~is_int_side:Right
+ | Get_tag get_tag_ty, Naked_immediates immediates ->
+ get_tag_immediate ~get_tag_ty ~immediates ~get_tag_side:Left
+ | Naked_immediates immediates, Get_tag get_tag_ty ->
+ get_tag_immediate ~get_tag_ty ~immediates ~get_tag_side:Right
+ | Is_null is_null_ty, Naked_immediates immediates ->
+ is_null_immediate ~is_null_ty ~immediates ~is_null_side:Left
+ | Naked_immediates immediates, Is_null is_null_ty ->
+ is_null_immediate ~is_null_ty ~immediates ~is_null_side:Right
+ | (Is_int _ | Get_tag _ | Is_null _), (Is_int _ | Get_tag _ | Is_null _) ->
+ (* CR mshinwell: introduce improved handling for
+ * Is_int meet Is_int
+ * Get_tag meet Get_tag
+ * i.e. a better fix for PR1515, at which point we might also be able
+ * to consider improving:
+ * Is_int meet Get_tag
+ * and vice-versa. *)
+ (* We can't return Bottom, as it would be unsound, so we need to either do
+ the actual meet with Naked_immediates, or just give up and return one of
+ the arguments. *)
+ Ok (Left_input, env)
+
+and meet_head_of_kind_naked_float32 env t1 t2 =
+ set_meet
+ (module Numeric_types.Float32_by_bit_pattern.Set)
+ env
+ (t1
+ : TG.head_of_kind_naked_float32
+ :> Numeric_types.Float32_by_bit_pattern.Set.t)
+ (t2
+ : TG.head_of_kind_naked_float32
+ :> Numeric_types.Float32_by_bit_pattern.Set.t)
+ ~of_set:TG.Head_of_kind_naked_float32.create_non_empty_set
+
+and meet_head_of_kind_naked_float env t1 t2 =
+ set_meet
+ (module Numeric_types.Float_by_bit_pattern.Set)
+ env
+ (t1
+ : TG.head_of_kind_naked_float
+ :> Numeric_types.Float_by_bit_pattern.Set.t)
+ (t2
+ : TG.head_of_kind_naked_float
+ :> Numeric_types.Float_by_bit_pattern.Set.t)
+ ~of_set:TG.Head_of_kind_naked_float.create_non_empty_set
+
+and meet_head_of_kind_naked_int32 env t1 t2 =
+ set_meet
+ (module Numeric_types.Int32.Set)
+ env
+ (t1 : TG.head_of_kind_naked_int32 :> Numeric_types.Int32.Set.t)
+ (t2 : TG.head_of_kind_naked_int32 :> Numeric_types.Int32.Set.t)
+ ~of_set:TG.Head_of_kind_naked_int32.create_non_empty_set
+
+and meet_head_of_kind_naked_int64 env t1 t2 =
+ set_meet
+ (module Numeric_types.Int64.Set)
+ env
+ (t1 : TG.head_of_kind_naked_int64 :> Numeric_types.Int64.Set.t)
+ (t2 : TG.head_of_kind_naked_int64 :> Numeric_types.Int64.Set.t)
+ ~of_set:TG.Head_of_kind_naked_int64.create_non_empty_set
+
+and meet_head_of_kind_naked_nativeint env t1 t2 =
+ set_meet
+ (module Targetint_32_64.Set)
+ env
+ (t1 : TG.head_of_kind_naked_nativeint :> Targetint_32_64.Set.t)
+ (t2 : TG.head_of_kind_naked_nativeint :> Targetint_32_64.Set.t)
+ ~of_set:TG.Head_of_kind_naked_nativeint.create_non_empty_set
+
+and meet_head_of_kind_naked_vec128 env t1 t2 =
+ set_meet
+ (module Vec128.Set)
+ env
+ (t1 : TG.head_of_kind_naked_vec128 :> Vec128.Set.t)
+ (t2 : TG.head_of_kind_naked_vec128 :> Vec128.Set.t)
+ ~of_set:TG.Head_of_kind_naked_vec128.create_non_empty_set
+
+and meet_head_of_kind_rec_info env _t1 _t2 =
+ (* CR-someday lmaurer: This could be doing things like discovering two depth
+ variables are equal *)
+ (* CR vlaviron: This looks awfully wrong. I think we'll need to remove it at
+ some point; it is only reachable from function types, and we should already
+ have any relevant coercion from closure types. *)
+ Ok (Both_inputs, env)
+
+and meet_head_of_kind_region env () () : _ meet_result = Ok (Both_inputs, env)
+
+and meet_row_like :
+ 'lattice 'shape 'maps_to 'row_tag 'known.
+ meet_maps_to:(TE.t -> 'maps_to -> 'maps_to -> 'maps_to meet_result) ->
+ equal_index:('lattice -> 'lattice -> bool) ->
+ subset_index:('lattice -> 'lattice -> bool) ->
+ union_index:('lattice -> 'lattice -> 'lattice) ->
+ meet_shape:('shape -> 'shape -> 'shape Or_bottom.t) ->
+ is_empty_map_known:('known -> bool) ->
+ get_singleton_map_known:
+ ('known ->
+ ('row_tag * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) option) ->
+ merge_map_known:
+ (('row_tag ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) ->
+ 'known ->
+ 'known ->
+ 'known) ->
+ TE.t ->
+ known1:'known ->
+ known2:'known ->
+ other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
+ other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
+ ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t)
+ meet_result =
+ fun ~meet_maps_to ~equal_index ~subset_index ~union_index ~meet_shape
+ ~is_empty_map_known ~get_singleton_map_known ~merge_map_known initial_env
+ ~known1 ~known2 ~other1 ~other2 ->
+ let common_scope = TE.current_scope initial_env in
+ let base_env = TE.increment_scope initial_env in
+ let extract_extension scoped_env =
+ TE.cut_as_extension scoped_env ~cut_after:common_scope
+ in
+ let open struct
+ type result_env =
+ | No_result
+ | Extension of TEE.t
+ end in
+ let result_env = ref No_result in
+ let need_join =
+ (* The returned env_extension is the join of the env_extension produced by
+ each non bottom cases. Therefore there is some loss of precision in that
+ case and we need to store the one produced for each tag. But when only
+ one tag is kept it would be wasteful (but correct) to store it.
+
+ We consider that the result of the meet between t1 and t2 will have only
+ one tag when t1 (or t2) has exactly one tag (one that and no 'other'
+ cases).
+
+ This is an overapproximation because the result could have only one tag
+ for instance if
+
+ t1 = [Tag 1 | Tag 2] and t2 = [Tag 2 | Tag 3], or if
+
+ t1 = [Tag 1 | Tag 2] and t2 = [Tag 1 | Tag 2]
+
+ but the meet between some combinations result in a bottom. *)
+ match
+ ( other1,
+ get_singleton_map_known known1,
+ other2,
+ get_singleton_map_known known2 )
+ with
+ | Bottom, Some _, _, _ | _, _, Bottom, Some _ -> false
+ | (Ok _ | Bottom), _, (Ok _ | Bottom), _ ->
+ if is_empty_map_known known1 && is_empty_map_known known2
+ then false
+ else true
+ in
+ let result_is_t1 = ref true in
+ let result_is_t2 = ref true in
+ let update_refs = function
+ | Both_inputs -> ()
+ | Left_input -> result_is_t2 := false
+ | Right_input -> result_is_t1 := false
+ | New_result _ ->
+ result_is_t1 := false;
+ result_is_t2 := false
+ in
+ let join_result_env scoped_env =
+ let new_result_env =
+ match !result_env with
+ | No_result -> Extension (extract_extension scoped_env)
+ | Extension ext1 ->
+ assert need_join;
+ let ext2 = extract_extension scoped_env in
+ let join_env =
+ Join_env.create base_env ~left_env:base_env ~right_env:scoped_env
+ in
+ let extension = join_env_extension join_env ext1 ext2 in
+ Extension extension
+ in
+ result_env := new_result_env
+ in
+ let meet_index env (i1 : ('lattice, 'shape) TG.row_like_index)
+ (i2 : ('lattice, 'shape) TG.row_like_index) :
+ ('lattice, 'shape) TG.row_like_index meet_result =
+ match meet_shape i1.shape i2.shape with
+ | Bottom -> Bottom (New_result ())
+ | Ok shape -> (
+ match i1.domain, i2.domain with
+ | Known i1', Known i2' ->
+ if equal_index i1' i2'
+ then Ok (Both_inputs, env)
+ else Bottom (New_result ())
+ | Known known, At_least at_least ->
+ if subset_index at_least known
+ then
+ (* [at_least] is included in [known] hence [Known known] is included
+ in [At_least at_least], hence [Known known] \inter [At_least
+ at_least] = [Known known] *)
+ Ok (Left_input, env)
+ else Bottom (New_result ())
+ | At_least at_least, Known known ->
+ if subset_index at_least known
+ then Ok (Right_input, env)
+ else Bottom (New_result ())
+ | At_least i1', At_least i2' ->
+ if subset_index i1' i2'
+ then
+ if subset_index i2' i1'
+ then Ok (Both_inputs, env)
+ else Ok (Right_input, env)
+ else if subset_index i2' i1'
+ then Ok (Left_input, env)
+ else
+ let domain =
+ TG.Row_like_index_domain.at_least (union_index i1' i2')
+ in
+ Ok (New_result (TG.Row_like_index.create ~domain ~shape), env))
+ in
+ let bottom_case r =
+ update_refs r;
+ None
+ in
+ let meet_case env (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t)
+ (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) =
+ match meet_index env case1.index case2.index with
+ | Bottom r -> bottom_case r
+ | Ok (index_result, env) -> (
+ match meet_maps_to env case1.maps_to case2.maps_to with
+ | Bottom r -> bottom_case r
+ | Ok (maps_to_result, env) -> (
+ let env : _ Or_bottom.t =
+ match
+ TE.add_env_extension_strict env case1.env_extension ~meet_type
+ with
+ | Bottom -> Bottom
+ | Ok env ->
+ TE.add_env_extension_strict env case2.env_extension ~meet_type
+ in
+ match env with
+ | Bottom -> bottom_case (New_result ())
+ | Ok env ->
+ join_result_env env;
+ update_refs index_result;
+ update_refs maps_to_result;
+ let index = extract_value index_result case1.index case2.index in
+ let maps_to =
+ extract_value maps_to_result case1.maps_to case2.maps_to
+ in
+ let env_extension =
+ if need_join then extract_extension env else TEE.empty
+ in
+ if TEE.is_empty env_extension
+ then ()
+ else (
+ result_is_t1 := false;
+ result_is_t2 := false);
+ Some
+ (Or_unknown.Known
+ (TG.Row_like_case.create ~maps_to ~index ~env_extension))))
+ in
+ let meet_knowns
+ (case1 :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option)
+ (case2 :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option =
+ match case1, case2 with
+ | None, None -> None
+ | Some case1, None -> (
+ match other2 with
+ | Bottom ->
+ result_is_t1 := false;
+ None
+ | Ok other_case -> (
+ match case1 with
+ | Unknown -> (
+ match
+ TE.add_env_extension_strict base_env other_case.env_extension
+ ~meet_type
+ with
+ | Bottom -> None
+ | Ok env ->
+ join_result_env env;
+ result_is_t1 := false;
+ result_is_t2 := false;
+ Some (Known other_case))
+ | Known case1 -> meet_case base_env case1 other_case))
+ | None, Some case2 -> (
+ match other1 with
+ | Bottom ->
+ result_is_t2 := false;
+ None
+ | Ok other_case -> (
+ match case2 with
+ | Unknown -> (
+ match
+ TE.add_env_extension_strict base_env other_case.env_extension
+ ~meet_type
+ with
+ | Bottom -> None
+ | Ok env ->
+ join_result_env env;
+ result_is_t1 := false;
+ result_is_t2 := false;
+ Some (Known other_case))
+ | Known case2 -> meet_case base_env other_case case2))
+ | Some case1, Some case2 -> (
+ match case1, case2 with
+ | Unknown, Unknown ->
+ join_result_env base_env;
+ Some Unknown
+ | Known case, Unknown -> (
+ match
+ TE.add_env_extension_strict base_env case.env_extension ~meet_type
+ with
+ | Bottom -> None
+ | Ok env ->
+ join_result_env env;
+ result_is_t2 := false;
+ Some (Known case))
+ | Unknown, Known case -> (
+ match
+ TE.add_env_extension_strict base_env case.env_extension ~meet_type
+ with
+ | Bottom -> None
+ | Ok env ->
+ join_result_env env;
+ result_is_t1 := false;
+ Some (Known case))
+ | Known case1, Known case2 -> meet_case base_env case1 case2)
+ in
+ let known =
+ merge_map_known
+ (fun _tag case1 case2 -> meet_knowns case1 case2)
+ known1 known2
+ in
+ let other : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t =
+ match other1, other2 with
+ | Bottom, Bottom -> Bottom
+ | Bottom, _ ->
+ result_is_t2 := false;
+ Bottom
+ | _, Bottom ->
+ result_is_t1 := false;
+ Bottom
+ | Ok other1, Ok other2 -> (
+ match meet_case base_env other1 other2 with
+ | None -> Bottom
+ | Some Unknown -> Misc.fatal_error "meet_case should not produce Unknown"
+ | Some (Known r) -> Ok r)
+ in
+ if is_empty_map_known known
+ && match other with Bottom -> true | Ok _ -> false
+ then Bottom (New_result ())
+ else
+ let env : _ Or_bottom.t =
+ match !result_env with
+ | No_result -> Bottom
+ | Extension ext -> TE.add_env_extension_strict initial_env ext ~meet_type
+ in
+ let match_with_input v =
+ match !result_is_t1, !result_is_t2 with
+ | true, true -> Both_inputs
+ | true, false -> Left_input
+ | false, true -> Right_input
+ | false, false -> New_result v
+ in
+ match env with
+ | Bottom -> Bottom (match_with_input ())
+ | Ok env -> Ok (match_with_input (known, other), env)
+
+and meet_row_like_for_blocks env
+ ({ known_tags = known1; other_tags = other1; alloc_mode = alloc_mode1 } :
+ TG.Row_like_for_blocks.t)
+ ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } :
+ TG.Row_like_for_blocks.t) : TG.Row_like_for_blocks.t meet_result =
+ let meet_shape shape1 shape2 : _ Or_bottom.t =
+ if K.Block_shape.equal shape1 shape2 then Ok shape1 else Bottom
+ in
+ let get_singleton_map_known known =
+ match (Tag.Map.get_singleton known : (_ * _ Or_unknown.t) option) with
+ | Some (tag, Known case) -> Some (tag, case)
+ | Some (_, Unknown) | None -> None
+ in
+ combine_results2 env
+ ~rebuild:(fun (known_tags, other_tags) alloc_mode ->
+ TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode)
+ ~meet_a:(fun env (known1, other1) (known2, other2) ->
+ meet_row_like ~meet_maps_to:meet_int_indexed_product
+ ~equal_index:TG.Block_size.equal ~subset_index:TG.Block_size.subset
+ ~union_index:TG.Block_size.union ~meet_shape
+ ~is_empty_map_known:Tag.Map.is_empty ~get_singleton_map_known
+ ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 ~other2)
+ ~meet_b:meet_alloc_mode ~left_a:(known1, other1) ~right_a:(known2, other2)
+ ~left_b:alloc_mode1 ~right_b:alloc_mode2
+
+and meet_row_like_for_closures env
+ ({ known_closures = known1; other_closures = other1 } :
+ TG.Row_like_for_closures.t)
+ ({ known_closures = known2; other_closures = other2 } :
+ TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t meet_result =
+ let meet_shape () () : _ Or_bottom.t = Ok () in
+ let merge_map_known merge_case known1 known2 =
+ Function_slot.Map.merge
+ (fun fslot case1 case2 ->
+ let case1 = Option.map Or_unknown.known case1 in
+ let case2 = Option.map Or_unknown.known case2 in
+ match merge_case fslot case1 case2 with
+ | None -> None
+ | Some (Or_unknown.Known case) -> Some case
+ | Some Or_unknown.Unknown ->
+ Misc.fatal_error "Unknown case in closure meet")
+ known1 known2
+ in
+ map_result
+ ~f:(fun (known_closures, other_closures) ->
+ TG.Row_like_for_closures.create_raw ~known_closures ~other_closures)
+ (meet_row_like ~meet_maps_to:meet_closures_entry
+ ~equal_index:Set_of_closures_contents.equal
+ ~subset_index:Set_of_closures_contents.subset
+ ~union_index:Set_of_closures_contents.union ~meet_shape
+ ~is_empty_map_known:Function_slot.Map.is_empty
+ ~get_singleton_map_known:Function_slot.Map.get_singleton ~merge_map_known
+ env ~known1 ~known2 ~other1 ~other2)
+
+and meet_closures_entry (env : TE.t)
+ ({ function_types = function_types1;
+ closure_types = closure_types1;
+ value_slot_types = value_slot_types1
+ } :
+ TG.Closures_entry.t)
+ ({ function_types = function_types2;
+ closure_types = closure_types2;
+ value_slot_types = value_slot_types2
+ } :
+ TG.Closures_entry.t) : TG.Closures_entry.t meet_result =
+ combine_results env
+ ~meet_ops:
+ [ Function_slot_map_meet.meet ~meet_data:meet_function_type;
+ meet_product_function_slot_indexed;
+ meet_product_value_slot_indexed ]
+ ~left_inputs:[function_types1; closure_types1; value_slot_types1]
+ ~right_inputs:[function_types2; closure_types2; value_slot_types2]
+ ~rebuild:(fun (function_types, (closure_types, (value_slot_types, ()))) ->
+ TG.Closures_entry.create ~function_types ~closure_types ~value_slot_types)
+
+and meet_product_function_slot_indexed env
+ ({ function_slot_components_by_index = components_by_index1 } :
+ TG.Product.Function_slot_indexed.t)
+ ({ function_slot_components_by_index = components_by_index2 } :
+ TG.Product.Function_slot_indexed.t) :
+ TG.Product.Function_slot_indexed.t meet_result =
+ map_result ~f:TG.Product.Function_slot_indexed.create
+ (Function_slot_map_meet.meet ~meet_data:meet env components_by_index1
+ components_by_index2)
+
+and meet_product_value_slot_indexed env
+ ({ value_slot_components_by_index = components_by_index1 } :
+ TG.Product.Value_slot_indexed.t)
+ ({ value_slot_components_by_index = components_by_index2 } :
+ TG.Product.Value_slot_indexed.t) :
+ TG.Product.Value_slot_indexed.t meet_result =
+ map_result ~f:TG.Product.Value_slot_indexed.create
+ (Value_slot_map_meet.meet ~meet_data:meet env components_by_index1
+ components_by_index2)
+
+and meet_int_indexed_product env (fields1 : TG.Product.Int_indexed.t)
+ (fields2 : TG.Product.Int_indexed.t) : _ meet_result =
+ let length = max (Array.length fields1) (Array.length fields2) in
+ map_result ~f:TG.Product.Int_indexed.create_from_array
+ (meet_array_of_types env fields1 fields2 ~length)
+
+and meet_array_of_types env fields1 fields2 ~length =
+ let fold2 f left right init =
+ let r = ref init in
+ for i = 0 to length - 1 do
+ let left_data = if i >= Array.length left then None else Some left.(i) in
+ let right_data =
+ if i >= Array.length right then None else Some right.(i)
+ in
+ r := f i left_data right_data !r
+ done;
+ !r
+ in
+ let rebuild l =
+ match l with
+ | [] -> [||]
+ | (_key, data) :: _ ->
+ let result = Array.make length data in
+ List.iter (fun (key, data) -> result.(key) <- data) l;
+ result
+ in
+ let fold2 = { fold2 } in
+ meet_mapping ~meet_data:meet ~fold2 ~env ~left:fields1 ~right:fields2 ~rebuild
+
+and meet_function_type (env : TE.t)
+ (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t)
+ (func_type2 : TG.Function_type.t Or_unknown_or_bottom.t) :
+ TG.Function_type.t Or_unknown_or_bottom.t meet_result =
+ match func_type1, func_type2 with
+ | Bottom, Bottom | Unknown, Unknown -> Ok (Both_inputs, env)
+ | Bottom, _ | _, Unknown -> Ok (Left_input, env)
+ | _, Bottom | Unknown, _ -> Ok (Right_input, env)
+ | ( Ok { code_id = code_id1; rec_info = rec_info1 },
+ Ok { code_id = code_id2; rec_info = rec_info2 } ) ->
+ let rebuild code_id rec_info =
+ (* It's possible that [code_id] corresponds to deleted code. In that case,
+ any attempt to inline will fail, as the code will not be found in the
+ simplifier's environment -- see
+ [Simplify_apply_expr.simplify_direct_function_call]. *)
+ Or_unknown_or_bottom.Ok (TG.Function_type.create code_id ~rec_info)
+ in
+ combine_results2 env ~rebuild ~meet_a:meet_code_id ~left_a:code_id1
+ ~right_a:code_id2 ~meet_b:meet ~left_b:rec_info1 ~right_b:rec_info2
+
+and meet_type env t1 t2 : _ Or_bottom.t =
+ if TE.is_bottom env
+ then Bottom
+ else
+ match meet env t1 t2 with
+ | Ok (res, env) -> Ok (res, env)
+ | Bottom _ -> Bottom
+
+and join ?bound_name env (t1 : TG.t) (t2 : TG.t) : TG.t Or_unknown.t =
+ (* Kind mismatches should have been caught (either turned into Invalid or a
+ fatal error) before we get here. *)
+ if not (K.equal (TG.kind t1) (TG.kind t2))
+ then
+ Misc.fatal_errorf "Kind mismatch upon join:@ %a@ versus@ %a" TG.print t1
+ TG.print t2;
+ let kind = TG.kind t1 in
+ let canonical_simple1 =
+ match
+ TE.get_alias_then_canonical_simple_exn
+ (Join_env.left_join_env env)
+ t1 ~min_name_mode:Name_mode.in_types
+ with
+ | exception Not_found -> None
+ | canonical_simple -> Some canonical_simple
+ in
+ let canonical_simple2 =
+ match
+ TE.get_alias_then_canonical_simple_exn
+ (Join_env.right_join_env env)
+ t2 ~min_name_mode:Name_mode.in_types
+ with
+ | exception Not_found -> None
+ | canonical_simple -> Some canonical_simple
+ in
+ let expanded1 =
+ Expand_head.expand_head0
+ (Join_env.left_join_env env)
+ t1 ~known_canonical_simple_at_in_types_mode:canonical_simple1
+ in
+ let expanded2 =
+ Expand_head.expand_head0
+ (Join_env.right_join_env env)
+ t2 ~known_canonical_simple_at_in_types_mode:canonical_simple2
+ in
+ let shared_aliases =
+ let shared_aliases =
+ match
+ ( canonical_simple1,
+ ET.descr expanded1,
+ canonical_simple2,
+ ET.descr expanded2 )
+ with
+ | None, _, None, _
+ | None, (Ok _ | Unknown), _, _
+ | _, _, None, (Ok _ | Unknown) ->
+ Aliases.Alias_set.empty
+ | Some simple1, _, _, Bottom -> Aliases.Alias_set.singleton simple1
+ | _, Bottom, Some simple2, _ -> Aliases.Alias_set.singleton simple2
+ | Some simple1, _, Some simple2, _ ->
+ if Simple.same simple1 simple2
+ then Aliases.Alias_set.singleton simple1
+ else
+ Aliases.Alias_set.inter
+ (all_aliases_of
+ (Join_env.left_join_env env)
+ canonical_simple1
+ ~in_env:(Join_env.target_join_env env))
+ (all_aliases_of
+ (Join_env.right_join_env env)
+ canonical_simple2
+ ~in_env:(Join_env.target_join_env env))
+ in
+ match bound_name with
+ | None -> shared_aliases
+ | Some bound_name ->
+ (* We only return one type for each name, so we have to decide whether to
+ return an alias or an expanded head. Usually we prefer aliases, because
+ we hope that the alias itself will have a concrete equation anyway, but
+ we must be careful to ensure that we don't return aliases to self
+ (obviously wrong) or, if two variables [x] and [y] alias each other,
+ redundant equations [x : (= y)] and [y : (= x)]. *)
+ Aliases.Alias_set.filter
+ ~f:(fun alias ->
+ TE.alias_is_bound_strictly_earlier
+ (Join_env.target_join_env env)
+ ~bound_name ~alias)
+ shared_aliases
+ in
+ let unknown () : _ Or_unknown.t =
+ (* CR vlaviron: Fix this to Unknown when Product can handle it *)
+ Known (MTC.unknown kind)
+ in
+ match Aliases.Alias_set.find_best shared_aliases with
+ | Some alias -> Known (TG.alias_type_of kind alias)
+ | None -> (
+ match canonical_simple1, canonical_simple2 with
+ | Some simple1, Some simple2
+ when Join_env.already_joining env simple1 simple2 ->
+ unknown ()
+ | Some _, Some _ | Some _, None | None, Some _ | None, None -> (
+ let join_heads env : _ Or_unknown.t =
+ Known (ET.to_type (join_expanded_head env kind expanded1 expanded2))
+ in
+ match canonical_simple1, canonical_simple2 with
+ | Some simple1, Some simple2 -> (
+ match Join_env.now_joining env simple1 simple2 with
+ | Continue env -> join_heads env
+ | Stop -> unknown ())
+ | Some _, None | None, Some _ | None, None -> join_heads env))
+
+and join_expanded_head env kind (expanded1 : ET.t) (expanded2 : ET.t) : ET.t =
+ match ET.descr expanded1, ET.descr expanded2 with
+ | Bottom, Bottom -> ET.create_bottom kind
+ (* The target environment defines all the names from the left and right
+ environments, so we can safely return any input as the result *)
+ | Ok _, Bottom -> expanded1
+ | Bottom, Ok _ -> expanded2
+ | Unknown, _ | _, Unknown -> ET.create_unknown kind
+ | Ok descr1, Ok descr2 -> (
+ let expanded_or_unknown =
+ match descr1, descr2 with
+ | Value head1, Value head2 ->
+ let>+ head = join_head_of_kind_value env head1 head2 in
+ ET.create_value head
+ | Naked_immediate head1, Naked_immediate head2 ->
+ let>+ head = join_head_of_kind_naked_immediate env head1 head2 in
+ ET.create_naked_immediate head
+ | Naked_float32 head1, Naked_float32 head2 ->
+ let>+ head = join_head_of_kind_naked_float32 env head1 head2 in
+ ET.create_naked_float32 head
+ | Naked_float head1, Naked_float head2 ->
+ let>+ head = join_head_of_kind_naked_float env head1 head2 in
+ ET.create_naked_float head
+ | Naked_int32 head1, Naked_int32 head2 ->
+ let>+ head = join_head_of_kind_naked_int32 env head1 head2 in
+ ET.create_naked_int32 head
+ | Naked_int64 head1, Naked_int64 head2 ->
+ let>+ head = join_head_of_kind_naked_int64 env head1 head2 in
+ ET.create_naked_int64 head
+ | Naked_nativeint head1, Naked_nativeint head2 ->
+ let>+ head = join_head_of_kind_naked_nativeint env head1 head2 in
+ ET.create_naked_nativeint head
+ | Naked_vec128 head1, Naked_vec128 head2 ->
+ let>+ head = join_head_of_kind_naked_vec128 env head1 head2 in
+ ET.create_naked_vec128 head
+ | Rec_info head1, Rec_info head2 ->
+ let>+ head = join_head_of_kind_rec_info env head1 head2 in
+ ET.create_rec_info head
+ | Region head1, Region head2 ->
+ let>+ head = join_head_of_kind_region env head1 head2 in
+ ET.create_region head
+ | ( ( Value _ | Naked_immediate _ | Naked_float _ | Naked_float32 _
+ | Naked_int32 _ | Naked_vec128 _ | Naked_int64 _ | Naked_nativeint _
+ | Rec_info _ | Region _ ),
+ _ ) ->
+ assert false
+ in
+ match expanded_or_unknown with
+ | Known expanded -> expanded
+ | Unknown -> ET.unknown_like expanded1)
+
+and join_head_of_kind_value env (head1 : TG.head_of_kind_value)
+ (head2 : TG.head_of_kind_value) : TG.head_of_kind_value Or_unknown.t =
+ let non_null : _ Or_unknown_or_bottom.t =
+ match head1.non_null, head2.non_null with
+ | Unknown, _ | _, Unknown -> Unknown
+ | Bottom, x | x, Bottom -> x
+ | Ok head1, Ok head2 -> (
+ match join_head_of_kind_value_non_null env head1 head2 with
+ | Unknown -> Unknown
+ | Known head -> Ok head)
+ in
+ let is_null : TG.is_null =
+ match head1.is_null, head2.is_null with
+ | Maybe_null, _ | _, Maybe_null -> Maybe_null
+ | Not_null, Not_null -> Not_null
+ in
+ match[@warning "-4"] non_null, is_null with
+ | Unknown, Maybe_null -> Unknown
+ | _, _ -> Known { non_null; is_null }
+
+and join_head_of_kind_value_non_null env
+ (head1 : TG.head_of_kind_value_non_null)
+ (head2 : TG.head_of_kind_value_non_null) :
+ TG.head_of_kind_value_non_null Or_unknown.t =
+ match head1, head2 with
+ | ( Variant
+ { blocks = blocks1;
+ immediates = imms1;
+ extensions = extensions1;
+ is_unique = is_unique1
+ },
+ Variant
+ { blocks = blocks2;
+ immediates = imms2;
+ extensions = extensions2;
+ is_unique = is_unique2
+ } ) ->
+ let>+ blocks, immediates, extensions =
+ join_variant env ~blocks1 ~imms1 ~extensions1 ~blocks2 ~imms2 ~extensions2
+ in
+ (* Uniqueness tracks whether duplication/lifting is allowed. It must always
+ be propagated, both for meet and join. *)
+ let is_unique = is_unique1 || is_unique2 in
+ TG.Head_of_kind_value_non_null.create_variant ~is_unique ~blocks ~immediates
+ ~extensions
+ | ( Mutable_block { alloc_mode = alloc_mode1 },
+ Mutable_block { alloc_mode = alloc_mode2 } ) ->
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ Known (TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode)
+ | Boxed_float32 (n1, alloc_mode1), Boxed_float32 (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_float32 n alloc_mode
+ | Boxed_float (n1, alloc_mode1), Boxed_float (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_float n alloc_mode
+ | Boxed_int32 (n1, alloc_mode1), Boxed_int32 (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_int32 n alloc_mode
+ | Boxed_int64 (n1, alloc_mode1), Boxed_int64 (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_int64 n alloc_mode
+ | Boxed_nativeint (n1, alloc_mode1), Boxed_nativeint (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_nativeint n alloc_mode
+ | Boxed_vec128 (n1, alloc_mode1), Boxed_vec128 (n2, alloc_mode2) ->
+ let>+ n = join env n1 n2 in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Head_of_kind_value_non_null.create_boxed_vec128 n alloc_mode
+ | ( Closures { by_function_slot = by_function_slot1; alloc_mode = alloc_mode1 },
+ Closures
+ { by_function_slot = by_function_slot2; alloc_mode = alloc_mode2 } ) ->
+ let by_function_slot =
+ join_row_like_for_closures env by_function_slot1 by_function_slot2
+ in
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ Known
+ (TG.Head_of_kind_value_non_null.create_closures by_function_slot
+ alloc_mode)
+ | String strs1, String strs2 ->
+ let strs = String_info.Set.union strs1 strs2 in
+ Known (TG.Head_of_kind_value_non_null.create_string strs)
+ | ( Array
+ { element_kind = element_kind1;
+ length = length1;
+ contents = array_contents1;
+ alloc_mode = alloc_mode1
+ },
+ Array
+ { element_kind = element_kind2;
+ length = length2;
+ contents = array_contents2;
+ alloc_mode = alloc_mode2
+ } ) ->
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ let element_kind = join_array_element_kinds element_kind1 element_kind2 in
+ let contents =
+ join_array_contents env array_contents1 array_contents2
+ ~joined_element_kind:element_kind
+ in
+ let>+ length = join env length1 length2 in
+ TG.Head_of_kind_value_non_null.create_array_with_contents ~element_kind
+ ~length contents alloc_mode
+ | ( ( Variant _ | Mutable_block _ | Boxed_float _ | Boxed_float32 _
+ | Boxed_int32 _ | Boxed_vec128 _ | Boxed_int64 _ | Boxed_nativeint _
+ | Closures _ | String _ | Array _ ),
+ _ ) ->
+ Unknown
+
+and join_array_contents env (array_contents1 : TG.array_contents Or_unknown.t)
+ (array_contents2 : TG.array_contents Or_unknown.t)
+ ~(joined_element_kind : _ Or_unknown_or_bottom.t) =
+ join_unknown
+ (fun env (array_contents1 : TG.array_contents)
+ (array_contents2 : TG.array_contents) : TG.array_contents Or_unknown.t ->
+ match array_contents1, array_contents2 with
+ | Mutable, Mutable -> Known TG.Mutable
+ | Mutable, Immutable _ | Immutable _, Mutable -> Unknown
+ | Immutable { fields = fields1 }, Immutable { fields = fields2 } -> (
+ if Array.length fields1 <> Array.length fields2
+ then Unknown
+ else
+ match joined_element_kind with
+ | Bottom | Unknown -> Unknown
+ | Ok _ -> (
+ let exception Unknown_result in
+ try
+ let fields =
+ Array.init (Array.length fields1) (fun idx ->
+ match join env fields1.(idx) fields2.(idx) with
+ | Unknown -> raise Unknown_result
+ | Known ty -> ty)
+ in
+ Known (TG.Immutable { fields })
+ with Unknown_result -> Unknown)))
+ env array_contents1 array_contents2
+
+and join_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t)
+ ~(imms1 : TG.t Or_unknown.t) ~(extensions1 : TG.variant_extensions)
+ ~(blocks2 : TG.Row_like_for_blocks.t Or_unknown.t)
+ ~(imms2 : TG.t Or_unknown.t) ~(extensions2 : TG.variant_extensions) :
+ (TG.Row_like_for_blocks.t Or_unknown.t
+ * TG.t Or_unknown.t
+ * TG.variant_extensions)
+ Or_unknown.t =
+ let blocks = join_unknown join_row_like_for_blocks env blocks1 blocks2 in
+ let imms = join_unknown (join ?bound_name:None) env imms1 imms2 in
+ let extensions : TG.variant_extensions =
+ match extensions1, extensions2 with
+ | No_extensions, Ext _ | Ext _, No_extensions | No_extensions, No_extensions
+ ->
+ No_extensions
+ | ( Ext { when_immediate = when_immediate1; when_block = when_block1 },
+ Ext { when_immediate = when_immediate2; when_block = when_block2 } ) ->
+ let when_immediate =
+ join_env_extension env when_immediate1 when_immediate2
+ in
+ let when_block = join_env_extension env when_block1 when_block2 in
+ if TEE.is_empty when_immediate && TEE.is_empty when_block
+ then No_extensions
+ else Ext { when_immediate; when_block }
+ in
+ match blocks, imms, extensions with
+ | Unknown, Unknown, No_extensions -> Unknown
+ | (Unknown | Known _), (Unknown | Known _), (No_extensions | Ext _) ->
+ Known (blocks, imms, extensions)
+
+and join_head_of_kind_naked_immediate env
+ (head1 : TG.Head_of_kind_naked_immediate.t)
+ (head2 : TG.Head_of_kind_naked_immediate.t) :
+ TG.Head_of_kind_naked_immediate.t Or_unknown.t =
+ let module I = Targetint_31_63 in
+ match head1, head2 with
+ | Naked_immediates is1, Naked_immediates is2 -> (
+ assert (not (Targetint_31_63.Set.is_empty is1));
+ assert (not (Targetint_31_63.Set.is_empty is2));
+ let is = I.Set.union is1 is2 in
+ let head = TG.Head_of_kind_naked_immediate.create_naked_immediates is in
+ match head with
+ | Ok head -> Known head
+ | Bottom ->
+ Misc.fatal_error "Did not expect [Bottom] from [create_naked_immediates]")
+ | Is_int ty1, Is_int ty2 ->
+ let>+ ty = join env ty1 ty2 in
+ TG.Head_of_kind_naked_immediate.create_is_int ty
+ | Get_tag ty1, Get_tag ty2 ->
+ let>+ ty = join env ty1 ty2 in
+ TG.Head_of_kind_naked_immediate.create_get_tag ty
+ | Is_null ty1, Is_null ty2 ->
+ let>+ ty = join env ty1 ty2 in
+ TG.Head_of_kind_naked_immediate.create_is_null ty
+ (* From now on: Irregular cases *)
+ (* CR vlaviron: There could be improvements based on reduction (trying to
+ reduce the is_int and get_tag cases to naked_immediate sets, then joining
+ those) but this looks unlikely to be useful and could end up begin quite
+ expensive. *)
+ | Is_int ty, Naked_immediates is_int | Naked_immediates is_int, Is_int ty -> (
+ if I.Set.is_empty is_int
+ then Known (TG.Head_of_kind_naked_immediate.create_is_int ty)
+ else
+ (* Slightly better than Unknown *)
+ let head =
+ TG.Head_of_kind_naked_immediate.create_naked_immediates
+ (I.Set.add I.zero (I.Set.add I.one is_int))
+ in
+ match head with
+ | Ok head -> Known head
+ | Bottom ->
+ Misc.fatal_error
+ "Did not expect [Bottom] from [create_naked_immediates]")
+ | Get_tag ty, Naked_immediates tags | Naked_immediates tags, Get_tag ty ->
+ if I.Set.is_empty tags
+ then Known (TG.Head_of_kind_naked_immediate.create_get_tag ty)
+ else Unknown
+ | Is_null ty, Naked_immediates is_null | Naked_immediates is_null, Is_null ty
+ -> (
+ if I.Set.is_empty is_null
+ then Known (TG.Head_of_kind_naked_immediate.create_is_null ty)
+ else
+ (* Slightly better than Unknown *)
+ let head =
+ TG.Head_of_kind_naked_immediate.create_naked_immediates
+ (I.Set.add I.zero (I.Set.add I.one is_null))
+ in
+ match head with
+ | Ok head -> Known head
+ | Bottom ->
+ Misc.fatal_error
+ "Did not expect [Bottom] from [create_naked_immediates]")
+ | (Is_int _ | Get_tag _ | Is_null _), (Is_int _ | Get_tag _ | Is_null _) ->
+ Unknown
+
+and join_head_of_kind_naked_float32 _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_float32.union t1 t2)
+
+and join_head_of_kind_naked_float _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_float.union t1 t2)
+
+and join_head_of_kind_naked_int32 _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_int32.union t1 t2)
+
+and join_head_of_kind_naked_int64 _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_int64.union t1 t2)
+
+and join_head_of_kind_naked_nativeint _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_nativeint.union t1 t2)
+
+and join_head_of_kind_naked_vec128 _env t1 t2 : _ Or_unknown.t =
+ Known (TG.Head_of_kind_naked_vec128.union t1 t2)
+
+and join_head_of_kind_rec_info _env t1 t2 : _ Or_unknown.t =
+ if Rec_info_expr.equal t1 t2 then Known t1 else Unknown
+
+and join_head_of_kind_region _env () () : _ Or_unknown.t = Known ()
+
+(* Note that unlike the [join] function on types, for structures (closures
+ entry, row-like, etc.) the return type is [t] (and not [t Or_unknown.t]).
+ This simplifies some parts of the code a bit that cannot handle the Unknown
+ case gracefully. All join functions for structures can handle [Unknown]
+ results from generic [join]s without needing to propagate them. *)
+
+and join_row_like :
+ 'lattice 'shape 'maps_to 'row_tag 'known.
+ join_maps_to:(Join_env.t -> 'shape -> 'maps_to -> 'maps_to -> 'maps_to) ->
+ equal_index:('lattice -> 'lattice -> bool) ->
+ inter_index:('lattice -> 'lattice -> 'lattice) ->
+ join_shape:('shape -> 'shape -> 'shape Or_unknown.t) ->
+ merge_map_known:
+ (('row_tag ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) ->
+ 'known ->
+ 'known ->
+ 'known) ->
+ Join_env.t ->
+ known1:'known ->
+ known2:'known ->
+ other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
+ other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
+ ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t)
+ Or_unknown.t =
+ fun ~join_maps_to ~equal_index ~inter_index ~join_shape ~merge_map_known
+ join_env ~known1 ~known2 ~other1 ~other2 ->
+ let join_index (i1 : ('lattice, 'shape) TG.row_like_index)
+ (i2 : ('lattice, 'shape) TG.row_like_index) :
+ ('lattice, 'shape) TG.row_like_index Or_unknown.t =
+ match join_shape i1.shape i2.shape with
+ | Unknown -> Unknown
+ | Known shape -> (
+ let return_index domain =
+ Or_unknown.Known (TG.Row_like_index.create ~domain ~shape)
+ in
+ match i1.domain, i2.domain with
+ | Known i1', Known i2' ->
+ if equal_index i1' i2'
+ then return_index i1.domain
+ else
+ (* We can't represent exactly the union, This is the best
+ approximation *)
+ return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2'))
+ | Known i1', At_least i2'
+ | At_least i1', Known i2'
+ | At_least i1', At_least i2' ->
+ return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2')))
+ in
+ let join_case join_env
+ (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t)
+ (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) : _ Or_unknown.t
+ =
+ let index = join_index case1.index case2.index in
+ Or_unknown.map index
+ ~f:(fun (index : ('lattice, 'shape) TG.Row_like_index.t) ->
+ let maps_to =
+ join_maps_to join_env index.shape case1.maps_to case2.maps_to
+ in
+ let env_extension =
+ join_env_extension join_env case1.env_extension case2.env_extension
+ in
+ TG.Row_like_case.create ~maps_to ~index ~env_extension)
+ in
+ let join_knowns
+ (case1 :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option)
+ (case2 :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option =
+ match case1, case2 with
+ | None, None -> None
+ | Some Unknown, _ | _, Some Unknown -> Some Unknown
+ | Some (Known case1), None -> (
+ let only_case1 () =
+ (* cf. Type_descr.join_head_or_unknown_or_bottom, we need to join these
+ to ensure that free variables not present in the target env are
+ cleaned out of the types. Same below *)
+ (* CR pchambart: This seems terribly inefficient. *)
+ let join_env =
+ Join_env.create
+ (Join_env.target_join_env join_env)
+ ~left_env:(Join_env.left_join_env join_env)
+ ~right_env:(Join_env.left_join_env join_env)
+ in
+ let case1 = join_case join_env case1 case1 in
+ Some case1
+ in
+ match other2 with
+ | Bottom -> only_case1 ()
+ | Ok other_case -> Some (join_case join_env case1 other_case))
+ | None, Some (Known case2) -> (
+ let only_case2 () =
+ (* See at the other bottom case *)
+ let join_env =
+ Join_env.create
+ (Join_env.target_join_env join_env)
+ ~left_env:(Join_env.right_join_env join_env)
+ ~right_env:(Join_env.right_join_env join_env)
+ in
+ let case2 = join_case join_env case2 case2 in
+ Some case2
+ in
+ match other1 with
+ | Bottom -> only_case2 ()
+ | Ok other_case -> Some (join_case join_env other_case case2))
+ | Some (Known case1), Some (Known case2) ->
+ Some (join_case join_env case1 case2)
+ in
+ let known =
+ merge_map_known
+ (fun _tag case1 case2 -> join_knowns case1 case2)
+ known1 known2
+ in
+ let other :
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t Or_unknown.t =
+ match other1, other2 with
+ | Bottom, Bottom -> Known Bottom
+ | Ok other1, Bottom ->
+ (* See the previous cases *)
+ let env =
+ Join_env.create
+ (Join_env.target_join_env join_env)
+ ~left_env:(Join_env.left_join_env join_env)
+ ~right_env:(Join_env.left_join_env join_env)
+ in
+ let other1 = join_case env other1 other1 in
+ Or_unknown.map other1 ~f:(fun other1 -> Or_bottom.Ok other1)
+ | Bottom, Ok other2 ->
+ (* See the previous cases *)
+ let env =
+ Join_env.create
+ (Join_env.target_join_env join_env)
+ ~left_env:(Join_env.right_join_env join_env)
+ ~right_env:(Join_env.right_join_env join_env)
+ in
+ let other2 = join_case env other2 other2 in
+ Or_unknown.map other2 ~f:(fun other2 -> Or_bottom.Ok other2)
+ | Ok other1, Ok other2 ->
+ Or_unknown.map (join_case join_env other1 other2) ~f:(fun case ->
+ Or_bottom.Ok case)
+ in
+ Or_unknown.map other ~f:(fun other -> known, other)
+
+and join_row_like_for_blocks env
+ ({ known_tags = known1; other_tags = other1; alloc_mode = alloc_mode1 } :
+ TG.Row_like_for_blocks.t)
+ ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } :
+ TG.Row_like_for_blocks.t) =
+ let join_shape shape1 shape2 : _ Or_unknown.t =
+ if K.Block_shape.equal shape1 shape2 then Known shape1 else Unknown
+ in
+ Or_unknown.map
+ (join_row_like ~join_maps_to:join_int_indexed_product
+ ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter
+ ~join_shape ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1
+ ~other2) ~f:(fun (known_tags, other_tags) ->
+ let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
+ TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode)
+
+and join_row_like_for_closures env
+ ({ known_closures = known1; other_closures = other1 } :
+ TG.Row_like_for_closures.t)
+ ({ known_closures = known2; other_closures = other2 } :
+ TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t =
+ let merge_map_known join_case known1 known2 =
+ Function_slot.Map.merge
+ (fun function_slot case1 case2 ->
+ let case1 = Option.map Or_unknown.known case1 in
+ let case2 = Option.map Or_unknown.known case2 in
+ match (join_case function_slot case1 case2 : _ Or_unknown.t option) with
+ | None -> None
+ | Some (Known case) -> Some case
+ | Some Unknown ->
+ Misc.fatal_error "Join row_like case for closures returned Unknown")
+ known1 known2
+ in
+ match
+ join_row_like
+ ~join_maps_to:(fun env () x y -> join_closures_entry env x y)
+ ~equal_index:Set_of_closures_contents.equal
+ ~inter_index:Set_of_closures_contents.inter
+ ~join_shape:(fun () () -> Or_unknown.Known ())
+ ~merge_map_known env ~known1 ~known2 ~other1 ~other2
+ with
+ | Known (known_closures, other_closures) ->
+ TG.Row_like_for_closures.create_raw ~known_closures ~other_closures
+ | Unknown ->
+ Misc.fatal_error "Join row_like case for closures returned Unknown"
+
+and join_closures_entry env
+ ({ function_types = function_types1;
+ closure_types = closure_types1;
+ value_slot_types = value_slot_types1
+ } :
+ TG.Closures_entry.t)
+ ({ function_types = function_types2;
+ closure_types = closure_types2;
+ value_slot_types = value_slot_types2
+ } :
+ TG.Closures_entry.t) : TG.Closures_entry.t =
+ let function_types =
+ Function_slot.Map.merge
+ (fun _function_slot func_type1 func_type2 ->
+ match func_type1, func_type2 with
+ | None, None | Some _, None | None, Some _ -> None
+ | Some func_type1, Some func_type2 ->
+ Some (join_function_type env func_type1 func_type2))
+ function_types1 function_types2
+ in
+ let closure_types =
+ join_function_slot_indexed_product env closure_types1 closure_types2
+ in
+ let value_slot_types =
+ join_value_slot_indexed_product env value_slot_types1 value_slot_types2
+ in
+ TG.Closures_entry.create ~function_types ~closure_types ~value_slot_types
+
+and join_generic_product :
+ 'key 'key_map.
+ Join_env.t ->
+ components_by_index1:'key_map ->
+ components_by_index2:'key_map ->
+ merge:
+ (('key -> TG.t option -> TG.t option -> TG.t option) ->
+ 'key_map ->
+ 'key_map ->
+ 'key_map) ->
+ 'key_map =
+ fun env ~components_by_index1 ~components_by_index2 ~merge ->
+ merge
+ (fun _index ty1_opt ty2_opt ->
+ match ty1_opt, ty2_opt with
+ | None, _ | _, None -> None
+ | Some ty1, Some ty2 -> (
+ match join env ty1 ty2 with Known ty -> Some ty | Unknown -> None))
+ components_by_index1 components_by_index2
+
+and join_function_slot_indexed_product env
+ ({ function_slot_components_by_index = components_by_index1 } :
+ TG.Product.Function_slot_indexed.t)
+ ({ function_slot_components_by_index = components_by_index2 } :
+ TG.Product.Function_slot_indexed.t) : TG.Product.Function_slot_indexed.t =
+ let function_slot_components_by_index =
+ join_generic_product env ~components_by_index1 ~components_by_index2
+ ~merge:Function_slot.Map.merge
+ in
+ TG.Product.Function_slot_indexed.create function_slot_components_by_index
+
+and join_value_slot_indexed_product env
+ ({ value_slot_components_by_index = components_by_index1 } :
+ TG.Product.Value_slot_indexed.t)
+ ({ value_slot_components_by_index = components_by_index2 } :
+ TG.Product.Value_slot_indexed.t) : TG.Product.Value_slot_indexed.t =
+ let value_slot_components_by_index =
+ join_generic_product env ~components_by_index1 ~components_by_index2
+ ~merge:Value_slot.Map.merge
+ in
+ TG.Product.Value_slot_indexed.create value_slot_components_by_index
+
+and join_int_indexed_product env shape (fields1 : TG.Product.Int_indexed.t)
+ (fields2 : TG.Product.Int_indexed.t) : TG.Product.Int_indexed.t =
+ let length1 = Array.length fields1 in
+ let length2 = Array.length fields2 in
+ let length = min length1 length2 in
+ let exception Exit in
+ let all_phys_equal =
+ try
+ for index = 0 to length - 1 do
+ if fields1.(index) != fields2.(index) then raise Exit
+ done;
+ true
+ with Exit -> false
+ in
+ let fields =
+ if all_phys_equal
+ then
+ if Int.equal length1 length
+ then fields1
+ else (
+ assert (Int.equal length2 length);
+ fields2)
+ else
+ Array.init length (fun index ->
+ if fields1.(index) == fields2.(index)
+ then fields1.(index)
+ else
+ match join env fields1.(index) fields2.(index) with
+ | Unknown -> MTC.unknown_from_shape shape index
+ | Known ty -> ty)
+ in
+ TG.Product.Int_indexed.create_from_array fields
+
+and join_function_type (env : Join_env.t)
+ (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t)
+ (func_type2 : TG.Function_type.t Or_unknown_or_bottom.t) :
+ TG.Function_type.t Or_unknown_or_bottom.t =
+ match func_type1, func_type2 with
+ | Bottom, func_type | func_type, Bottom -> func_type
+ | Unknown, _ | _, Unknown -> Unknown
+ | ( Ok { code_id = code_id1; rec_info = rec_info1 },
+ Ok { code_id = code_id2; rec_info = rec_info2 } ) -> (
+ let target_typing_env = Join_env.target_join_env env in
+ (* As a note, sometimes it might be preferable not to do the code age
+ relation join, and take the hit of an indirect call in exchange for
+ calling specialised versions of the code. Maybe an annotation would be
+ needed. Dolan thinks there isn't a single good answer here and we should
+ maybe just not do the join. (The code age relation meet would remain
+ though as it's useful elsewhere.) *)
+ match
+ Code_age_relation.join
+ ~target_t:(TE.code_age_relation target_typing_env)
+ ~resolver:(TE.code_age_relation_resolver target_typing_env)
+ (TE.code_age_relation (Join_env.left_join_env env))
+ (TE.code_age_relation (Join_env.right_join_env env))
+ code_id1 code_id2
+ with
+ | Unknown -> Unknown
+ | Known code_id -> (
+ match join env rec_info1 rec_info2 with
+ | Known rec_info -> Ok (TG.Function_type.create code_id ~rec_info)
+ | Unknown -> Unknown))
+
+and join_env_extension env (ext1 : TEE.t) (ext2 : TEE.t) : TEE.t =
+ let equations =
+ Name.Map.merge
+ (fun name ty1_opt ty2_opt ->
+ match ty1_opt, ty2_opt with
+ | None, _ | _, None -> None
+ | Some ty1, Some ty2 -> (
+ match join env ty1 ty2 with
+ | Known ty ->
+ if MTC.is_alias_of_name ty name
+ then
+ (* This is rare but not anomalous. It may mean that [ty1] and
+ [ty2] are both alias types which canonicalize to [name], for
+ instance. In any event, if the best type available for [name]
+ is [= name], we effectively know nothing, so we drop [name].
+ ([name = name] would be rejected by [TE.add_equation]
+ anyway.) *)
+ None
+ else (
+ (* This should always pass due to the [is_alias_of_name] check. *)
+ MTC.check_equation name ty;
+ Some ty)
+ | Unknown -> None))
+ (TEE.to_map ext1) (TEE.to_map ext2)
+ in
+ TEE.from_map equations
+
+(* Exposed to the outside world with Or_bottom type *)
+let meet env ty1 ty2 : _ Or_bottom.t =
+ if TE.is_bottom env
+ then Bottom
+ else
+ match meet env ty1 ty2 with
+ | Bottom _ -> Bottom
+ | Ok (r, env) ->
+ let res_ty = extract_value r ty1 ty2 in
+ if TG.is_obviously_bottom res_ty then Bottom else Ok (res_ty, env)
+
+let meet_shape env t ~shape : _ Or_bottom.t =
+ if TE.is_bottom env
+ then Bottom
+ else match meet env t shape with Bottom -> Bottom | Ok (_, env) -> Ok env
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.mli b/middle_end/flambda2/types/meet_and_n_way_join.mli
new file mode 100644
index 00000000000..67f367e9539
--- /dev/null
+++ b/middle_end/flambda2/types/meet_and_n_way_join.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2021 OCamlPro SAS *)
+(* Copyright 2014--2021 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(** Greatest lower bound of two types. *)
+val meet :
+ Typing_env.t ->
+ Type_grammar.t ->
+ Type_grammar.t ->
+ (Type_grammar.t * Typing_env.t) Or_bottom.t
+
+(** Least upper bound of two types. *)
+val join :
+ ?bound_name:Name.t ->
+ Typing_env.Join_env.t ->
+ Type_grammar.t ->
+ Type_grammar.t ->
+ Type_grammar.t Or_unknown.t
+
+val meet_shape :
+ Typing_env.t ->
+ Type_grammar.t ->
+ shape:Type_grammar.t ->
+ Typing_env.t Or_bottom.t
+
+(* This function has a slightly different interface; it is meant to be used only
+ by functions in Typing_env *)
+val meet_type :
+ Typing_env.t ->
+ Type_grammar.t ->
+ Type_grammar.t ->
+ (Type_grammar.t Typing_env.meet_return_value * Typing_env.t) Or_bottom.t
From 62520811f85ffb580d05d2a612b3ec219cfa1e8b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Wed, 20 Nov 2024 09:08:35 +0100
Subject: [PATCH 02/12] flambda2-types: New n-way join algorithm
The existing join algorithm suffers from several drawbacks:
- It can be slow due to the use of a quadratic algorithm, taking up to
60% of the total compilation time in -O3 mode in pathological cases
(lambda_to_flambda_primitives.ml). See also #3300.
- It is inefficient as it computes the join of all types appearing in
*any* joined environment prior to filtering out the types that are
not needed, instead of first computing the types whose join will be
needed.
- It is sensitive to the names of local variables that only exist in
some of the joined environments but not in the target environment.
- It relies on a global binding time of variables across all joined
environments and the target environment that does not exist, as
figured in #3278. Subsequently, it can lose aliasing information,
and breaks typing env invariants by recording the same variable as
defined multiple times (with dubious semantics).
This patch implements a new join algorithm, based on a n-way join of types.
The new algorithm is:
- Faster, as it avoids quadratic complexity (outside of complex nesting
of env extensions). Compared to the existing join algorithm (with
advanced meet), on my machine, the new join algorithm is 30x faster
on the pathological lambda_to_flambda_primitives.ml, taking only
around 10% of the total compilation time and speeding up the
compilation of the file by 3.5x. On camlinternalFormat.ml, the new
join is about 2.5-3x faster, reducing the time spent in the join from
20% to less than 10% and speeding up the total compilation time by
about 20%.
- More efficient, as it only computes a join if it can possibly result
in a more precise type, i.e. if the variable has been assigned a new
type in all joined environments (otherwise the existing type in the
target environment is already the most precise).
- Independent of the names of local variables.
- Only depends on a consistent binding time *order* of the shared
variables (defined in both the target environment and all joined
environments), which is respected. Since the result is independent of
the binding times of local / existential variables, the typing env
invariants are respected.
---
middle_end/flambda2/tests/meet_test.ml | 153 +-
middle_end/flambda2/types/env/join_env.ml | 972 +++++++++
middle_end/flambda2/types/env/join_env.mli | 45 +
.../flambda2/types/env/typing_env_level.ml | 39 +-
.../flambda2/types/equal_types_for_debug.ml | 497 +++++
.../flambda2/types/equal_types_for_debug.mli | 60 +
middle_end/flambda2/types/flambda2_types.ml | 10 +
middle_end/flambda2/types/flambda2_types.mli | 7 +
middle_end/flambda2/types/join_levels.ml | 349 +--
middle_end/flambda2/types/join_levels_old.ml | 338 +++
middle_end/flambda2/types/join_levels_old.mli | 27 +
.../flambda2/types/meet_and_n_way_join.ml | 1895 ++++++++++-------
.../flambda2/types/meet_and_n_way_join.mli | 12 +-
13 files changed, 3351 insertions(+), 1053 deletions(-)
create mode 100644 middle_end/flambda2/types/env/join_env.ml
create mode 100644 middle_end/flambda2/types/env/join_env.mli
create mode 100644 middle_end/flambda2/types/equal_types_for_debug.ml
create mode 100644 middle_end/flambda2/types/equal_types_for_debug.mli
create mode 100644 middle_end/flambda2/types/join_levels_old.ml
create mode 100644 middle_end/flambda2/types/join_levels_old.mli
diff --git a/middle_end/flambda2/tests/meet_test.ml b/middle_end/flambda2/tests/meet_test.ml
index 0af29852d5a..807dbf95e2d 100644
--- a/middle_end/flambda2/tests/meet_test.ml
+++ b/middle_end/flambda2/tests/meet_test.ml
@@ -139,6 +139,153 @@ let meet_variants_don't_lose_aliases () =
Format.eprintf "@[<hov 2>meet:@ %a@]@.@[<hov 2>env:@ %a@]@." T.print
tag_meet_ty TE.print tag_meet_env)
+let test_join_with_extensions () =
+ let define ?(kind = K.value) env v =
+ let v' = Bound_var.create v Name_mode.normal in
+ TE.add_definition env (Bound_name.create_var v') kind
+ in
+ let env = create_env () in
+ let y = Variable.create "y" in
+ let x = Variable.create "x" in
+ let a = Variable.create "a" in
+ let b = Variable.create "b" in
+ let env = define env y in
+ let env = define env x in
+ let env = define ~kind:K.naked_immediate env a in
+ let env = define ~kind:K.naked_immediate env b in
+ let tag_0 = Tag.Scannable.zero in
+ let tag_1 = Option.get (Tag.Scannable.of_tag (Tag.create_exn 1)) in
+ let make ty =
+ T.variant
+ ~const_ctors:(T.bottom K.naked_immediate)
+ ~non_const_ctors:
+ (Tag.Scannable.Map.of_list
+ [ tag_0, (K.Block_shape.Scannable Value_only, [ty]);
+ tag_1, (K.Block_shape.Scannable Value_only, []) ])
+ Alloc_mode.For_types.heap
+ in
+ let env = TE.add_equation env (Name.var y) (make (T.unknown K.value)) in
+ let scope = TE.current_scope env in
+ let scoped_env = TE.increment_scope env in
+ let left_env =
+ TE.add_equation scoped_env (Name.var x)
+ (T.tagged_immediate_alias_to ~naked_immediate:a)
+ in
+ let right_env =
+ TE.add_equation scoped_env (Name.var x)
+ (T.tagged_immediate_alias_to ~naked_immediate:b)
+ in
+ let ty_a = make (T.tagged_immediate_alias_to ~naked_immediate:a) in
+ let ty_b = make (T.tagged_immediate_alias_to ~naked_immediate:b) in
+ let left_env = TE.add_equation left_env (Name.var y) ty_a in
+ let right_env =
+ match T.meet right_env ty_a ty_b with
+ | Ok (ty, right_env) -> TE.add_equation right_env (Name.var y) ty
+ | Bottom -> assert false
+ in
+ Format.eprintf "Left:@.%a@." TE.print left_env;
+ Format.eprintf "Right:@.%a@." TE.print right_env;
+ let joined_env =
+ T.cut_and_n_way_join scoped_env
+ [ left_env, Apply_cont_rewrite_id.create (), Inlinable;
+ right_env, Apply_cont_rewrite_id.create (), Inlinable ]
+ ~params:Bound_parameters.empty ~cut_after:scope
+ ~extra_allowed_names:Name_occurrences.empty
+ ~extra_lifted_consts_in_use_envs:Symbol.Set.empty
+ in
+ Format.eprintf "Res:@.%a@." TE.print joined_env
+
+let test_join_with_complex_extensions () =
+ let define ?(kind = K.value) env v =
+ let v' = Bound_var.create v Name_mode.normal in
+ TE.add_definition env (Bound_name.create_var v') kind
+ in
+ let env = create_env () in
+ let y = Variable.create "y" in
+ let x = Variable.create "x" in
+ let w = Variable.create "w" in
+ let z = Variable.create "z" in
+ let a = Variable.create "a" in
+ let b = Variable.create "b" in
+ let c = Variable.create "c" in
+ let d = Variable.create "d" in
+ let env = define env z in
+ let env = define env x in
+ let env = define env y in
+ let env = define env w in
+ let env = define ~kind:K.naked_immediate env a in
+ let env = define ~kind:K.naked_immediate env b in
+ let env = define ~kind:K.naked_immediate env c in
+ let env = define ~kind:K.naked_immediate env d in
+ let tag_0 = Tag.Scannable.zero in
+ let tag_1 = Option.get (Tag.Scannable.of_tag (Tag.create_exn 1)) in
+ let make tys =
+ T.variant
+ ~const_ctors:(T.bottom K.naked_immediate)
+ ~non_const_ctors:
+ (Tag.Scannable.Map.of_list
+ [ tag_0, (K.Block_shape.Scannable Value_only, tys);
+ tag_1, (K.Block_shape.Scannable Value_only, []) ])
+ Alloc_mode.For_types.heap
+ in
+ let env =
+ TE.add_equation env (Name.var z)
+ (make [T.unknown K.value; T.unknown K.value])
+ in
+ let scope = TE.current_scope env in
+ let scoped_env = TE.increment_scope env in
+ let left_env =
+ TE.add_equation scoped_env (Name.var x)
+ (T.tagged_immediate_alias_to ~naked_immediate:a)
+ in
+ let left_env =
+ TE.add_equation left_env (Name.var y)
+ (T.tagged_immediate_alias_to ~naked_immediate:a)
+ in
+ let left_env =
+ TE.add_equation left_env (Name.var w)
+ (T.tagged_immediate_alias_to ~naked_immediate:a)
+ in
+ let right_env =
+ TE.add_equation scoped_env (Name.var x)
+ (T.tagged_immediate_alias_to ~naked_immediate:b)
+ in
+ let right_env =
+ TE.add_equation right_env (Name.var y)
+ (T.tagged_immediate_alias_to ~naked_immediate:c)
+ in
+ let right_env =
+ TE.add_equation right_env (Name.var w)
+ (T.tagged_immediate_alias_to ~naked_immediate:d)
+ in
+ let ty_a =
+ make
+ [ T.tagged_immediate_alias_to ~naked_immediate:b;
+ T.tagged_immediate_alias_to ~naked_immediate:b ]
+ in
+ let ty_b =
+ make
+ [ T.tagged_immediate_alias_to ~naked_immediate:c;
+ T.tagged_immediate_alias_to ~naked_immediate:d ]
+ in
+ let left_env = TE.add_equation left_env (Name.var z) ty_a in
+ let right_env =
+ match T.meet right_env ty_a ty_b with
+ | Ok (ty, right_env) -> TE.add_equation right_env (Name.var z) ty
+ | Bottom -> assert false
+ in
+ Format.eprintf "Left:@.%a@." TE.print left_env;
+ Format.eprintf "Right:@.%a@." TE.print right_env;
+ let joined_env =
+ T.cut_and_n_way_join scoped_env
+ [ left_env, Apply_cont_rewrite_id.create (), Inlinable;
+ right_env, Apply_cont_rewrite_id.create (), Inlinable ]
+ ~params:Bound_parameters.empty ~cut_after:scope
+ ~extra_allowed_names:Name_occurrences.empty
+ ~extra_lifted_consts_in_use_envs:Symbol.Set.empty
+ in
+ Format.eprintf "Res:@.%a@." TE.print joined_env
+
let test_meet_two_blocks () =
let define env v =
let v' = Bound_var.create v Name_mode.normal in
@@ -272,4 +419,8 @@ let () =
Format.eprintf "@.MEET ALIAS TO RECOVER @\n@.";
test_meet_recover_alias ();
Format.eprintf "@.MEET BOTTOM AFTER ALIAS@\n@.";
- test_meet_bottom_after_alias ()
+ test_meet_bottom_after_alias ();
+ Format.eprintf "@.JOIN WITH EXTENSIONS@\n@.";
+ test_join_with_extensions ();
+ Format.eprintf "@.JOIN WITH COMPLEX EXTENSIONS@\n@.";
+ test_join_with_complex_extensions ()
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
new file mode 100644
index 00000000000..114f3f86fc5
--- /dev/null
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -0,0 +1,972 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2013--2025 OCamlPro SAS *)
+(* Copyright 2014--2025 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+module K = Flambda_kind
+module TG = Type_grammar
+module TE = Typing_env
+module TEE = Typing_env_extension
+module TEL = Typing_env_level
+module ET = Expand_head.Expanded_type
+
+(* This file implements the join of typing envs, or more precisely of typing env
+ levels.
+
+ Most of it is actually concerned with the join of aliases, although some of
+ it is also taking care of robustly computing the join of env extensions and
+ nested env extensions.
+
+ In the following, we will call the "target env" the environment that is the
+ result of the join, and the "joined envs" the distinct environments that are
+ being joined.
+
+ We perform a full n-way join in four steps:
+
+ 1) Process all demotions in the joined envs, building a relation between a
+ variable in the target env and its canonical name in each of the joined envs.
+
+ 2) Compute shared demotions by detecting variables in the target env that
+ have the same canonicals in all of the joined envs. This relies on all
+ environments having a consistent binding times for the *shared variables*
+ (i.e. the variables that are defined in the target environment) in order to
+ avoid accidental quadratic complexity.
+
+ At this point, we have found all the aliases between existing variables in
+ the target env. It remains to compute the type information.
+
+ 3) Process all the non-alias type information in the joined envs, building a
+ relation between a canonical variable in the target env and its new types in
+ each of the joined envs. If a variable has been demoted in one of the joined
+ envs but not in the target env as part of the previous step, treat it as if
+ it had received the current type of its canonical in the joined env instead.
+
+ For instance, if we add the type "= x" to a variable [p] in one joined env
+ (demoting [p] to [x]) and we add a non-alias type [ty] to [p] in the other
+ joined env, we will compute the join of [ty] and the type of [x] in the first
+ joined env to assign to [p] in the target env.
+
+ 4) For any variable that has been assigned a new type in all the joined envs
+ in the previous step, compute its new type in the target env by joining its
+ types in all the joined envs. If there is at least one joined env where the
+ variable did not get a new type, the result of the join can never be more
+ precise than that type, which is also the original type of the variable in
+ the target env. *)
+
+module Index : sig
+ include Container_types.S
+
+ val zero : t
+
+ val succ : t -> t
+end = struct
+ include Numeric_types.Int
+
+ let zero = 0
+
+ let succ n = n + 1
+end
+
+module Join_aliases : sig
+ type t
+
+ val empty : t
+
+ (** [find ~mem_name ~is_bound_strictly_earlier simples t] is:
+
+ - [Bottom] if [simples] is empty;
+ - [Ok simple] if there is a [simple] that is equal to each of the [simples]
+ in the corresponding environment, or otherwise an existential variable
+ introduced with [add_existential_var] for this set of [simples];
+ - [Unknown] otherwise.
+
+ [mem_name] should return [true] if the name is defined in the target
+ environment (false if it is a local variable of a joined environment).
+
+ [is_bound_strictly_earlier] determines whether a {b shared} name (i.e.
+ defined in the target env and in all joined envs) is bound earlier than
+ a {b shared} simple. Recall that we require a consistent ordering on
+ shared names.
+
+ {b Note}: the [simples] must be canonical in their environment. *)
+ val find :
+ mem_name:(Name.t -> bool) ->
+ is_bound_strictly_earlier:(Name.t -> than:Simple.t -> bool) ->
+ Simple.t Index.Map.t ->
+ t ->
+ Simple.t Or_unknown_or_bottom.t
+
+ (** [add_existential_var ~mem_name simples t] returns a fresh variable [var]
+ and an updated [t] where [var] is associated with the [simples]. *)
+ val add_existential_var :
+ mem_name:(Name.t -> bool) -> Simple.t Index.Map.t -> t -> Variable.t * t
+
+ type 'a add_result =
+ { values_in_target_env : 'a Index.Map.t Variable.Map.t;
+ touched_variables : Variable.Set.t
+ }
+
+ (** [add_in_target_env ~mem_name t values values_in_target_env] adds the values
+ in [values], keyed by their name in the corresponding environment, to the
+ [values_in_target_env], keyed with their name in the target environment.
+
+ More precisely, if there is an entry [index -> var -> value] in [values],
+ an entry [target_var -> index -> value] is added to [values_in_target_env]
+ for all variables [target_var] in the target environment that are equal to
+ [var] in the joined environment at [index]. *)
+ val add_in_target_env :
+ mem_name:(Name.t -> bool) ->
+ t ->
+ 'a Variable.Map.t Index.Map.t ->
+ 'a Index.Map.t Variable.Map.t ->
+ 'a add_result
+
+ type join_result = private
+ { demoted_in_target_env : Simple.t Variable.Map.t;
+ (** Variables that should be demoted in the target env as a result of the
+ join.
+
+ The demoted variables are no longer present in [t]. *)
+ demoted_in_some_envs : Simple.t Index.Map.t Variable.Map.t;
+ (** Variables that have been demoted in some (possibly all, if
+ they have been demoted to distinct canonicals) of the joined
+ environments, but not in the target enviroment.
+
+ These are still present in [t], but they need to be considered for
+ the join of types. *)
+ t : t
+ }
+
+ val n_way_join :
+ mem_name:(Name.t -> bool) ->
+ is_bound_strictly_earlier:(Name.t -> than:Simple.t -> bool) ->
+ t ->
+ Simple.t Variable.Map.t Index.Map.t ->
+ join_result Or_bottom.t
+end = struct
+ module Indexed_simple = Container_types.Make (struct
+ type t = Simple.t Index.Map.t
+
+ let print = Index.Map.print Simple.print
+
+ let hash map =
+ Index.Map.fold
+ (fun index simple hash ->
+ Hashtbl.hash (hash, Index.hash index, Simple.hash simple))
+ map (Hashtbl.hash 0)
+
+ let equal = Index.Map.equal Simple.equal
+
+ let compare = Index.Map.compare Simple.compare
+ end)
+
+ module ISM = Indexed_simple.Map
+
+ type t =
+ { joined_simples : Variable.t ISM.t;
+ (** Maps a tuple of simples in the joined environments to the variable
+ that represents it in the target environment, if any.
+
+ If there is a mapping [simples -> var] in [joined_simples], then
+ [demoted_from_target_env(var) = simples]. *)
+ demoted_from_target_env : Simple.t Index.Map.t Variable.Map.t;
+ (** Maps a variable defined in the target environment to its
+ canonicals in each joined environment {b where it has been
+ demoted}.
+
+ Missing entries in the map means that the variable has not been
+ demoted in the corresponding environment.
+
+ We assume that the binding time order for shared variables (i.e.
+ variables that are present in the target environment and in all
+ joined environments) is consistent across all environments.
+
+ When given a set of simples in all environments, this allows us
+ to find the appropriate variable quickly: if this set of simple
+ is the set of canonicals for a shared variable, it can only be
+ the case for the shared variable with the latest binding time
+ (because a shared variable with an earlier binding time can never
+ be demoted to a shared variable with a later binding time). *)
+ names_in_target_env : Variable.Set.t Variable.Map.t Index.Map.t
+ (** Maps a variable in a joined environment to the set of
+ (other) variables it is equal to in the target environment. *)
+ }
+
+ let empty =
+ { joined_simples = ISM.empty;
+ demoted_from_target_env = Variable.Map.empty;
+ names_in_target_env = Index.Map.empty
+ }
+
+ let find ~mem_name ~is_bound_strictly_earlier (simples : Simple.t Index.Map.t)
+ t : _ Or_unknown_or_bottom.t =
+ let[@inline] mem_simple simple =
+ Simple.pattern_match simple
+ ~const:(fun _ -> true)
+ ~name:(fun name ~coercion:_ -> mem_name name)
+ in
+ (* We need to determine if the provided set of simples (which are assumed to
+ be canonicals in their own environment) has an existing name in the
+ target environment.
+
+ This existing name might be:
+
+ 1) A constant or symbol, which can only happen if all the joined simples
+ are equal; or
+
+ 2) A shared variable demoted in zero or more, but not all, environments;
+ or
+
+ 3) A shared variable demoted in all environments; or
+
+ 4) An existential variable previously created for this exact set of
+ simples.
+
+ To detect case 1), we need to pick one of the simples and check that is
+ it a) equal to all the other simples and b) exists in the target
+ environment.
+
+ To detect case 3) and 4), we make a lookup in the [join_simples] table.
+
+ To detect case 2), it is not enough to check that all the simples are
+ identical, because the shared variable might have been demoted in one but
+ not all environments, and performing a partial lookup in the
+ [join_simples] table (or pre-populating it) would give the join quadratic
+ complexity globally.
+
+ Instead, we exploit the fact that {b shared} variables are defined in the
+ same order in all environments: if the simples are equal to a shared
+ variable that has been demoted in some, but not all, environments, there
+ is at least one simple that is equal to that variable, and it is
+ necessary the latest bound shared variable because we can only demote to
+ variables that were bound earlier.
+
+ The code below computes the latest bound simple (considering that
+ constants and symbols are bound at an identical -oo binding time) that is
+ defined in the target environment to combine tests for cases 1) and
+ 2). *)
+ let latest_bound_simple =
+ Index.Map.fold
+ (fun _ simple acc : _ Or_unknown_or_bottom.t ->
+ match (acc : _ Or_unknown_or_bottom.t) with
+ | Bottom | Unknown -> if mem_simple simple then Ok simple else Unknown
+ | Ok existing_simple -> (
+ match Simple.must_be_var simple with
+ | None -> acc
+ | Some (var, _coercion) ->
+ if mem_name (Name.var var)
+ then
+ (* NB: These are not actually aliases in the target env yet. *)
+ if is_bound_strictly_earlier (Name.var var)
+ ~than:existing_simple
+ then Ok simple
+ else acc
+ else acc))
+ simples Or_unknown_or_bottom.Bottom
+ in
+ let[@local] find_local_variable () : _ Or_unknown_or_bottom.t =
+ (* When looking for an existential variable, we only look for exact
+ matches.
+
+ This means that we might end up creating more local variables than
+ would be strictly necessary, but they have more precise types. *)
+ match ISM.find_opt simples t.joined_simples with
+ | None -> Unknown
+ | Some var -> Ok (Simple.var var)
+ in
+ match latest_bound_simple with
+ | Bottom -> Bottom
+ | Unknown ->
+ (* Join of existential variables can only be case 3) or 4) *)
+ find_local_variable ()
+ | Ok latest_bound_simple -> (
+ match Simple.must_be_var latest_bound_simple with
+ | None ->
+ (* Case 1), 3), or 4) *)
+ if Index.Map.for_all
+ (fun _ simple -> Simple.equal simple latest_bound_simple)
+ simples
+ then Ok latest_bound_simple
+ else find_local_variable ()
+ | Some (var, coercion) ->
+ (* Case 2), 3), or 4) *)
+ let coercion_to_var = Coercion.inverse coercion in
+ let earlier_bound_simples =
+ Index.Map.filter_map
+ (fun _ simple ->
+ if Simple.equal simple latest_bound_simple
+ then None
+ else Some (Simple.apply_coercion_exn simple coercion_to_var))
+ simples
+ in
+ let canonicals_for_var =
+ Option.value ~default:Index.Map.empty
+ (Variable.Map.find_opt var t.demoted_from_target_env)
+ in
+ (* Consider the case where we have [a -> (1:b, 2:c)], i.e. [a] has been
+ demoted to [b] in environment [1] and to [c] in environment [2], but
+ was not demoted in environment [0].
+
+ Suppose we are looking for a name for the tuple [(0:a, 1:b)] where
+ environment [2] is not present, because we are in a situation (e.g.
+ tag of a variant) which is impossible in environment [2].
+
+ We want to recognize this as being equal to [a], which we can do by
+ restricting the canonicals of [a] to those of the environments for
+ which we are making a lookup.
+
+ Note that an alternative would be to create a new existential
+ variable for the pair [(0:a, 1:b)], which could get a more precise
+ type. We can't record both informations without introducing an env
+ extension, so we favor preserving equalities for variables defined in
+ the target env and precision for existential variables (cf
+ [find_local_variable]). *)
+ let canonicals_for_var =
+ Index.Map.inter
+ (fun _ _ canonical -> canonical)
+ simples canonicals_for_var
+ in
+ if Index.Map.equal Simple.equal earlier_bound_simples canonicals_for_var
+ then Ok latest_bound_simple
+ else find_local_variable ())
+
+ let add_existential_var ~mem_name simples t =
+ let shared_name =
+ try
+ Index.Map.fold
+ (fun _ simple raw_name ->
+ Simple.pattern_match' simple
+ ~const:(fun _ -> raw_name)
+ ~symbol:(fun _ ~coercion:_ -> raw_name)
+ ~var:(fun var ~coercion:_ ->
+ let var_name = Variable.raw_name var in
+ match raw_name with
+ | None -> Some var_name
+ | Some raw_name when String.equal raw_name var_name ->
+ Some raw_name
+ | Some _ -> raise Not_found))
+ simples None
+ with Not_found -> None
+ in
+ let raw_name =
+ match shared_name with Some raw_name -> raw_name | None -> "join_var"
+ in
+ let var = Variable.create raw_name in
+ let joined_simples = ISM.add simples var t.joined_simples in
+ let demoted_from_target_env =
+ Variable.Map.add var simples t.demoted_from_target_env
+ in
+ let names_in_target_env =
+ Index.Map.fold
+ (fun index simple names_in_target_env ->
+ match Simple.must_be_var simple with
+ | Some (joined_var, coercion)
+ when Coercion.is_id coercion && mem_name (Name.var joined_var) ->
+ Index.Map.update index
+ (fun names_from_this_env_in_target_env ->
+ let names_from_this_env_in_target_env =
+ Option.value ~default:Variable.Map.empty
+ names_from_this_env_in_target_env
+ in
+ Some
+ (Variable.Map.update joined_var
+ (function
+ | None -> Some (Variable.Set.singleton var)
+ | Some existing_vars ->
+ Some (Variable.Set.add var existing_vars))
+ names_from_this_env_in_target_env))
+ names_in_target_env
+ | _ -> names_in_target_env)
+ simples t.names_in_target_env
+ in
+ var, { joined_simples; names_in_target_env; demoted_from_target_env }
+
+ let find_canonicals demoted_var t =
+ match Variable.Map.find_opt demoted_var t.demoted_from_target_env with
+ | Some canonicals -> canonicals
+ | None ->
+ Misc.fatal_errorf "Variable %a was not demoted." Variable.print
+ demoted_var
+
+ let forget_demoted_var demoted_var t =
+ (* [demoted_var] is demoted to [simple] in all environments.
+
+ Remove it from all maps (except [map_to_canonical], which records the
+ demotion) -- for all intents and purposes, we only need to consider the
+ canonical [simple]. *)
+ let canonicals = find_canonicals demoted_var t in
+ let demoted_from_target_env =
+ Variable.Map.remove demoted_var t.demoted_from_target_env
+ in
+ let names_in_target_env =
+ Index.Map.fold
+ (fun index simple names_in_target_env ->
+ match Simple.must_be_var simple with
+ | Some (var, coercion) when Coercion.is_id coercion ->
+ Index.Map.update index
+ (fun names_for_index ->
+ let names_for_index =
+ Option.value ~default:Variable.Map.empty names_for_index
+ in
+ let names_for_index =
+ Variable.Map.update var
+ (fun names ->
+ let names =
+ Option.value ~default:Variable.Set.empty names
+ in
+ let names = Variable.Set.remove demoted_var names in
+ if Variable.Set.is_empty names then None else Some names)
+ names_for_index
+ in
+ if Variable.Map.is_empty names_for_index
+ then None
+ else Some names_for_index)
+ names_in_target_env
+ | _ -> names_in_target_env)
+ canonicals t.names_in_target_env
+ in
+ { t with demoted_from_target_env; names_in_target_env }
+
+ let expand_to_names_in_target_env ~mem_name ~update_names names_in_target_env
+ table acc =
+ Index.Map.fold
+ (fun index values (acc, names_in_target_env, touched_vars) ->
+ let names_from_this_env_in_target_env =
+ Option.value ~default:Variable.Map.empty
+ (Index.Map.find_opt index names_in_target_env)
+ in
+ let acc, names_from_this_env_in_target_env, touched_vars =
+ Variable.Map.fold
+ (fun var value
+ (acc, names_from_this_env_in_target_env, touched_vars) ->
+ let vars_in_target_env =
+ Option.value ~default:Variable.Set.empty
+ (Variable.Map.find_opt var names_from_this_env_in_target_env)
+ in
+ let vars_in_target_env =
+ if mem_name (Name.var var)
+ then Variable.Set.add var vars_in_target_env
+ else vars_in_target_env
+ in
+ let names_from_this_env_in_target_env =
+ update_names var vars_in_target_env value
+ names_from_this_env_in_target_env
+ in
+ let acc =
+ Variable.Set.fold
+ (fun var_in_target_env values ->
+ Variable.Map.update var_in_target_env
+ (function
+ | None -> Some (Index.Map.singleton index value)
+ | Some values_in_other_envs ->
+ Some (Index.Map.add index value values_in_other_envs))
+ values)
+ vars_in_target_env acc
+ in
+ ( acc,
+ names_from_this_env_in_target_env,
+ Variable.Set.union vars_in_target_env touched_vars ))
+ values
+ (acc, names_from_this_env_in_target_env, touched_vars)
+ in
+ ( acc,
+ Index.Map.add index names_from_this_env_in_target_env
+ names_in_target_env,
+ touched_vars ))
+ table
+ (acc, names_in_target_env, Variable.Set.empty)
+
+ type 'a add_result =
+ { values_in_target_env : 'a Index.Map.t Variable.Map.t;
+ touched_variables : Variable.Set.t
+ }
+
+ let add_in_target_env ~mem_name t table values_by_index =
+ let values_in_target_env, _names_in_target_env, touched_variables =
+ expand_to_names_in_target_env ~mem_name
+ ~update_names:(fun _ _ _ names -> names)
+ t.names_in_target_env table values_by_index
+ in
+ { values_in_target_env; touched_variables }
+
+ type join_result =
+ { demoted_in_target_env : Simple.t Variable.Map.t;
+ demoted_in_some_envs : Simple.t Index.Map.t Variable.Map.t;
+ t : t
+ }
+
+ let n_way_join0 ~mem_name ~is_bound_strictly_earlier t all_demotions =
+ let demoted_from_target_env, names_in_target_env, touched_vars =
+ expand_to_names_in_target_env ~mem_name
+ ~update_names:
+ (fun demoted_var names_of_demoted_in_target_env canonical_simple
+ names_from_this_env_in_target_env ->
+ let names_from_this_env_in_target_env =
+ Variable.Map.remove demoted_var names_from_this_env_in_target_env
+ in
+ match Simple.must_be_var canonical_simple with
+ | Some (canonical_var, coercion)
+ when Coercion.is_id coercion && mem_name (Name.var canonical_var) ->
+ Variable.Map.update canonical_var
+ (function
+ | None -> Some names_of_demoted_in_target_env
+ | Some existing_vars ->
+ Some
+ (Variable.Set.union existing_vars
+ names_of_demoted_in_target_env))
+ names_from_this_env_in_target_env
+ | _ -> names_from_this_env_in_target_env)
+ t.names_in_target_env all_demotions t.demoted_from_target_env
+ in
+ let t = { t with demoted_from_target_env; names_in_target_env } in
+ let all_indices = Index.Map.keys all_demotions in
+ Variable.Set.fold
+ (fun demoted_var { demoted_in_target_env; demoted_in_some_envs; t } ->
+ let canonicals = find_canonicals demoted_var t in
+ let[@local] is_demoted_in_some_envs t =
+ let demoted_in_some_envs =
+ Variable.Map.add demoted_var canonicals demoted_in_some_envs
+ in
+ { demoted_in_target_env; demoted_in_some_envs; t }
+ in
+ let[@local] is_demoted_in_all_envs t =
+ let joined_simples =
+ ISM.add canonicals demoted_var t.joined_simples
+ in
+ is_demoted_in_some_envs { t with joined_simples }
+ in
+ let[@local] is_demoted_in_target_env canonical t =
+ let t = forget_demoted_var demoted_var t in
+ let demoted_in_target_env =
+ Variable.Map.add demoted_var canonical demoted_in_target_env
+ in
+ { demoted_in_target_env; demoted_in_some_envs; t }
+ in
+ (* We keep stale entries in the [joined_simples] table here, which is OK
+ because we never iterate on it and we never look them up anymore
+ since they are non-canonical in at least one of the joined
+ environments.
+
+ This can only happen in the presence of env extensions. *)
+ if not (Index.Set.subset all_indices (Index.Map.keys canonicals))
+ then is_demoted_in_some_envs t
+ else
+ match find ~mem_name ~is_bound_strictly_earlier canonicals t with
+ | Bottom ->
+ Misc.fatal_error
+ "Unexpected bottom for non-empty set of canonicals."
+ | Unknown -> is_demoted_in_all_envs t
+ | Ok simple -> is_demoted_in_target_env simple t)
+ touched_vars
+ { demoted_in_target_env = Variable.Map.empty;
+ demoted_in_some_envs = Variable.Map.empty;
+ t
+ }
+
+ let n_way_join ~mem_name ~is_bound_strictly_earlier t all_demotions =
+ if Index.Map.is_empty all_demotions
+ then Or_bottom.Bottom
+ else
+ Or_bottom.Ok
+ (n_way_join0 ~mem_name ~is_bound_strictly_earlier t all_demotions)
+end
+
+module Join_equations = struct
+ (** Maps a variable in the target environment to its {b updated} types in the
+ joined environments.
+
+ If the variable did not receive a new type (either explicitly or through demotion)
+ in a given environment, the corresponding entry is absent.
+
+ {b Note}: A variable can have a more precise joined type if, and only if,
+ it has been given a new type in {b all} the joined environments. *)
+ type t = ET.t Index.Map.t Variable.Map.t
+
+ let empty = Variable.Map.empty
+
+ let find var t =
+ Option.value ~default:Index.Map.empty (Variable.Map.find_opt var t)
+
+ let n_way_join ~n_way_join_type vars equations st =
+ Variable.Map.fold
+ (fun var types (equations, st) ->
+ let types =
+ Index.Map.fold
+ (fun index expanded acc -> (index, ET.to_type expanded) :: acc)
+ types []
+ in
+ match (n_way_join_type st types : _ Or_unknown.t * _) with
+ | Unknown, st -> equations, st
+ | Known ty, st -> Variable.Map.add var ty equations, st)
+ vars (equations, st)
+
+ let add_joined_simple ~joined_envs demoted_var canonicals joined_types =
+ Variable.Map.update demoted_var
+ (fun types_of_demoted_var ->
+ let types_of_demoted_var =
+ Option.value ~default:Index.Map.empty types_of_demoted_var
+ in
+ let types_of_demoted_var =
+ Index.Map.fold
+ (fun index canonical types_of_demoted_var ->
+ let env = Index.Map.find index joined_envs in
+ let ty =
+ Simple.pattern_match canonical
+ ~const:More_type_creators.type_for_const
+ ~name:(fun name ~coercion ->
+ TG.apply_coercion (TE.find env name None) coercion)
+ in
+ let expanded =
+ Expand_head.expand_head0 env ty
+ ~known_canonical_simple_at_in_types_mode:(Some canonical)
+ in
+ Index.Map.add index expanded types_of_demoted_var)
+ canonicals types_of_demoted_var
+ in
+ Some types_of_demoted_var)
+ joined_types
+end
+
+module Symbol_projection = struct
+ include Symbol_projection
+ include Container_types.Make (Symbol_projection)
+end
+
+let n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
+ join_aliases joined_envs all_symbol_projections =
+ let joined_projections =
+ Index.Map.fold
+ (fun index symbol_projections acc ->
+ let typing_env = Index.Map.find index joined_envs in
+ Variable.Map.fold
+ (fun var symbol_projection acc ->
+ let canonical =
+ TE.get_canonical_simple_exn typing_env (Simple.var var)
+ ~min_name_mode:Name_mode.in_types
+ in
+ Symbol_projection.Map.update symbol_projection
+ (function
+ | None -> Some (Index.Map.singleton index canonical)
+ | Some projections_in_other_envs ->
+ Some (Index.Map.add index canonical projections_in_other_envs))
+ acc)
+ symbol_projections acc)
+ all_symbol_projections Symbol_projection.Map.empty
+ in
+ let all_indices = Index.Map.keys joined_envs in
+ Symbol_projection.Map.fold
+ (fun symbol_projection simples symbol_projections ->
+ if not (Index.Set.subset all_indices (Index.Map.keys simples))
+ then symbol_projections
+ else
+ match
+ Join_aliases.find ~mem_name ~is_bound_strictly_earlier simples
+ join_aliases
+ with
+ | Bottom | Unknown -> symbol_projections
+ | Ok simple -> (
+ match Simple.must_be_var simple with
+ | Some (var, coercion) when Coercion.is_id coercion ->
+ Variable.Map.add var symbol_projection symbol_projections
+ | _ -> symbol_projections))
+ joined_projections Variable.Map.empty
+
+type t =
+ { join_aliases : Join_aliases.t;
+ join_types : Join_equations.t;
+ existential_vars : K.t Variable.Map.t;
+ pending_vars : Simple.t Index.Map.t Variable.Map.t;
+ (* Existential variables that have been defined by their names in all the
+ joined environment, but whose type has not yet been computed. *)
+ joined_envs : TE.t Index.Map.t;
+ (* Currently active joined environments.
+
+ {b Note}: This can be a subset of all the actual joined environments when
+ performing a join inside env extensions. *)
+ target_env : TE.t
+ }
+
+type join_result =
+ { demoted_in_target_env : Simple.t Variable.Map.t;
+ extra_variables : K.t Variable.Map.t;
+ equations : TG.t Variable.Map.t;
+ symbol_projections : Symbol_projection.t Variable.Map.t
+ }
+
+let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
+ let all_demotions, all_expanded_equations, all_symbol_projections =
+ Index.Map.fold
+ (fun index level
+ (all_demotions, all_expanded_equations, all_symbol_projections) ->
+ let symbol_projections = TEL.symbol_projections level in
+ let equations = TEL.equations level in
+ let typing_env = Index.Map.find index t.joined_envs in
+ let demotions, expanded_equations =
+ Name.Map.fold
+ (fun name ty (demotions, expanded_equations) ->
+ match Name.must_be_var_opt name with
+ | None -> demotions, expanded_equations
+ | Some var -> (
+ match
+ TE.get_alias_then_canonical_simple_exn
+ ~min_name_mode:Name_mode.in_types typing_env ty
+ with
+ | canonical_simple ->
+ ( Variable.Map.add var canonical_simple demotions,
+ expanded_equations )
+ | exception Not_found ->
+ let expanded =
+ Expand_head.expand_head0 typing_env ty
+ ~known_canonical_simple_at_in_types_mode:
+ (Some (Simple.var var))
+ in
+ demotions, Variable.Map.add var expanded expanded_equations))
+ equations
+ (Variable.Map.empty, Variable.Map.empty)
+ in
+ ( Index.Map.add index demotions all_demotions,
+ Index.Map.add index expanded_equations all_expanded_equations,
+ Index.Map.add index symbol_projections all_symbol_projections ))
+ all_levels
+ (Index.Map.empty, Index.Map.empty, Index.Map.empty)
+ in
+ let mem_name = TE.mem ~min_name_mode:Name_mode.in_types t.target_env in
+ let is_bound_strictly_earlier name ~than =
+ TE.alias_is_bound_strictly_earlier t.target_env ~bound_name:name ~alias:than
+ in
+ match
+ Join_aliases.n_way_join ~mem_name ~is_bound_strictly_earlier t.join_aliases
+ all_demotions
+ with
+ | Bottom -> Bottom
+ | Ok { demoted_in_target_env; demoted_in_some_envs; t = join_aliases } ->
+ let join_types =
+ Variable.Map.fold
+ (Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
+ demoted_in_some_envs t.join_types
+ in
+ let { Join_aliases.values_in_target_env = join_types;
+ touched_variables = touched_vars
+ } =
+ Join_aliases.add_in_target_env ~mem_name join_aliases
+ all_expanded_equations join_types
+ in
+ let touched_vars =
+ Variable.Set.union touched_vars (Variable.Map.keys demoted_in_some_envs)
+ in
+ let t = { t with join_aliases; join_types } in
+ let all_indices = Index.Map.keys t.joined_envs in
+ let equations_to_join =
+ Variable.Set.fold
+ (fun var new_vars ->
+ let types = Join_equations.find var t.join_types in
+ if not (Index.Set.subset all_indices (Index.Map.keys types))
+ then new_vars
+ else
+ (* Restrict the indices in case we are joining env extensions that
+ are not defined in all environments *)
+ let types =
+ Index.Map.inter (fun _ _ expanded -> expanded) t.joined_envs types
+ in
+ Variable.Map.add var types new_vars)
+ touched_vars Variable.Map.empty
+ in
+ let rec loop equations_to_join joined_equations t =
+ let equations, t =
+ Join_equations.n_way_join ~n_way_join_type equations_to_join
+ joined_equations t
+ in
+ if Variable.Map.is_empty t.pending_vars
+ then
+ let symbol_projections =
+ n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
+ t.join_aliases t.joined_envs all_symbol_projections
+ in
+ Or_bottom.Ok
+ { demoted_in_target_env;
+ extra_variables = t.existential_vars;
+ equations;
+ symbol_projections
+ }
+ else
+ let join_types =
+ Variable.Map.fold
+ (Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
+ t.pending_vars t.join_types
+ in
+ let equations_to_join =
+ Variable.Map.mapi
+ (fun var _ -> Join_equations.find var join_types)
+ t.pending_vars
+ in
+ let pending_vars = Variable.Map.empty in
+ loop equations_to_join equations { t with pending_vars; join_types }
+ in
+ loop equations_to_join Variable.Map.empty t
+
+let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env
+ joined_envs =
+ let _, joined_envs, joined_levels =
+ List.fold_left
+ (fun (discriminant, joined_envs, joined_levels) typing_env ->
+ let level = TE.cut typing_env ~cut_after in
+ ( Index.succ discriminant,
+ Index.Map.add discriminant typing_env joined_envs,
+ Index.Map.add discriminant level joined_levels ))
+ (Index.zero, Index.Map.empty, Index.Map.empty)
+ joined_envs
+ in
+ match
+ n_way_join_levels ~n_way_join_type
+ { join_aliases = Join_aliases.empty;
+ join_types = Join_equations.empty;
+ existential_vars = Variable.Map.empty;
+ pending_vars = Variable.Map.empty;
+ joined_envs;
+ target_env
+ }
+ joined_levels
+ with
+ | Bottom ->
+ (* Join of zero envs -- should possibly return bottom? *)
+ target_env
+ | Ok { demoted_in_target_env; extra_variables; equations; symbol_projections }
+ ->
+ let target_env =
+ Variable.Map.fold
+ (fun var kind target_env ->
+ TE.add_definition target_env
+ (Bound_name.create_var (Bound_var.create var Name_mode.in_types))
+ kind)
+ extra_variables target_env
+ in
+ let target_env =
+ Variable.Map.fold
+ (fun var simple target_env ->
+ let kind = TG.kind (TE.find target_env (Name.var var) None) in
+ let ty = TG.alias_type_of kind simple in
+ TE.add_equation ~meet_type target_env (Name.var var) ty)
+ demoted_in_target_env target_env
+ in
+ let target_env =
+ Variable.Map.fold
+ (fun var ty target_env ->
+ TE.add_equation ~meet_type target_env (Name.var var) ty)
+ equations target_env
+ in
+ let target_env =
+ Variable.Map.fold
+ (fun var symbol_projection target_env ->
+ TE.add_symbol_projection target_env var symbol_projection)
+ symbol_projections target_env
+ in
+ target_env
+
+let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
+ =
+ let joined_levels, joined_envs =
+ List.fold_left
+ (fun (joined_levels, joined_envs) (index, extension) ->
+ let parent_env = Index.Map.find index t.joined_envs in
+ (* The extension is not guaranteed to still be in canonical form, but we
+ need the equations to be in canonical form to known which variables
+ are actually touched by the extension, so we add it once then cut it.
+
+ Note: we need to cut it as a level, because the meets from
+ [add_env_extension_strict] could add perform nested joins which could
+ add new variables. *)
+ assert (not (TE.is_bottom parent_env));
+ let cut_after = TE.current_scope parent_env in
+ let typing_env = TE.increment_scope parent_env in
+ match TE.add_env_extension_strict ~meet_type typing_env extension with
+ | Bottom ->
+ (* We can reach bottom here if the extension was created in a more
+ generic context, but is added in a context where it is no longer
+ reachable. *)
+ joined_levels, joined_envs
+ | Ok typing_env ->
+ let level = TE.cut typing_env ~cut_after in
+ ( Index.Map.add index level joined_levels,
+ Index.Map.add index typing_env joined_envs ))
+ (Index.Map.empty, Index.Map.empty)
+ envs_with_extensions
+ in
+ match
+ n_way_join_levels ~n_way_join_type
+ { join_aliases = t.join_aliases;
+ join_types = t.join_types;
+ existential_vars = t.existential_vars;
+ pending_vars = Variable.Map.empty;
+ joined_envs;
+ target_env = t.target_env
+ }
+ joined_levels
+ with
+ | Bottom -> Or_bottom.Bottom
+ | Ok { demoted_in_target_env; extra_variables; equations; symbol_projections }
+ ->
+ if not (Variable.Map.is_empty symbol_projections)
+ then Misc.fatal_error "Unexpected symbol projections in env extension.";
+ let joined_equations =
+ Variable.Map.fold
+ (fun var simple equations ->
+ let kind =
+ match Variable.Map.find_opt var extra_variables with
+ | Some kind -> kind
+ | None -> TG.kind (TE.find t.target_env (Name.var var) None)
+ in
+ let ty = TG.alias_type_of kind simple in
+ Name.Map.add (Name.var var) ty equations)
+ demoted_in_target_env Name.Map.empty
+ in
+ let joined_equations =
+ Variable.Map.fold
+ (fun var ty equations -> Name.Map.add (Name.var var) ty equations)
+ equations joined_equations
+ in
+ (* Preserve existential vars since we can't bind them in extensions. *)
+ let existential_vars = extra_variables in
+ Or_bottom.Ok (TEE.from_map joined_equations, { t with existential_vars })
+
+let n_way_join_simples t kind simples : _ Or_bottom.t * _ =
+ let simples = Index.Map.of_list simples in
+ let mem_name = TE.mem ~min_name_mode:Name_mode.in_types t.target_env in
+ let is_bound_strictly_earlier name ~than =
+ TE.alias_is_bound_strictly_earlier t.target_env ~bound_name:name ~alias:than
+ in
+ match
+ Join_aliases.find ~mem_name ~is_bound_strictly_earlier simples
+ t.join_aliases
+ with
+ | Bottom -> Bottom, t
+ | Ok simple -> Ok simple, t
+ | Unknown ->
+ let var, join_aliases =
+ Join_aliases.add_existential_var ~mem_name simples t.join_aliases
+ in
+ let existential_vars = Variable.Map.add var kind t.existential_vars in
+ let pending_vars = Variable.Map.add var simples t.pending_vars in
+ Ok (Simple.var var), { t with existential_vars; join_aliases; pending_vars }
+
+type env_id = Index.t
+
+type 'a join_arg = env_id * 'a
+
+let target_join_env { target_env; _ } = target_env
+
+type n_way_join_type = t -> TG.t join_arg list -> TG.t Or_unknown.t * t
+
+let joined_env env index =
+ match Index.Map.find_opt index env.joined_envs with
+ | Some typing_env -> typing_env
+ | None -> Misc.fatal_error "Invalid joined environment."
diff --git a/middle_end/flambda2/types/env/join_env.mli b/middle_end/flambda2/types/env/join_env.mli
new file mode 100644
index 00000000000..ab32866a593
--- /dev/null
+++ b/middle_end/flambda2/types/env/join_env.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2013--2025 OCamlPro SAS *)
+(* Copyright 2014--2025 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+type env_id
+
+type 'a join_arg = env_id * 'a
+
+type t
+
+val target_join_env : t -> Typing_env.t
+
+val joined_env : t -> env_id -> Typing_env.t
+
+val n_way_join_simples :
+ t -> Flambda_kind.t -> Simple.t join_arg list -> Simple.t Or_bottom.t * t
+
+type n_way_join_type =
+ t -> Type_grammar.t join_arg list -> Type_grammar.t Or_unknown.t * t
+
+val n_way_join_env_extension :
+ n_way_join_type:n_way_join_type ->
+ meet_type:Typing_env.meet_type ->
+ t ->
+ Typing_env_extension.t join_arg list ->
+ (Typing_env_extension.t * t) Or_bottom.t
+
+val cut_and_n_way_join :
+ n_way_join_type:n_way_join_type ->
+ meet_type:Typing_env.meet_type ->
+ cut_after:Scope.t ->
+ Typing_env.t ->
+ Typing_env.t list ->
+ Typing_env.t
diff --git a/middle_end/flambda2/types/env/typing_env_level.ml b/middle_end/flambda2/types/env/typing_env_level.ml
index 57768fe01e5..6c6cccd022c 100644
--- a/middle_end/flambda2/types/env/typing_env_level.ml
+++ b/middle_end/flambda2/types/env/typing_env_level.ml
@@ -36,7 +36,6 @@ let find_kind t var = Variable.Map.find var t.defined_vars
let variable_is_defined t var = Variable.Map.mem var t.defined_vars
-(* CR mshinwell: print symbol projections *)
let print_equations ppf equations =
let equations = Name.Map.bindings equations in
match equations with
@@ -47,25 +46,35 @@ let print_equations ppf equations =
Format.fprintf ppf "@[<hov 1>%a@ :@ %a@]" Name.print name TG.print ty))
equations
+let print_symbol_projections ppf symbol_projections =
+ let symbol_projections = Variable.Map.bindings symbol_projections in
+ match symbol_projections with
+ | [] -> Format.pp_print_string ppf "()"
+ | _ :: _ ->
+ Format.fprintf ppf "(%a)"
+ (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (name, ty) ->
+ Format.fprintf ppf "@[<hov 1>%a@ :@ %a@]" Variable.print name
+ Symbol_projection.print ty))
+ symbol_projections
+
let [@ocamlformat "disable"] print ppf
{ defined_vars; binding_times = _; equations;
- symbol_projections = _; } =
+ symbol_projections } =
(* CR mshinwell: Print [defined_vars] when not called from
[Typing_env.print] *)
- if Variable.Map.is_empty defined_vars then
+ Format.fprintf ppf "@[<hov 1>(";
+ if not (Variable.Map.is_empty defined_vars) then
Format.fprintf ppf
- "@[<hov 1>(\
- @[<hov 1>(equations@ @[<v 1>%a@])@])\
- @]"
- print_equations equations
- else
+ "@[<hov 1>(defined_vars@ @[<hov 1>%a@])@]@ "
+ Variable.Set.print (Variable.Map.keys defined_vars);
+ if not (Variable.Map.is_empty symbol_projections) then
Format.fprintf ppf
- "@[<hov 1>(\
- @[<hov 1>(defined_vars@ @[<hov 1>%a@])@]@ \
- @[<hov 1>(equations@ @[<v 1>%a@])@]@ \
- )@]"
- Variable.Set.print (Variable.Map.keys defined_vars)
- print_equations equations
+ "@[<hov 1>(symbol_projections@ @[<hov 1>%a@])@]@ "
+ print_symbol_projections symbol_projections ;
+ Format.fprintf ppf
+ "@[<hov 1>(equations@ @[<v 1>%a@])@])"
+ print_equations equations;
+ Format.fprintf ppf ")@]"
let fold_on_defined_vars f t init =
Binding_time.Map.fold
@@ -188,7 +197,7 @@ let ids_for_export t =
let as_extension_without_bindings
({ defined_vars; binding_times; equations; symbol_projections } as t) =
- if Flambda_features.check_invariants ()
+ if Flambda_features.check_light_invariants ()
then
if Variable.Map.is_empty defined_vars
&& Binding_time.Map.is_empty binding_times
diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml
new file mode 100644
index 00000000000..c58f1cce301
--- /dev/null
+++ b/middle_end/flambda2/types/equal_types_for_debug.ml
@@ -0,0 +1,497 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2025 OCamlPro SAS *)
+(* Copyright 2025 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+module TE = Typing_env
+module TEE = Typing_env_extension
+module TG = Type_grammar
+module ET = Expand_head.Expanded_type
+
+type renaming =
+ { mutable left_renaming : Variable.t Variable.Map.t;
+ mutable right_renaming : Variable.t Variable.Map.t
+ }
+
+let create_renaming () =
+ { left_renaming = Variable.Map.empty; right_renaming = Variable.Map.empty }
+
+let link_and_check renaming var1 var2 check =
+ match Variable.Map.find_opt var1 renaming.left_renaming with
+ | Some var1' -> Variable.equal var1' var2
+ | None -> (
+ match Variable.Map.find_opt var2 renaming.right_renaming with
+ | Some _ -> false
+ | None ->
+ renaming.left_renaming
+ <- Variable.Map.add var1 var2 renaming.left_renaming;
+ renaming.right_renaming
+ <- Variable.Map.add var2 var1 renaming.right_renaming;
+ check ())
+
+type env =
+ { parent_env : TE.t;
+ left_env : TE.t;
+ right_env : TE.t;
+ meet_type : TE.meet_type;
+ renaming : renaming
+ }
+
+let create_env ~meet_type parent_env left_env right_env =
+ { parent_env; left_env; right_env; meet_type; renaming = create_renaming () }
+
+let extension_env env left_env right_env = { env with left_env; right_env }
+
+let add_env_extension env ext1 ext2 =
+ extension_env env
+ (TE.add_env_extension ~meet_type:env.meet_type env.left_env ext1)
+ (TE.add_env_extension ~meet_type:env.meet_type env.right_env ext2)
+
+let add_env_extension_strict env ext1 ext2 =
+ ( TE.add_env_extension_strict ~meet_type:env.meet_type env.left_env ext1,
+ TE.add_env_extension_strict ~meet_type:env.meet_type env.right_env ext2 )
+
+let exists_in_parent_env env name =
+ TE.mem ~min_name_mode:Name_mode.in_types env.parent_env name
+
+let simple_exists_in_parent_env env simple =
+ TE.mem_simple ~min_name_mode:Name_mode.in_types env.parent_env simple
+
+let equal_bottom equal (x1 : _ Or_bottom.t) (x2 : _ Or_bottom.t) =
+ match x1, x2 with
+ | Bottom, Bottom -> true
+ | Bottom, Ok _ | Ok _, Bottom -> false
+ | Ok x1, Ok x2 -> equal x1 x2
+
+let equal_row_like_index_domain ~equal_lattice (t1 : _ TG.row_like_index_domain)
+ (t2 : _ TG.row_like_index_domain) =
+ match t1, t2 with
+ | Known t1, Known t2 -> equal_lattice t1 t2
+ | Known _, At_least _ | At_least _, Known _ -> false
+ | At_least t1, At_least t2 -> equal_lattice t1 t2
+
+let equal_row_like_index ~equal_lattice ~equal_shape
+ (t1 : (_, _) TG.row_like_index) (t2 : (_, _) TG.row_like_index) =
+ equal_row_like_index_domain ~equal_lattice t1.domain t2.domain
+ && equal_shape t1.shape t2.shape
+
+let names_with_non_equal_types_env_extension ~equal_type env
+ (ext1 : TG.env_extension) (ext2 : TG.env_extension) =
+ (* Only consider names that are defined in the parent environment and have a
+ new equation in at least one environment.
+
+ Note that there is a loss of precision here with existential variables (not
+ present in the parent env): if two existential variables have been (or will
+ be!) linked, we don't check that the new types added by each extension for
+ the linked variables are equal. *)
+ let shared_names =
+ Name.Map.merge
+ (fun name ty1 ty2 ->
+ match ty1, ty2 with
+ | (Some ty, _ | _, Some ty) when exists_in_parent_env env name ->
+ Some (TG.kind ty)
+ | _ -> None)
+ (TEE.to_map ext1) (TEE.to_map ext2)
+ in
+ let env = add_env_extension env ext1 ext2 in
+ Name.Map.keys
+ (Name.Map.filter
+ (fun name kind ->
+ let left_ty =
+ ET.to_type
+ (Expand_head.expand_head env.left_env
+ (TG.alias_type_of kind (Simple.name name)))
+ in
+ let right_ty =
+ ET.to_type
+ (Expand_head.expand_head env.right_env
+ (TG.alias_type_of kind (Simple.name name)))
+ in
+ not (equal_type env left_ty right_ty))
+ shared_names)
+
+let equal_env_extension ~equal_type env ext1 ext2 =
+ Name.Set.is_empty
+ (names_with_non_equal_types_env_extension ~equal_type env ext1 ext2)
+
+let equal_row_like_case ~equal_type ~equal_maps_to ~equal_lattice ~equal_shape
+ env (t1 : (_, _, _) TG.row_like_case) (t2 : (_, _, _) TG.row_like_case) =
+ match
+ ( TE.add_env_extension_strict env.left_env t1.env_extension
+ ~meet_type:env.meet_type,
+ TE.add_env_extension_strict env.right_env t2.env_extension
+ ~meet_type:env.meet_type )
+ with
+ | Or_bottom.Bottom, Or_bottom.Bottom -> true
+ | Or_bottom.Ok _, Or_bottom.Bottom | Or_bottom.Bottom, Or_bottom.Ok _ -> false
+ | Or_bottom.Ok left_env, Or_bottom.Ok right_env ->
+ let both_env = extension_env env left_env right_env in
+ equal_row_like_index ~equal_lattice ~equal_shape t1.index t2.index
+ && equal_maps_to both_env t1.maps_to t2.maps_to
+ && equal_env_extension ~equal_type both_env t1.env_extension
+ t2.env_extension
+
+let equal_array eq a1 a2 =
+ Array.length a1 = Array.length a2 && Array.for_all2 eq a1 a2
+
+let equal_row_like_block_case ~equal_type env (t1 : TG.row_like_block_case)
+ (t2 : TG.row_like_block_case) =
+ equal_row_like_case ~equal_type ~equal_lattice:TG.Block_size.equal
+ ~equal_shape:Flambda_kind.Block_shape.equal
+ ~equal_maps_to:(fun env -> equal_array (equal_type env))
+ env t1 t2
+
+let equal_row_like_for_blocks ~equal_type env (t1 : TG.row_like_for_blocks)
+ (t2 : TG.row_like_for_blocks) =
+ Tag.Map.equal
+ (Or_unknown.equal (equal_row_like_block_case ~equal_type env))
+ t1.known_tags t2.known_tags
+ && equal_bottom
+ (equal_row_like_block_case ~equal_type env)
+ t1.other_tags t2.other_tags
+ && Alloc_mode.For_types.equal t1.alloc_mode t2.alloc_mode
+
+let equal_function_slot_indexed_product ~equal_type env
+ (t1 : TG.function_slot_indexed_product)
+ (t2 : TG.function_slot_indexed_product) =
+ Function_slot.Map.equal (equal_type env) t1.function_slot_components_by_index
+ t2.function_slot_components_by_index
+
+let equal_value_slot_indexed_product ~equal_type env
+ (t1 : TG.value_slot_indexed_product) (t2 : TG.value_slot_indexed_product) =
+ Value_slot.Map.equal (equal_type env) t1.value_slot_components_by_index
+ t2.value_slot_components_by_index
+
+let equal_function_type ~equal_type env (t1 : TG.function_type)
+ (t2 : TG.function_type) =
+ Code_id.equal t1.code_id t2.code_id && equal_type env t1.rec_info t2.rec_info
+
+let equal_closures_entry ~equal_type env (t1 : TG.closures_entry)
+ (t2 : TG.closures_entry) =
+ Function_slot.Map.equal
+ (Or_unknown_or_bottom.equal (equal_function_type ~equal_type env))
+ t1.function_types t2.function_types
+ && equal_function_slot_indexed_product ~equal_type env t1.closure_types
+ t2.closure_types
+ && equal_value_slot_indexed_product ~equal_type env t1.value_slot_types
+ t2.value_slot_types
+
+let equal_row_like_for_closures ~equal_type env (t1 : TG.row_like_for_closures)
+ (t2 : TG.row_like_for_closures) =
+ let equal_row_like_case =
+ equal_row_like_case ~equal_type env
+ ~equal_lattice:Set_of_closures_contents.equal
+ ~equal_shape:(fun () () -> true)
+ ~equal_maps_to:(equal_closures_entry ~equal_type)
+ in
+ Function_slot.Map.equal equal_row_like_case t1.known_closures
+ t2.known_closures
+ && equal_bottom equal_row_like_case t1.other_closures t2.other_closures
+
+let equal_array_contents ~equal_type env (t1 : TG.array_contents)
+ (t2 : TG.array_contents) =
+ match t1, t2 with
+ | Mutable, Mutable -> true
+ | Mutable, Immutable _ | Immutable _, Mutable -> false
+ | Immutable { fields = f1 }, Immutable { fields = f2 } ->
+ equal_array (equal_type env) f1 f2
+
+let equal_head_of_kind_value_non_null ~equal_type env
+ (t1 : TG.head_of_kind_value_non_null) (t2 : TG.head_of_kind_value_non_null)
+ =
+ match t1, t2 with
+ | Variant t1, Variant t2 -> (
+ Bool.equal t1.is_unique t2.is_unique
+ &&
+ let envs_immediate, envs_block =
+ match t1.extensions, t2.extensions with
+ | No_extensions, No_extensions ->
+ ( (Or_bottom.Ok env.left_env, Or_bottom.Ok env.right_env),
+ (Or_bottom.Ok env.left_env, Or_bottom.Ok env.right_env) )
+ | Ext { when_immediate; when_block }, No_extensions ->
+ ( add_env_extension_strict env when_immediate TEE.empty,
+ add_env_extension_strict env when_block TEE.empty )
+ | No_extensions, Ext { when_immediate; when_block } ->
+ ( add_env_extension_strict env TEE.empty when_immediate,
+ add_env_extension_strict env TEE.empty when_block )
+ | ( Ext { when_immediate = when_immediate1; when_block = when_block1 },
+ Ext { when_immediate = when_immediate2; when_block = when_block2 } )
+ ->
+ ( add_env_extension_strict env when_immediate1 when_immediate2,
+ add_env_extension_strict env when_block1 when_block2 )
+ in
+ (match envs_immediate with
+ | Bottom, Bottom -> true
+ | Bottom, Ok _ | Ok _, Bottom -> false
+ | Ok left_env, Ok right_env ->
+ Or_unknown.equal
+ (equal_type (extension_env env left_env right_env))
+ t1.immediates t2.immediates)
+ &&
+ match envs_block with
+ | Bottom, Bottom -> true
+ | Bottom, Ok _ | Ok _, Bottom -> false
+ | Ok left_env, Ok right_env ->
+ Or_unknown.equal
+ (equal_row_like_for_blocks ~equal_type
+ (extension_env env left_env right_env))
+ t1.blocks t2.blocks)
+ | Mutable_block t1, Mutable_block t2 ->
+ Alloc_mode.For_types.equal t1.alloc_mode t2.alloc_mode
+ | Boxed_float32 (t1, a1), Boxed_float32 (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Boxed_float (t1, a1), Boxed_float (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Boxed_int32 (t1, a1), Boxed_int32 (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Boxed_int64 (t1, a1), Boxed_int64 (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Boxed_nativeint (t1, a1), Boxed_nativeint (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Boxed_vec128 (t1, a1), Boxed_vec128 (t2, a2) ->
+ equal_type env t1 t2 && Alloc_mode.For_types.equal a1 a2
+ | Closures c1, Closures c2 ->
+ equal_row_like_for_closures ~equal_type env c1.by_function_slot
+ c2.by_function_slot
+ && Alloc_mode.For_types.equal c1.alloc_mode c2.alloc_mode
+ | String t1, String t2 -> String_info.Set.equal t1 t2
+ | Array t1, Array t2 ->
+ Or_unknown_or_bottom.equal Flambda_kind.With_subkind.equal t1.element_kind
+ t2.element_kind
+ && equal_type env t1.length t2.length
+ && Or_unknown.equal
+ (equal_array_contents ~equal_type env)
+ t1.contents t2.contents
+ && Alloc_mode.For_types.equal t1.alloc_mode t2.alloc_mode
+ | ( ( Variant _ | Mutable_block _ | Boxed_float _ | Boxed_float32 _
+ | Boxed_int32 _ | Boxed_vec128 _ | Boxed_int64 _ | Boxed_nativeint _
+ | Closures _ | String _ | Array _ ),
+ _ ) ->
+ false
+
+let equal_head_of_kind_value ~equal_type env (t1 : TG.head_of_kind_value)
+ (t2 : TG.head_of_kind_value) =
+ match t1.is_null, t2.is_null with
+ | Not_null, Maybe_null | Maybe_null, Not_null -> false
+ | Not_null, Not_null | Maybe_null, Maybe_null ->
+ Or_unknown_or_bottom.equal
+ (equal_head_of_kind_value_non_null ~equal_type env)
+ t1.non_null t2.non_null
+
+let equal_head_of_kind_naked_immediate ~equal_type env
+ (t1 : TG.head_of_kind_naked_immediate)
+ (t2 : TG.head_of_kind_naked_immediate) =
+ match t1, t2 with
+ | Naked_immediates is1, Naked_immediates is2 ->
+ Targetint_31_63.Set.equal is1 is2
+ | Is_int t1, Is_int t2 -> equal_type env t1 t2
+ | Get_tag t1, Get_tag t2 -> equal_type env t1 t2
+ | Is_null t1, Is_null t2 -> equal_type env t1 t2
+ | (Naked_immediates _ | Is_int _ | Get_tag _ | Is_null _), _ -> false
+
+let equal_head_of_kind_naked_float32 (t1 : TG.head_of_kind_naked_float32)
+ (t2 : TG.head_of_kind_naked_float32) =
+ Numeric_types.Float32_by_bit_pattern.Set.equal
+ (t1 :> Numeric_types.Float32_by_bit_pattern.Set.t)
+ (t2 :> Numeric_types.Float32_by_bit_pattern.Set.t)
+
+let equal_head_of_kind_naked_float (t1 : TG.head_of_kind_naked_float)
+ (t2 : TG.head_of_kind_naked_float) =
+ Numeric_types.Float_by_bit_pattern.Set.equal
+ (t1 :> Numeric_types.Float_by_bit_pattern.Set.t)
+ (t2 :> Numeric_types.Float_by_bit_pattern.Set.t)
+
+let equal_head_of_kind_naked_int32 (t1 : TG.head_of_kind_naked_int32)
+ (t2 : TG.head_of_kind_naked_int32) =
+ Numeric_types.Int32.Set.equal
+ (t1 :> Numeric_types.Int32.Set.t)
+ (t2 :> Numeric_types.Int32.Set.t)
+
+let equal_head_of_kind_naked_int64 (t1 : TG.head_of_kind_naked_int64)
+ (t2 : TG.head_of_kind_naked_int64) =
+ Numeric_types.Int64.Set.equal
+ (t1 :> Numeric_types.Int64.Set.t)
+ (t2 :> Numeric_types.Int64.Set.t)
+
+let equal_head_of_kind_naked_nativeint (t1 : TG.head_of_kind_naked_nativeint)
+ (t2 : TG.head_of_kind_naked_nativeint) =
+ Targetint_32_64.Set.equal
+ (t1 :> Targetint_32_64.Set.t)
+ (t2 :> Targetint_32_64.Set.t)
+
+let equal_head_of_kind_naked_vec128 (t1 : TG.head_of_kind_naked_vec128)
+ (t2 : TG.head_of_kind_naked_vec128) =
+ Vector_types.Vec128.Bit_pattern.Set.equal
+ (t1 :> Vector_types.Vec128.Bit_pattern.Set.t)
+ (t2 :> Vector_types.Vec128.Bit_pattern.Set.t)
+
+let equal_head_of_kind_rec_info (t1 : TG.head_of_kind_rec_info)
+ (t2 : TG.head_of_kind_rec_info) =
+ Rec_info_expr.equal t1 t2
+
+let equal_head_of_kind_region (() : TG.head_of_kind_region)
+ (() : TG.head_of_kind_region) =
+ true
+
+let is_unknown_head_of_kind_value (t : TG.head_of_kind_value) =
+ match t.is_null, t.non_null with
+ | Maybe_null, Unknown -> true
+ | (Not_null | Maybe_null), (Unknown | Bottom | Ok _) -> false
+
+let is_non_obviously_unknown (t : ET.descr) =
+ match t with
+ | Value head -> is_unknown_head_of_kind_value head
+ | Naked_immediate _ | Naked_float32 _ | Naked_float _ | Naked_int32 _
+ | Naked_int64 _ | Naked_nativeint _ | Naked_vec128 _ | Rec_info _ | Region _
+ ->
+ false
+
+let is_bottom_head_of_kind_value (t : TG.head_of_kind_value) =
+ match t.is_null, t.non_null with
+ | Not_null, Bottom -> true
+ | (Not_null | Maybe_null), (Unknown | Bottom | Ok _) -> false
+
+let is_non_obviously_bottom (t : ET.descr) =
+ match t with
+ | Value head -> is_bottom_head_of_kind_value head
+ | Naked_immediate _ | Naked_float32 _ | Naked_float _ | Naked_int32 _
+ | Naked_int64 _ | Naked_nativeint _ | Naked_vec128 _ | Rec_info _ | Region _
+ ->
+ false
+
+let equal_expanded_head ~equal_type env (t1 : ET.t) (t2 : ET.t) =
+ match ET.descr t1, ET.descr t2 with
+ | Unknown, Unknown -> true
+ | Bottom, Bottom -> true
+ | Unknown, Ok head | Ok head, Unknown -> is_non_obviously_unknown head
+ | Unknown, Bottom | Bottom, Unknown -> false
+ | Ok head, Bottom | Bottom, Ok head -> is_non_obviously_bottom head
+ | Ok t1, Ok t2 -> (
+ match t1, t2 with
+ | Value t1, Value t2 -> equal_head_of_kind_value ~equal_type env t1 t2
+ | Naked_immediate t1, Naked_immediate t2 ->
+ equal_head_of_kind_naked_immediate ~equal_type env t1 t2
+ | Naked_float32 t1, Naked_float32 t2 ->
+ equal_head_of_kind_naked_float32 t1 t2
+ | Naked_float t1, Naked_float t2 -> equal_head_of_kind_naked_float t1 t2
+ | Naked_int32 t1, Naked_int32 t2 -> equal_head_of_kind_naked_int32 t1 t2
+ | Naked_int64 t1, Naked_int64 t2 -> equal_head_of_kind_naked_int64 t1 t2
+ | Naked_nativeint t1, Naked_nativeint t2 ->
+ equal_head_of_kind_naked_nativeint t1 t2
+ | Naked_vec128 t1, Naked_vec128 t2 -> equal_head_of_kind_naked_vec128 t1 t2
+ | Rec_info t1, Rec_info t2 -> equal_head_of_kind_rec_info t1 t2
+ | Region t1, Region t2 -> equal_head_of_kind_region t1 t2
+ | ( ( Value _ | Naked_immediate _ | Naked_float32 _ | Naked_float _
+ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ | Naked_vec128 _
+ | Rec_info _ | Region _ ),
+ _ ) ->
+ false)
+
+let rec equal_type env t1 t2 =
+ let canonical_simple1 =
+ try
+ Some
+ (TE.get_alias_then_canonical_simple_exn
+ ~min_name_mode:Name_mode.in_types env.left_env t1)
+ with Not_found -> None
+ in
+ let canonical_simple2 =
+ try
+ Some
+ (TE.get_alias_then_canonical_simple_exn
+ ~min_name_mode:Name_mode.in_types env.right_env t2)
+ with Not_found -> None
+ in
+ match canonical_simple1, canonical_simple2 with
+ | Some simple1, Some simple2
+ when Simple.equal simple1 simple2 && simple_exists_in_parent_env env simple1
+ ->
+ true
+ | Some simple1, Some simple2 -> (
+ match Simple.must_be_var simple1, Simple.must_be_var simple2 with
+ | None, None | None, Some _ | Some _, None ->
+ (* Allow non-canonical representations of constants. *)
+ if Simple.is_const simple1 || Simple.is_const simple2
+ then
+ equal_expanded_head ~equal_type env
+ (Expand_head.expand_head env.left_env t1)
+ (Expand_head.expand_head env.right_env t2)
+ else false
+ | Some (var1, coercion1), Some (var2, coercion2) -> (
+ let coercion =
+ Coercion.compose_exn coercion1 ~then_:(Coercion.inverse coercion2)
+ in
+ match
+ ( exists_in_parent_env env (Name.var var1),
+ exists_in_parent_env env (Name.var var2) )
+ with
+ | true, true -> Variable.equal var1 var2 && Coercion.is_id coercion
+ | true, false | false, true -> false
+ | false, false ->
+ link_and_check env.renaming var1 var2 (fun () ->
+ equal_expanded_head ~equal_type env
+ (Expand_head.expand_head env.left_env t1)
+ (Expand_head.expand_head env.right_env t2))))
+ | (None, Some simple | Some simple, None)
+ when (not (Simple.is_const simple))
+ && simple_exists_in_parent_env env simple ->
+ false
+ | None, None | Some _, None | None, Some _ ->
+ (* We lose some precision here: if the same named type from one of the
+ environments is checked for equality against multiple anonymous types
+ from the other environment, we know more equalities in the first
+ environment than in the second. This is probably acceptable since this
+ check is only intended for debugging. *)
+ equal_expanded_head ~equal_type env
+ (Expand_head.expand_head env.left_env t1)
+ (Expand_head.expand_head env.right_env t2)
+
+let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1
+ level2 =
+ let left_env =
+ Typing_env_level.fold_on_defined_vars
+ (fun var kind left_env ->
+ TE.add_definition left_env
+ (Bound_name.create_var (Bound_var.create var Name_mode.in_types))
+ kind)
+ level1 env
+ in
+ let right_env =
+ Typing_env_level.fold_on_defined_vars
+ (fun var kind right_env ->
+ TE.add_definition right_env
+ (Bound_name.create_var (Bound_var.create var Name_mode.in_types))
+ kind)
+ level2 env
+ in
+ names_with_non_equal_types_env_extension ~equal_type
+ (create_env ~meet_type env left_env right_env)
+ (TEE.from_map (Typing_env_level.equations level1))
+ (TEE.from_map (Typing_env_level.equations level2))
+
+let equal_level_ignoring_name_mode ~meet_type env level1 level2 =
+ Name.Set.is_empty
+ (names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1
+ level2)
+
+let names_with_non_equal_types_env_extension ~meet_type env ext1 ext2 =
+ names_with_non_equal_types_env_extension ~equal_type
+ (create_env ~meet_type env env env)
+ ext1 ext2
+
+let equal_env_extension ~meet_type env ext1 ext2 =
+ Name.Set.is_empty
+ (names_with_non_equal_types_env_extension ~meet_type env ext1 ext2)
+
+let equal_type ~meet_type env t1 t2 =
+ equal_type (create_env ~meet_type env env env) t1 t2
diff --git a/middle_end/flambda2/types/equal_types_for_debug.mli b/middle_end/flambda2/types/equal_types_for_debug.mli
new file mode 100644
index 00000000000..98c0dc229b3
--- /dev/null
+++ b/middle_end/flambda2/types/equal_types_for_debug.mli
@@ -0,0 +1,60 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2025 OCamlPro SAS *)
+(* Copyright 2025 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* This module provides facilities for checking that two types are equal, for a
+ {b semantic} definition of equality: aliases are resolved with respect to a
+ typing environment.
+
+ {b Warning}: This module should only be used for debugging purposes. It has
+ high computational complexity, and no guarantees is made on the precision of
+ the equality test, in particular for types containing env extensions.
+
+ {b Note}: The functions operating on levels treat all variables defined by
+ the levels as existentials. *)
+
+val equal_type :
+ meet_type:Typing_env.meet_type ->
+ Typing_env.t ->
+ Type_grammar.t ->
+ Type_grammar.t ->
+ bool
+
+val equal_env_extension :
+ meet_type:Typing_env.meet_type ->
+ Typing_env.t ->
+ Typing_env_extension.t ->
+ Typing_env_extension.t ->
+ bool
+
+val names_with_non_equal_types_env_extension :
+ meet_type:Typing_env.meet_type ->
+ Typing_env.t ->
+ Typing_env_extension.t ->
+ Typing_env_extension.t ->
+ Name.Set.t
+
+val equal_level_ignoring_name_mode :
+ meet_type:Typing_env.meet_type ->
+ Typing_env.t ->
+ Typing_env_level.t ->
+ Typing_env_level.t ->
+ bool
+
+val names_with_non_equal_types_level_ignoring_name_mode :
+ meet_type:Typing_env.meet_type ->
+ Typing_env.t ->
+ Typing_env_level.t ->
+ Typing_env_level.t ->
+ Name.Set.t
diff --git a/middle_end/flambda2/types/flambda2_types.ml b/middle_end/flambda2/types/flambda2_types.ml
index d85e61ce95f..c6243a5f09a 100644
--- a/middle_end/flambda2/types/flambda2_types.ml
+++ b/middle_end/flambda2/types/flambda2_types.ml
@@ -51,3 +51,13 @@ module Code_age_relation = Code_age_relation
let remove_outermost_alias env ty =
Expand_head.expand_head env ty |> Expand_head.Expanded_type.to_type
+
+module Equal_types_for_debug = struct
+ let equal_type env t1 t2 =
+ Equal_types_for_debug.equal_type ~meet_type:Meet_and_join.meet_type env t1
+ t2
+
+ let equal_env_extension env ext1 ext2 =
+ Equal_types_for_debug.equal_env_extension ~meet_type:Meet_and_join.meet_type
+ env ext1 ext2
+end
diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli
index 028a7cc729a..2bb3853a8fa 100644
--- a/middle_end/flambda2/types/flambda2_types.mli
+++ b/middle_end/flambda2/types/flambda2_types.mli
@@ -789,3 +789,10 @@ val never_holds_locally_allocated_values :
Typing_env.t -> Variable.t -> unit proof_of_property
val remove_outermost_alias : Typing_env.t -> t -> t
+
+module Equal_types_for_debug : sig
+ val equal_type : Typing_env.t -> Type_grammar.t -> Type_grammar.t -> bool
+
+ val equal_env_extension :
+ Typing_env.t -> Typing_env_extension.t -> Typing_env_extension.t -> bool
+end
diff --git a/middle_end/flambda2/types/join_levels.ml b/middle_end/flambda2/types/join_levels.ml
index f7d98596d30..e1a6139c1b7 100644
--- a/middle_end/flambda2/types/join_levels.ml
+++ b/middle_end/flambda2/types/join_levels.ml
@@ -14,214 +14,8 @@
(* *)
(**************************************************************************)
-module K = Flambda_kind
-module MTC = More_type_creators
module TE = Typing_env
-module TEE = Typing_env_extension
module TEL = Typing_env_level
-module TG = Type_grammar
-module Join_env = TE.Join_env
-
-let join_types ~env_at_fork envs_with_levels =
- (* Add all the variables defined by the branches as existentials to the
- [env_at_fork].
-
- Any such variable will be given type [Bottom] on a branch where it was not
- originally present.
-
- Iterating on [level.binding_times] instead of [level.defined_vars] ensures
- consistency of binding time order in the branches and the result. In
- addition, this also aggregates the code age relations of the branches. *)
- let base_env =
- List.fold_left
- (fun base_env (env_at_use, _, _, level) ->
- let base_env =
- Binding_time.Map.fold
- (fun _ vars base_env ->
- Variable.Set.fold
- (fun var base_env ->
- if TE.mem base_env (Name.var var)
- then base_env
- else
- let kind = TEL.find_kind level var in
- TE.add_definition base_env
- (Bound_name.create_var
- (Bound_var.create var Name_mode.in_types))
- kind)
- vars base_env)
- (TEL.variables_by_binding_time level)
- base_env
- in
- let code_age_relation =
- Code_age_relation.union
- (TE.code_age_relation base_env)
- (TE.code_age_relation env_at_use)
- in
- TE.with_code_age_relation base_env code_age_relation)
- env_at_fork envs_with_levels
- in
- (* Find the actual domain of the join of the levels
-
- We compute an extension that is the join of the extensions corresponding to
- all the levels. To avoid the difficulty with computing the domain lazily
- during the join, we pre-compute the domain and initialise our accumulator
- with bottom types for all variables involved. *)
- let initial_types =
- List.fold_left
- (fun initial_types (_, _, _, level) ->
- Name.Map.fold
- (fun name ty initial_types ->
- if Name.is_var name
- then Name.Map.add name (MTC.bottom_like ty) initial_types
- else initial_types)
- (TEL.equations level) initial_types)
- Name.Map.empty envs_with_levels
- in
- (* Now fold over the levels doing the actual join operation on equations. *)
- ListLabels.fold_left envs_with_levels ~init:initial_types
- ~f:(fun joined_types (env_at_use, _, _, t) ->
- let left_env =
- (* CR vlaviron: This is very likely quadratic (number of uses times
- number of variables in all uses). However it's hard to know how we
- could do better. *)
- TE.add_env_extension_maybe_bottom base_env
- (TEE.from_map joined_types)
- ~meet_type:Meet_and_join.meet_type
- in
- let join_types name joined_ty use_ty =
- let same_unit =
- Compilation_unit.equal
- (Name.compilation_unit name)
- (Compilation_unit.get_current_exn ())
- in
- if same_unit && not (TE.mem base_env name)
- then
- Misc.fatal_errorf "Name %a not defined in [base_env]:@ %a" Name.print
- name TE.print base_env;
- (* If [name] is that of a lifted constant symbol generated during one of
- the levels, then ignore it. [Simplify_expr] will already have made
- its type suitable for [base_env] and inserted it into that
- environment.
-
- If [name] is a symbol that is not a lifted constant, then it was
- defined before the fork and already has an equation in base_env.
- While it is possible that its type could be refined by all of the
- branches, it is unlikely. *)
- if not (Name.is_var name)
- then None
- else
- let joined_ty, use_ty =
- match joined_ty, use_ty with
- | None, Some _use_ty ->
- assert false (* See the computation of [initial_types] *)
- | Some joined_ty, None ->
- (* There is no equation, at all (not even saying "unknown"), on
- the current level for [name]. There are two possible cases for
- that:
-
- - The environment at use knows of this variable, but this level
- has no equation on it. In this case, we need to retrieve the
- type from [env_at_use] and join with it.
-
- - The variable doesn't exist in this environment. This happens
- if the variable is defined in one of the other branches, and
- will be quantified existentially in the result. In this case,
- it's safe to join with Bottom. *)
- let is_defined_at_use = TE.mem env_at_use name in
- if is_defined_at_use
- then
- let use_ty =
- let expected_kind = Some (TG.kind joined_ty) in
- TE.find env_at_use name expected_kind
- in
- joined_ty, use_ty
- else joined_ty, MTC.bottom_like joined_ty
- | Some joined_ty, Some use_ty -> joined_ty, use_ty
- | None, None -> assert false
- in
- let join_env =
- 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
- with
- | Known joined_ty -> Some joined_ty
- | Unknown -> None
- in
- Name.Map.merge join_types joined_types (TEL.equations t))
-
-let construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types
- ~params =
- let allowed_and_new =
- (* Parameters are already in the resulting environment *)
- List.fold_left
- (fun allowed_and_new param ->
- Name_occurrences.remove_var allowed_and_new
- ~var:(Bound_parameter.var param))
- allowed params
- in
- let variable_is_in_new_level var =
- Name_occurrences.mem_var allowed_and_new var
- in
- let defined_vars, binding_times =
- List.fold_left
- (fun (defined_vars, binding_times) (_env_at_use, _id, _use_kind, t) ->
- let defined_vars_this_level =
- Variable.Map.filter
- (fun var _ -> variable_is_in_new_level var)
- (TEL.defined_variables_with_kinds t)
- in
- let defined_vars =
- Variable.Map.union
- (fun var kind1 kind2 ->
- if K.equal kind1 kind2
- then Some kind1
- else
- Misc.fatal_errorf
- "Cannot join levels that disagree on the kind of \
- [defined_vars] (%a and %a for %a)"
- K.print kind1 K.print kind2 Variable.print var)
- defined_vars defined_vars_this_level
- in
- let binding_times_this_level =
- Binding_time.Map.filter_map
- (fun _ vars ->
- let vars = Variable.Set.filter variable_is_in_new_level vars in
- if Variable.Set.is_empty vars then None else Some vars)
- (TEL.variables_by_binding_time t)
- in
- let binding_times =
- Binding_time.Map.union
- (fun _bt vars1 vars2 -> Some (Variable.Set.union vars1 vars2))
- binding_times binding_times_this_level
- in
- defined_vars, binding_times)
- (Variable.Map.empty, Binding_time.Map.empty)
- envs_with_levels
- in
- let equations =
- Name.Map.filter
- (fun name _ty -> Name_occurrences.mem_name allowed name)
- joined_types
- in
- let symbol_projections =
- List.fold_left
- (fun symbol_projections (_env_at_use, _id, _use_kind, t) ->
- let projs_this_level =
- Variable.Map.filter
- (fun var _ ->
- let name = Name.var var in
- TE.mem ~min_name_mode:Name_mode.normal env_at_fork name
- || Name_occurrences.mem_name allowed name)
- (TEL.symbol_projections t)
- in
- Variable.Map.union
- (fun _var proj1 proj2 ->
- if Symbol_projection.equal proj1 proj2 then Some proj1 else None)
- symbol_projections projs_this_level)
- Variable.Map.empty envs_with_levels
- in
- TEL.create ~defined_vars ~binding_times ~equations ~symbol_projections
let check_join_inputs ~env_at_fork _envs_with_levels ~params
~extra_lifted_consts_in_use_envs =
@@ -249,90 +43,71 @@ let check_join_inputs ~env_at_fork _envs_with_levels ~params
Symbol.print symbol)
extra_lifted_consts_in_use_envs
-let join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs
- ~extra_allowed_names:allowed =
- check_join_inputs ~env_at_fork envs_with_levels ~params
+let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
+ ~extra_lifted_consts_in_use_envs ~extra_allowed_names:_ =
+ let params = Bound_parameters.to_list params in
+ check_join_inputs ~env_at_fork:definition_typing_env ts_and_use_ids ~params
~extra_lifted_consts_in_use_envs;
- (* Calculate the joined types of all the names involved. *)
- let joined_types = join_types ~env_at_fork envs_with_levels in
- (* Next calculate which equations (describing joined types) to propagate to
- the join point. (Recall that the environment at the fork point includes the
- parameters of the continuation being called at the join. We wish to ensure
- that information in the types of these parameters is not lost.)
+ let ts = List.rev_map (fun (t, _, _) -> t) ts_and_use_ids in
+ Join_env.cut_and_n_way_join ~meet_type:Meet_and_n_way_join.meet_type
+ ~n_way_join_type:Meet_and_n_way_join.n_way_join definition_typing_env
+ ~cut_after ts
- - Equations on names defined in the environment at the fork point are
- always propagated.
+let ignore_names =
+ String.split_on_char ','
+ (Option.value ~default:""
+ (Sys.getenv_opt "FLAMBDA2_JOIN_DEBUG_IGNORE_NAMES"))
- - Definitions of, and equations on, names that occur free on the right-hand
- sides of the propagated equations are also themselves propagated. The
- definition of any such propagated name (i.e. one that does not occur in the
- environment at the fork point) will be made existential. *)
- let free_names_transitive typ =
- (* We need to compute the free names of joined_types, but we can't use a
- typing environment. *)
- let rec free_names_transitive0 typ ~result =
- let free_names = TG.free_names typ in
- let to_traverse = Name_occurrences.diff free_names ~without:result in
- Name_occurrences.fold_names to_traverse ~init:result
- ~f:(fun result name ->
- let result =
- Name_occurrences.add_name result name Name_mode.in_types
- in
- match Name.Map.find name joined_types with
- | exception Not_found -> result
- | typ -> free_names_transitive0 typ ~result)
- in
- free_names_transitive0 typ ~result:Name_occurrences.empty
+let cut_and_n_way_join_checked definition_typing_env ts_and_use_ids ~params
+ ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
+ let scope = TE.current_scope definition_typing_env in
+ let typing_env = TE.increment_scope definition_typing_env in
+ let old_joined_env =
+ Join_levels_old.cut_and_n_way_join typing_env ts_and_use_ids ~params
+ ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names
in
- let allowed =
- Name.Map.fold
- (fun name ty allowed ->
- if TE.mem env_at_fork name || Name.is_symbol name
- then
- Name_occurrences.add_name
- (Name_occurrences.union allowed (free_names_transitive ty))
- name Name_mode.in_types
- else allowed)
- joined_types allowed
- in
- let allowed =
- Symbol.Set.fold
- (fun symbol allowed ->
- Name_occurrences.add_symbol allowed symbol Name_mode.in_types)
- extra_lifted_consts_in_use_envs allowed
- in
- (* Having calculated which equations to propagate, the resulting level can now
- be constructed. *)
- ( construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types
- ~params,
- Name_occurrences.fold_names allowed ~init:Name.Set.empty
- ~f:(fun names name -> Name.Set.add name names) )
-
-let n_way_join ~env_at_fork envs_with_levels ~params
- ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
- match envs_with_levels with
- | [] -> TEL.empty, Name.Set.empty
- | envs_with_levels ->
- join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs
- ~extra_allowed_names
-
-let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
- ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
- let after_cuts =
- List.map
- (fun (t, use_id, use_kind) ->
- let level = TE.cut t ~cut_after in
- t, use_id, use_kind, level)
- ts_and_use_ids
- in
- let params = Bound_parameters.to_list params in
- let level, alias_candidates =
- n_way_join ~env_at_fork:definition_typing_env after_cuts ~params
+ let old_joined_level = TE.cut old_joined_env ~cut_after:scope in
+ let new_joined_env =
+ cut_and_n_way_join typing_env ts_and_use_ids ~params ~cut_after
~extra_lifted_consts_in_use_envs ~extra_allowed_names
in
- let result_env =
- TE.add_env_extension_from_level definition_typing_env level
- ~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)
+ let new_joined_level = TE.cut new_joined_env ~cut_after:scope in
+ (let distinct_names =
+ Equal_types_for_debug.names_with_non_equal_types_level_ignoring_name_mode
+ ~meet_type:Meet_and_join.meet_type typing_env old_joined_level
+ new_joined_level
+ in
+ let distinct_names =
+ Name.Set.filter
+ (fun name ->
+ match Name.must_be_var_opt name with
+ | Some var ->
+ let raw_name = Variable.raw_name var in
+ not (List.exists (String.equal raw_name) ignore_names)
+ | None -> true)
+ distinct_names
+ in
+ if not (Name.Set.is_empty distinct_names)
+ then (
+ Format.eprintf "@[<v 1>%s Distinct joins %s@ " (String.make 22 '=')
+ (String.make 22 '=');
+ if Flambda_features.debug_flambda2 ()
+ then
+ List.iteri
+ (fun i (t, _, _) ->
+ let level = TE.cut t ~cut_after in
+ Format.eprintf "@[<v 1>-- Level %d --@ %a@]@ " i TEL.print level)
+ ts_and_use_ids;
+ Format.eprintf "@[<v 1>-- Old join --@ %a@]@ " TEL.print old_joined_level;
+ Format.eprintf "@[<v 1>-- New join --@ %a@]@ " TEL.print new_joined_level;
+ Format.eprintf "@[Names with distinct types:@ %a@]" Name.Set.print
+ distinct_names;
+ Format.eprintf "@]@\n%s@." (String.make 60 '=')));
+ TE.add_env_extension_from_level definition_typing_env new_joined_level
+ ~meet_type:Meet_and_join.meet_type
+
+let cut_and_n_way_join =
+ match Sys.getenv "FLAMBDA2_JOIN_ALGORITHM" with
+ | "old" -> Join_levels_old.cut_and_n_way_join
+ | "checked" -> cut_and_n_way_join_checked
+ | _ | (exception Not_found) -> cut_and_n_way_join
diff --git a/middle_end/flambda2/types/join_levels_old.ml b/middle_end/flambda2/types/join_levels_old.ml
new file mode 100644
index 00000000000..f7d98596d30
--- /dev/null
+++ b/middle_end/flambda2/types/join_levels_old.ml
@@ -0,0 +1,338 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2019 OCamlPro SAS *)
+(* Copyright 2014--2019 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+module K = Flambda_kind
+module MTC = More_type_creators
+module TE = Typing_env
+module TEE = Typing_env_extension
+module TEL = Typing_env_level
+module TG = Type_grammar
+module Join_env = TE.Join_env
+
+let join_types ~env_at_fork envs_with_levels =
+ (* Add all the variables defined by the branches as existentials to the
+ [env_at_fork].
+
+ Any such variable will be given type [Bottom] on a branch where it was not
+ originally present.
+
+ Iterating on [level.binding_times] instead of [level.defined_vars] ensures
+ consistency of binding time order in the branches and the result. In
+ addition, this also aggregates the code age relations of the branches. *)
+ let base_env =
+ List.fold_left
+ (fun base_env (env_at_use, _, _, level) ->
+ let base_env =
+ Binding_time.Map.fold
+ (fun _ vars base_env ->
+ Variable.Set.fold
+ (fun var base_env ->
+ if TE.mem base_env (Name.var var)
+ then base_env
+ else
+ let kind = TEL.find_kind level var in
+ TE.add_definition base_env
+ (Bound_name.create_var
+ (Bound_var.create var Name_mode.in_types))
+ kind)
+ vars base_env)
+ (TEL.variables_by_binding_time level)
+ base_env
+ in
+ let code_age_relation =
+ Code_age_relation.union
+ (TE.code_age_relation base_env)
+ (TE.code_age_relation env_at_use)
+ in
+ TE.with_code_age_relation base_env code_age_relation)
+ env_at_fork envs_with_levels
+ in
+ (* Find the actual domain of the join of the levels
+
+ We compute an extension that is the join of the extensions corresponding to
+ all the levels. To avoid the difficulty with computing the domain lazily
+ during the join, we pre-compute the domain and initialise our accumulator
+ with bottom types for all variables involved. *)
+ let initial_types =
+ List.fold_left
+ (fun initial_types (_, _, _, level) ->
+ Name.Map.fold
+ (fun name ty initial_types ->
+ if Name.is_var name
+ then Name.Map.add name (MTC.bottom_like ty) initial_types
+ else initial_types)
+ (TEL.equations level) initial_types)
+ Name.Map.empty envs_with_levels
+ in
+ (* Now fold over the levels doing the actual join operation on equations. *)
+ ListLabels.fold_left envs_with_levels ~init:initial_types
+ ~f:(fun joined_types (env_at_use, _, _, t) ->
+ let left_env =
+ (* CR vlaviron: This is very likely quadratic (number of uses times
+ number of variables in all uses). However it's hard to know how we
+ could do better. *)
+ TE.add_env_extension_maybe_bottom base_env
+ (TEE.from_map joined_types)
+ ~meet_type:Meet_and_join.meet_type
+ in
+ let join_types name joined_ty use_ty =
+ let same_unit =
+ Compilation_unit.equal
+ (Name.compilation_unit name)
+ (Compilation_unit.get_current_exn ())
+ in
+ if same_unit && not (TE.mem base_env name)
+ then
+ Misc.fatal_errorf "Name %a not defined in [base_env]:@ %a" Name.print
+ name TE.print base_env;
+ (* If [name] is that of a lifted constant symbol generated during one of
+ the levels, then ignore it. [Simplify_expr] will already have made
+ its type suitable for [base_env] and inserted it into that
+ environment.
+
+ If [name] is a symbol that is not a lifted constant, then it was
+ defined before the fork and already has an equation in base_env.
+ While it is possible that its type could be refined by all of the
+ branches, it is unlikely. *)
+ if not (Name.is_var name)
+ then None
+ else
+ let joined_ty, use_ty =
+ match joined_ty, use_ty with
+ | None, Some _use_ty ->
+ assert false (* See the computation of [initial_types] *)
+ | Some joined_ty, None ->
+ (* There is no equation, at all (not even saying "unknown"), on
+ the current level for [name]. There are two possible cases for
+ that:
+
+ - The environment at use knows of this variable, but this level
+ has no equation on it. In this case, we need to retrieve the
+ type from [env_at_use] and join with it.
+
+ - The variable doesn't exist in this environment. This happens
+ if the variable is defined in one of the other branches, and
+ will be quantified existentially in the result. In this case,
+ it's safe to join with Bottom. *)
+ let is_defined_at_use = TE.mem env_at_use name in
+ if is_defined_at_use
+ then
+ let use_ty =
+ let expected_kind = Some (TG.kind joined_ty) in
+ TE.find env_at_use name expected_kind
+ in
+ joined_ty, use_ty
+ else joined_ty, MTC.bottom_like joined_ty
+ | Some joined_ty, Some use_ty -> joined_ty, use_ty
+ | None, None -> assert false
+ in
+ let join_env =
+ 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
+ with
+ | Known joined_ty -> Some joined_ty
+ | Unknown -> None
+ in
+ Name.Map.merge join_types joined_types (TEL.equations t))
+
+let construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types
+ ~params =
+ let allowed_and_new =
+ (* Parameters are already in the resulting environment *)
+ List.fold_left
+ (fun allowed_and_new param ->
+ Name_occurrences.remove_var allowed_and_new
+ ~var:(Bound_parameter.var param))
+ allowed params
+ in
+ let variable_is_in_new_level var =
+ Name_occurrences.mem_var allowed_and_new var
+ in
+ let defined_vars, binding_times =
+ List.fold_left
+ (fun (defined_vars, binding_times) (_env_at_use, _id, _use_kind, t) ->
+ let defined_vars_this_level =
+ Variable.Map.filter
+ (fun var _ -> variable_is_in_new_level var)
+ (TEL.defined_variables_with_kinds t)
+ in
+ let defined_vars =
+ Variable.Map.union
+ (fun var kind1 kind2 ->
+ if K.equal kind1 kind2
+ then Some kind1
+ else
+ Misc.fatal_errorf
+ "Cannot join levels that disagree on the kind of \
+ [defined_vars] (%a and %a for %a)"
+ K.print kind1 K.print kind2 Variable.print var)
+ defined_vars defined_vars_this_level
+ in
+ let binding_times_this_level =
+ Binding_time.Map.filter_map
+ (fun _ vars ->
+ let vars = Variable.Set.filter variable_is_in_new_level vars in
+ if Variable.Set.is_empty vars then None else Some vars)
+ (TEL.variables_by_binding_time t)
+ in
+ let binding_times =
+ Binding_time.Map.union
+ (fun _bt vars1 vars2 -> Some (Variable.Set.union vars1 vars2))
+ binding_times binding_times_this_level
+ in
+ defined_vars, binding_times)
+ (Variable.Map.empty, Binding_time.Map.empty)
+ envs_with_levels
+ in
+ let equations =
+ Name.Map.filter
+ (fun name _ty -> Name_occurrences.mem_name allowed name)
+ joined_types
+ in
+ let symbol_projections =
+ List.fold_left
+ (fun symbol_projections (_env_at_use, _id, _use_kind, t) ->
+ let projs_this_level =
+ Variable.Map.filter
+ (fun var _ ->
+ let name = Name.var var in
+ TE.mem ~min_name_mode:Name_mode.normal env_at_fork name
+ || Name_occurrences.mem_name allowed name)
+ (TEL.symbol_projections t)
+ in
+ Variable.Map.union
+ (fun _var proj1 proj2 ->
+ if Symbol_projection.equal proj1 proj2 then Some proj1 else None)
+ symbol_projections projs_this_level)
+ Variable.Map.empty envs_with_levels
+ in
+ TEL.create ~defined_vars ~binding_times ~equations ~symbol_projections
+
+let check_join_inputs ~env_at_fork _envs_with_levels ~params
+ ~extra_lifted_consts_in_use_envs =
+ (* It might seem as if every name defined in [env_at_fork], with the exception
+ of the lifted constant symbols, should occur in every use environment.
+ However this is not the case: the introduction of the lifted constants into
+ [env_at_fork] in [Simplify_expr] may have produced [In_types] variables
+ (from [make_suitable_for_environment]) that will not be present in any use
+ environment. *)
+ List.iter
+ (fun param ->
+ if not (TE.mem env_at_fork (Bound_parameter.name param))
+ then
+ Misc.fatal_errorf "Parameter %a not defined in [env_at_fork] at join"
+ Bound_parameter.print param)
+ params;
+ Symbol.Set.iter
+ (fun symbol ->
+ if not (TE.mem env_at_fork (Name.symbol symbol))
+ then
+ Misc.fatal_errorf
+ "Symbol %a, which is a new lifted constant that arose during the \
+ simplification of the continuation's body, is not defined in the \
+ [env_at_fork] when calling [join]"
+ Symbol.print symbol)
+ extra_lifted_consts_in_use_envs
+
+let join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs
+ ~extra_allowed_names:allowed =
+ check_join_inputs ~env_at_fork envs_with_levels ~params
+ ~extra_lifted_consts_in_use_envs;
+ (* Calculate the joined types of all the names involved. *)
+ let joined_types = join_types ~env_at_fork envs_with_levels in
+ (* Next calculate which equations (describing joined types) to propagate to
+ the join point. (Recall that the environment at the fork point includes the
+ parameters of the continuation being called at the join. We wish to ensure
+ that information in the types of these parameters is not lost.)
+
+ - Equations on names defined in the environment at the fork point are
+ always propagated.
+
+ - Definitions of, and equations on, names that occur free on the right-hand
+ sides of the propagated equations are also themselves propagated. The
+ definition of any such propagated name (i.e. one that does not occur in the
+ environment at the fork point) will be made existential. *)
+ let free_names_transitive typ =
+ (* We need to compute the free names of joined_types, but we can't use a
+ typing environment. *)
+ let rec free_names_transitive0 typ ~result =
+ let free_names = TG.free_names typ in
+ let to_traverse = Name_occurrences.diff free_names ~without:result in
+ Name_occurrences.fold_names to_traverse ~init:result
+ ~f:(fun result name ->
+ let result =
+ Name_occurrences.add_name result name Name_mode.in_types
+ in
+ match Name.Map.find name joined_types with
+ | exception Not_found -> result
+ | typ -> free_names_transitive0 typ ~result)
+ in
+ free_names_transitive0 typ ~result:Name_occurrences.empty
+ in
+ let allowed =
+ Name.Map.fold
+ (fun name ty allowed ->
+ if TE.mem env_at_fork name || Name.is_symbol name
+ then
+ Name_occurrences.add_name
+ (Name_occurrences.union allowed (free_names_transitive ty))
+ name Name_mode.in_types
+ else allowed)
+ joined_types allowed
+ in
+ let allowed =
+ Symbol.Set.fold
+ (fun symbol allowed ->
+ Name_occurrences.add_symbol allowed symbol Name_mode.in_types)
+ extra_lifted_consts_in_use_envs allowed
+ in
+ (* Having calculated which equations to propagate, the resulting level can now
+ be constructed. *)
+ ( construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types
+ ~params,
+ Name_occurrences.fold_names allowed ~init:Name.Set.empty
+ ~f:(fun names name -> Name.Set.add name names) )
+
+let n_way_join ~env_at_fork envs_with_levels ~params
+ ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
+ match envs_with_levels with
+ | [] -> TEL.empty, Name.Set.empty
+ | envs_with_levels ->
+ join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs
+ ~extra_allowed_names
+
+let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
+ ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
+ let after_cuts =
+ List.map
+ (fun (t, use_id, use_kind) ->
+ let level = TE.cut t ~cut_after in
+ t, use_id, use_kind, level)
+ ts_and_use_ids
+ in
+ let params = Bound_parameters.to_list params in
+ let level, alias_candidates =
+ n_way_join ~env_at_fork:definition_typing_env after_cuts ~params
+ ~extra_lifted_consts_in_use_envs ~extra_allowed_names
+ in
+ let result_env =
+ TE.add_env_extension_from_level definition_typing_env level
+ ~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)
diff --git a/middle_end/flambda2/types/join_levels_old.mli b/middle_end/flambda2/types/join_levels_old.mli
new file mode 100644
index 00000000000..79bb3911f8d
--- /dev/null
+++ b/middle_end/flambda2/types/join_levels_old.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Pierre Chambart, OCamlPro *)
+(* Mark Shinwell and Leo White, Jane Street Europe *)
+(* *)
+(* Copyright 2013--2019 OCamlPro SAS *)
+(* Copyright 2014--2019 Jane Street Group LLC *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(** Compute the typing environment for a join point given the environments at
+ each of the corresponding continuation's uses. *)
+
+val cut_and_n_way_join :
+ Typing_env.t ->
+ (Typing_env.t * Apply_cont_rewrite_id.t * Continuation_use_kind.t) list ->
+ params:Bound_parameters.t ->
+ cut_after:Scope.t ->
+ extra_lifted_consts_in_use_envs:Symbol.Set.t ->
+ extra_allowed_names:Name_occurrences.t ->
+ Typing_env.t
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml
index 269f37da343..da83b9cd047 100644
--- a/middle_end/flambda2/types/meet_and_n_way_join.ml
+++ b/middle_end/flambda2/types/meet_and_n_way_join.ml
@@ -14,24 +14,14 @@
(* *)
(**************************************************************************)
-module Join_env = Typing_env.Join_env
module ET = Expand_head.Expanded_type
module K = Flambda_kind
module MTC = More_type_creators
module TG = Type_grammar
module TE = Typing_env
module TEE = Typing_env_extension
+module TEL = Typing_env_level
module Vec128 = Vector_types.Vec128.Bit_pattern
-open Or_unknown.Let_syntax
-
-let all_aliases_of env simple_opt ~in_env =
- match simple_opt with
- | None -> Aliases.Alias_set.empty
- | Some simple ->
- let simples = TE.aliases_of_simple_allowable_in_types env simple in
- Aliases.Alias_set.filter
- ~f:(fun simple -> TE.mem_simple in_env simple)
- simples
type 'a meet_return_value = 'a TE.meet_return_value =
| Left_input
@@ -50,6 +40,12 @@ type 'a meet_result =
| Bottom of unit meet_return_value
| Ok of 'a meet_return_value * TE.t
+type 'a n_way_join_result = 'a Or_unknown.t * Join_env.t
+
+let map_join_result ~f (v, env) = Or_unknown.map ~f v, env
+
+let ( let>+ ) x f = map_join_result ~f x
+
let add_equation (simple : Simple.t) ty_of_simple env ~meet_type :
unit meet_result =
let name name ~coercion:coercion_from_name_to_simple =
@@ -283,19 +279,25 @@ type ext =
when_b : TEE.t
}
-let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
- ~join_env_extension initial_env val_a1 val_b1 extensions1 val_a2 val_b2
- extensions2 =
+let add_defined_vars env level =
+ TEL.fold_on_defined_vars
+ (fun var kind env ->
+ TE.add_definition env
+ (Bound_name.create_var (Bound_var.create var Name_mode.in_types))
+ kind)
+ level env
+
+let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type ~n_way_join
+ initial_env val_a1 val_b1 extensions1 val_a2 val_b2 extensions2 =
let join_scope = TE.current_scope initial_env in
let env = TE.increment_scope initial_env in
- let to_extension scoped_env =
- TE.cut scoped_env ~cut_after:join_scope
- |> Typing_env_level.as_extension_without_bindings
- in
let direct_return r =
map_env r ~f:(fun scoped_env ->
- TE.add_env_extension_strict initial_env (to_extension scoped_env)
- ~meet_type)
+ (* Need to cut as a level because we could have added new variables. *)
+ let level = TE.cut scoped_env ~cut_after:join_scope in
+ let initial_env = add_defined_vars initial_env level in
+ let ext = TEE.from_map (TEL.equations level) in
+ TE.add_env_extension_strict initial_env ext ~meet_type)
in
let env_a, env_b = Or_bottom.Ok env, Or_bottom.Ok env in
let env_a, env_b =
@@ -346,17 +348,30 @@ let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
in
direct_return (Ok (result, env))
| Ok (a_result, env_a), Ok (b_result, env_b) ->
- let when_a = to_extension env_a in
- let when_b = to_extension env_b in
+ let result_env =
+ (* Not strict, as we don't expect to be able to get bottom equations from
+ joining non-bottom ones *)
+ Join_env.cut_and_n_way_join ~meet_type ~n_way_join_type:n_way_join
+ ~cut_after:join_scope initial_env [env_a; env_b]
+ in
+ let when_a_level = TE.cut env_a ~cut_after:join_scope in
+ let when_b_level = TE.cut env_b ~cut_after:join_scope in
+ (* Either [meet_a] or [meet_b] could have introduced new variables, which
+ need to be added to the result environment. *)
+ let result_env = add_defined_vars result_env when_a_level in
+ let result_env = add_defined_vars result_env when_b_level in
let extensions =
- if TEE.is_empty when_a && TEE.is_empty when_b
+ if TEL.is_empty when_a_level && TEL.is_empty when_b_level
then
No_extensions
(* CR vlaviron: If both extensions have equations in common, the join
below will add them to the result environment. Keeping those common
equations in the variant extensions then becomes redundant, but we
don't have an easy way to detect redundancy. *)
- else Ext { when_a; when_b }
+ else
+ let when_a = TEE.from_map (TEL.equations when_a_level) in
+ let when_b = TEE.from_map (TEL.equations when_b_level) in
+ Ext { when_a; when_b }
in
let env_extension_result =
(* We only catch the cases where empty extensions are preserved *)
@@ -378,15 +393,6 @@ let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
let val_b = extract_value b_result val_b1 val_b2 in
val_a, val_b, extensions)
in
- let join_env =
- Join_env.create initial_env ~left_env:env_a ~right_env:env_b
- in
- let result_extension = join_env_extension join_env when_a when_b in
- let result_env =
- (* Not strict, as we don't expect to be able to get bottom equations from
- joining non-bottom ones *)
- TE.add_env_extension initial_env result_extension ~meet_type
- in
Ok (result, result_env)
let meet_code_id (env : TE.t) (code_id1 : Code_id.t) (code_id2 : Code_id.t) :
@@ -447,12 +453,82 @@ let[@inline always] meet_unknown meet_contents ~contents_is_bottom env
| Known contents1, Known contents2 ->
map_result ~f:Or_unknown.known (meet_contents env contents1 contents2)
-let[@inline always] join_unknown join_contents (env : Join_env.t)
- (or_unknown1 : _ Or_unknown.t) (or_unknown2 : _ Or_unknown.t) :
- _ Or_unknown.t =
- match or_unknown1, or_unknown2 with
- | _, Unknown | Unknown, _ -> Unknown
- | Known contents1, Known contents2 -> join_contents env contents1 contents2
+let[@inline always] n_way_join_unknown n_way_join_contents (env : Join_env.t)
+ or_unknowns : _ n_way_join_result =
+ let exception Unknown_result in
+ try
+ n_way_join_contents env
+ (List.fold_left
+ (fun acc (id, or_unknown) ->
+ match (or_unknown : _ Or_unknown.t) with
+ | Known contents -> (id, contents) :: acc
+ | Unknown -> raise Unknown_result)
+ [] or_unknowns)
+ with Unknown_result -> Unknown, env
+
+let[@inline always] n_way_join_head_of_kind_naked_number ~union env (t1, _) ts :
+ _ n_way_join_result =
+ Known (List.fold_left (fun t1 (_, t2) -> union t1 t2) t1 ts), env
+
+let generic_merge_map_known :
+ 'index 'value 'map 'maps 'other.
+ filter_map:
+ (('index -> 'value Join_env.join_arg list -> 'value option) ->
+ 'maps ->
+ 'map) ->
+ map:((_ -> _ Join_env.join_arg list) -> 'map -> 'maps) ->
+ merge:
+ ((_ ->
+ 'value Join_env.join_arg list option ->
+ 'value option ->
+ 'value Join_env.join_arg list option) ->
+ 'maps ->
+ 'map ->
+ 'maps) ->
+ bottom:'map ->
+ other:('other -> 'value) ->
+ (Join_env.t ->
+ 'value Join_env.join_arg list ->
+ ('value * Join_env.t) Or_bottom.t) ->
+ Join_env.t ->
+ ('map * 'other Or_bottom.t) Join_env.join_arg list ->
+ 'map * Join_env.t =
+ fun ~filter_map ~map ~merge ~bottom ~other n_way_join env maps ->
+ match maps with
+ | [] -> bottom, env
+ | (id1, (map1, other1)) :: maps ->
+ let add_other acc id other_or_bottom =
+ match (other_or_bottom : 'other Or_bottom.t) with
+ | Bottom -> acc
+ | Ok known -> (id, other known) :: acc
+ in
+ let maps, _ =
+ List.fold_left
+ (fun (maps, others) (id2, (map2, other2)) ->
+ ( merge
+ (fun _ vals_opt val2_opt ->
+ match vals_opt, val2_opt with
+ | None, None -> None
+ | None, Some val2 -> Some ((id2, val2) :: others)
+ | Some vals, None -> Some (add_other vals id2 other2)
+ | Some vals, Some val2 -> Some ((id2, val2) :: vals))
+ maps map2,
+ add_other others id2 other2 ))
+ (map (fun val1 -> [id1, val1]) map1, add_other [] id1 other1)
+ maps
+ in
+ let env_ref = ref env in
+ let maps =
+ filter_map
+ (fun _index values ->
+ match n_way_join !env_ref values with
+ | Bottom -> None
+ | Ok (value, env) ->
+ env_ref := env;
+ Some value)
+ maps
+ in
+ maps, !env_ref
(* Note: Bottom is a valid element kind for empty arrays, so this function never
leads to a general Bottom result *)
@@ -668,9 +744,8 @@ and meet_head_of_kind_value env
map_result
~f:(fun (non_null, is_null, _extensions) : TG.head_of_kind_value ->
{ non_null; is_null })
- (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
- ~join_env_extension env non_null1 is_null1 No_extensions non_null2
- is_null2 No_extensions)
+ (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type ~n_way_join
+ env non_null1 is_null1 No_extensions non_null2 is_null2 No_extensions)
and meet_head_of_kind_value_non_null env
(head1 : TG.head_of_kind_value_non_null)
@@ -924,9 +999,8 @@ and meet_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t)
Ext { when_immediate; when_block }
in
blocks, imms, extensions)
- (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type
- ~join_env_extension env imms1 blocks1 extensions1 imms2 blocks2
- extensions2)
+ (meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type ~n_way_join
+ env imms1 blocks1 extensions1 imms2 blocks2 extensions2)
and meet_head_of_kind_naked_immediate env (t1 : TG.head_of_kind_naked_immediate)
(t2 : TG.head_of_kind_naked_immediate) :
@@ -1119,14 +1193,42 @@ and meet_row_like :
~is_empty_map_known ~get_singleton_map_known ~merge_map_known initial_env
~known1 ~known2 ~other1 ~other2 ->
let common_scope = TE.current_scope initial_env in
+ (* Keep track of the variables used by all extensions and lift them to the
+ result env in [extract_and_join_extensions]. *)
+ let extra_variables = ref Variable.Map.empty in
let base_env = TE.increment_scope initial_env in
- let extract_extension scoped_env =
- TE.cut_as_extension scoped_env ~cut_after:common_scope
+ let add_extra_variables_and_extract_extension scoped_env =
+ let level = TE.cut scoped_env ~cut_after:common_scope in
+ extra_variables
+ := Variable.Map.union
+ (fun var k1 k2 ->
+ if not (K.equal k1 k2)
+ then Misc.fatal_errorf "Different kinds for %a" Variable.print var;
+ Some k1)
+ !extra_variables
+ (TEL.defined_variables_with_kinds level);
+ TEE.from_map (TEL.equations level)
+ in
+ let extract_and_join_extensions scoped_envs =
+ (* We add the extra variables after the join, because some of the extra
+ variables could appear in one of the [scoped_envs] and the join expects
+ that variables defined in the central env are defined in all the joined
+ envs. *)
+ let result_env =
+ Join_env.cut_and_n_way_join ~n_way_join_type:n_way_join ~meet_type
+ ~cut_after:common_scope initial_env scoped_envs
+ in
+ Variable.Map.fold
+ (fun var kind env ->
+ TE.add_definition env
+ (Bound_name.create_var (Bound_var.create var Name_mode.in_types))
+ kind)
+ !extra_variables result_env
in
let open struct
type result_env =
| No_result
- | Extension of TEE.t
+ | Extension of TE.t list
end in
let result_env = ref No_result in
let need_join =
@@ -1172,15 +1274,10 @@ and meet_row_like :
let join_result_env scoped_env =
let new_result_env =
match !result_env with
- | No_result -> Extension (extract_extension scoped_env)
- | Extension ext1 ->
+ | No_result -> Extension [scoped_env]
+ | Extension other_envs ->
assert need_join;
- let ext2 = extract_extension scoped_env in
- let join_env =
- Join_env.create base_env ~left_env:base_env ~right_env:scoped_env
- in
- let extension = join_env_extension join_env ext1 ext2 in
- Extension extension
+ Extension (scoped_env :: other_envs)
in
result_env := new_result_env
in
@@ -1252,7 +1349,9 @@ and meet_row_like :
extract_value maps_to_result case1.maps_to case2.maps_to
in
let env_extension =
- if need_join then extract_extension env else TEE.empty
+ if need_join
+ then add_extra_variables_and_extract_extension env
+ else TEE.empty
in
if TEE.is_empty env_extension
then ()
@@ -1361,7 +1460,10 @@ and meet_row_like :
let env : _ Or_bottom.t =
match !result_env with
| No_result -> Bottom
- | Extension ext -> TE.add_env_extension_strict initial_env ext ~meet_type
+ | Extension scoped_envs ->
+ (* We used add_env_extension_strict here before, but we don't expect to
+ get bottom equations from joining non-bottom ones. *)
+ Or_bottom.Ok (extract_and_join_extensions scoped_envs)
in
let match_with_input v =
match !result_is_t1, !result_is_t2 with
@@ -1526,417 +1628,616 @@ and meet_type env t1 t2 : _ Or_bottom.t =
| Ok (res, env) -> Ok (res, env)
| Bottom _ -> Bottom
-and join ?bound_name env (t1 : TG.t) (t2 : TG.t) : TG.t Or_unknown.t =
- (* Kind mismatches should have been caught (either turned into Invalid or a
- fatal error) before we get here. *)
- if not (K.equal (TG.kind t1) (TG.kind t2))
- then
- Misc.fatal_errorf "Kind mismatch upon join:@ %a@ versus@ %a" TG.print t1
- TG.print t2;
- let kind = TG.kind t1 in
- let canonical_simple1 =
- match
- TE.get_alias_then_canonical_simple_exn
- (Join_env.left_join_env env)
- t1 ~min_name_mode:Name_mode.in_types
- with
- | exception Not_found -> None
- | canonical_simple -> Some canonical_simple
- in
- let canonical_simple2 =
- match
- TE.get_alias_then_canonical_simple_exn
- (Join_env.right_join_env env)
- t2 ~min_name_mode:Name_mode.in_types
- with
- | exception Not_found -> None
- | canonical_simple -> Some canonical_simple
- in
- let expanded1 =
- Expand_head.expand_head0
- (Join_env.left_join_env env)
- t1 ~known_canonical_simple_at_in_types_mode:canonical_simple1
- in
- let expanded2 =
- Expand_head.expand_head0
- (Join_env.right_join_env env)
- t2 ~known_canonical_simple_at_in_types_mode:canonical_simple2
+and n_way_join env (ts : _ Join_env.join_arg list) : TG.t n_way_join_result =
+ let kind =
+ match ts with
+ | [] -> Misc.fatal_error "N-way join of zero types"
+ | (_, t1) :: ts ->
+ let kind = TG.kind t1 in
+ if not (List.for_all (fun (_, t) -> K.equal kind (TG.kind t)) ts)
+ then
+ Misc.fatal_errorf "Kind mismatch upon join:@ %a"
+ (Format.pp_print_list
+ ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ versus@ ")
+ TG.print)
+ (List.map snd ts);
+ kind
in
- let shared_aliases =
- let shared_aliases =
- match
- ( canonical_simple1,
- ET.descr expanded1,
- canonical_simple2,
- ET.descr expanded2 )
- with
- | None, _, None, _
- | None, (Ok _ | Unknown), _, _
- | _, _, None, (Ok _ | Unknown) ->
- Aliases.Alias_set.empty
- | Some simple1, _, _, Bottom -> Aliases.Alias_set.singleton simple1
- | _, Bottom, Some simple2, _ -> Aliases.Alias_set.singleton simple2
- | Some simple1, _, Some simple2, _ ->
- if Simple.same simple1 simple2
- then Aliases.Alias_set.singleton simple1
- else
- Aliases.Alias_set.inter
- (all_aliases_of
- (Join_env.left_join_env env)
- canonical_simple1
- ~in_env:(Join_env.target_join_env env))
- (all_aliases_of
- (Join_env.right_join_env env)
- canonical_simple2
- ~in_env:(Join_env.target_join_env env))
+ let ts = List.filter (fun (_, ty) -> not (TG.is_obviously_bottom ty)) ts in
+ match
+ List.map
+ (fun (id, ty) ->
+ ( id,
+ TE.get_alias_then_canonical_simple_exn
+ ~min_name_mode:Name_mode.in_types
+ (Join_env.joined_env env id)
+ ty ))
+ ts
+ with
+ | canonical_simples -> (
+ match Join_env.n_way_join_simples env kind canonical_simples with
+ | Bottom, join_env -> Known (MTC.bottom kind), join_env
+ | Ok simple, join_env -> Known (TG.alias_type_of kind simple), join_env)
+ | exception Not_found ->
+ (* CR vlaviron: Fix this to return Unknown when Product can handle it *)
+ map_join_result ~f:ET.to_type
+ (n_way_join_expanded_head env kind
+ (List.map
+ (fun (id, ty) ->
+ id, Expand_head.expand_head (Join_env.joined_env env id) ty)
+ ts))
+
+and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
+ : ET.t n_way_join_result =
+ match expandeds with
+ | [] -> Known (ET.create_bottom kind), env
+ | (id1, expanded1) :: expandeds -> (
+ let exception Unknown_result in
+ let[@inline always] extract_head_exn extract expandeds =
+ List.filter_map
+ (fun (id2, expanded2) ->
+ match ET.descr expanded2 with
+ | Bottom -> None
+ | Unknown -> raise Unknown_result
+ | Ok head2 -> Some (id2, extract head2))
+ expandeds
in
- match bound_name with
- | None -> shared_aliases
- | Some bound_name ->
- (* We only return one type for each name, so we have to decide whether to
- return an alias or an expanded head. Usually we prefer aliases, because
- we hope that the alias itself will have a concrete equation anyway, but
- we must be careful to ensure that we don't return aliases to self
- (obviously wrong) or, if two variables [x] and [y] alias each other,
- redundant equations [x : (= y)] and [y : (= x)]. *)
- Aliases.Alias_set.filter
- ~f:(fun alias ->
- TE.alias_is_bound_strictly_earlier
- (Join_env.target_join_env env)
- ~bound_name ~alias)
- shared_aliases
- in
- let unknown () : _ Or_unknown.t =
- (* CR vlaviron: Fix this to Unknown when Product can handle it *)
- Known (MTC.unknown kind)
- in
- match Aliases.Alias_set.find_best shared_aliases with
- | Some alias -> Known (TG.alias_type_of kind alias)
- | None -> (
- match canonical_simple1, canonical_simple2 with
- | Some simple1, Some simple2
- when Join_env.already_joining env simple1 simple2 ->
- unknown ()
- | Some _, Some _ | Some _, None | None, Some _ | None, None -> (
- let join_heads env : _ Or_unknown.t =
- Known (ET.to_type (join_expanded_head env kind expanded1 expanded2))
+ match ET.descr expanded1 with
+ | Bottom -> n_way_join_expanded_head env kind expandeds
+ | Unknown -> Known (ET.create_unknown kind), env
+ | Ok descr1 -> (
+ let expanded_or_unknown, env =
+ try
+ match descr1 with
+ | Value head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Value head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_value env ((id1, head1) :: heads)
+ in
+ ET.create_value head
+ | Naked_immediate head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_immediate head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_immediate env ((id1, head1) :: heads)
+ in
+ ET.create_naked_immediate head
+ | Naked_float32 head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_float32 head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_float32 env (head1, id1) heads
+ in
+ ET.create_naked_float32 head
+ | Naked_float head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_float head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_float env (head1, id1) heads
+ in
+ ET.create_naked_float head
+ | Naked_int32 head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_int32 head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_int32 env (head1, id1) heads
+ in
+ ET.create_naked_int32 head
+ | Naked_int64 head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_int64 head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_int64 env (head1, id1) heads
+ in
+ ET.create_naked_int64 head
+ | Naked_nativeint head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_nativeint head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_nativeint env (head1, id1) heads
+ in
+ ET.create_naked_nativeint head
+ | Naked_vec128 head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Naked_vec128 head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_naked_vec128 env (head1, id1) heads
+ in
+ ET.create_naked_vec128 head
+ | Rec_info head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Rec_info head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_rec_info env (head1, id1) heads
+ in
+ ET.create_rec_info head
+ | Region head1 ->
+ let heads =
+ extract_head_exn
+ (function[@warning "-fragile-match"]
+ | Region head -> head | _ -> assert false)
+ expandeds
+ in
+ let>+ head =
+ n_way_join_head_of_kind_region env (head1, id1) heads
+ in
+ ET.create_region head
+ with Unknown_result -> Or_unknown.Unknown, env
in
- match canonical_simple1, canonical_simple2 with
- | Some simple1, Some simple2 -> (
- match Join_env.now_joining env simple1 simple2 with
- | Continue env -> join_heads env
- | Stop -> unknown ())
- | Some _, None | None, Some _ | None, None -> join_heads env))
-
-and join_expanded_head env kind (expanded1 : ET.t) (expanded2 : ET.t) : ET.t =
- match ET.descr expanded1, ET.descr expanded2 with
- | Bottom, Bottom -> ET.create_bottom kind
- (* The target environment defines all the names from the left and right
- environments, so we can safely return any input as the result *)
- | Ok _, Bottom -> expanded1
- | Bottom, Ok _ -> expanded2
- | Unknown, _ | _, Unknown -> ET.create_unknown kind
- | Ok descr1, Ok descr2 -> (
- let expanded_or_unknown =
- match descr1, descr2 with
- | Value head1, Value head2 ->
- let>+ head = join_head_of_kind_value env head1 head2 in
- ET.create_value head
- | Naked_immediate head1, Naked_immediate head2 ->
- let>+ head = join_head_of_kind_naked_immediate env head1 head2 in
- ET.create_naked_immediate head
- | Naked_float32 head1, Naked_float32 head2 ->
- let>+ head = join_head_of_kind_naked_float32 env head1 head2 in
- ET.create_naked_float32 head
- | Naked_float head1, Naked_float head2 ->
- let>+ head = join_head_of_kind_naked_float env head1 head2 in
- ET.create_naked_float head
- | Naked_int32 head1, Naked_int32 head2 ->
- let>+ head = join_head_of_kind_naked_int32 env head1 head2 in
- ET.create_naked_int32 head
- | Naked_int64 head1, Naked_int64 head2 ->
- let>+ head = join_head_of_kind_naked_int64 env head1 head2 in
- ET.create_naked_int64 head
- | Naked_nativeint head1, Naked_nativeint head2 ->
- let>+ head = join_head_of_kind_naked_nativeint env head1 head2 in
- ET.create_naked_nativeint head
- | Naked_vec128 head1, Naked_vec128 head2 ->
- let>+ head = join_head_of_kind_naked_vec128 env head1 head2 in
- ET.create_naked_vec128 head
- | Rec_info head1, Rec_info head2 ->
- let>+ head = join_head_of_kind_rec_info env head1 head2 in
- ET.create_rec_info head
- | Region head1, Region head2 ->
- let>+ head = join_head_of_kind_region env head1 head2 in
- ET.create_region head
- | ( ( Value _ | Naked_immediate _ | Naked_float _ | Naked_float32 _
- | Naked_int32 _ | Naked_vec128 _ | Naked_int64 _ | Naked_nativeint _
- | Rec_info _ | Region _ ),
- _ ) ->
- assert false
- in
- match expanded_or_unknown with
- | Known expanded -> expanded
- | Unknown -> ET.unknown_like expanded1)
-
-and join_head_of_kind_value env (head1 : TG.head_of_kind_value)
- (head2 : TG.head_of_kind_value) : TG.head_of_kind_value Or_unknown.t =
- let non_null : _ Or_unknown_or_bottom.t =
- match head1.non_null, head2.non_null with
- | Unknown, _ | _, Unknown -> Unknown
- | Bottom, x | x, Bottom -> x
- | Ok head1, Ok head2 -> (
- match join_head_of_kind_value_non_null env head1 head2 with
- | Unknown -> Unknown
- | Known head -> Ok head)
- in
+ match expanded_or_unknown with
+ | Known expanded -> Known expanded, env
+ | Unknown -> Known (ET.unknown_like expanded1), env))
+
+and n_way_join_head_of_kind_value env
+ (heads : TG.head_of_kind_value Join_env.join_arg list) :
+ TG.head_of_kind_value n_way_join_result =
let is_null : TG.is_null =
- match head1.is_null, head2.is_null with
- | Maybe_null, _ | _, Maybe_null -> Maybe_null
- | Not_null, Not_null -> Not_null
+ match heads with
+ | [] -> Not_null
+ | (_, head1) :: heads -> (
+ match head1.is_null with
+ | Maybe_null -> Maybe_null
+ | Not_null ->
+ if List.for_all
+ (fun (_, (head2 : TG.head_of_kind_value)) ->
+ match head2.is_null with Not_null -> true | Maybe_null -> false)
+ heads
+ then Not_null
+ else Maybe_null)
+ in
+ let non_null : _ Or_unknown_or_bottom.t * _ =
+ let exception Unknown_result in
+ try
+ let non_nulls =
+ List.fold_left
+ (fun non_null (id2, (head2 : TG.head_of_kind_value)) ->
+ match head2.non_null with
+ | Unknown -> raise Unknown_result
+ | Bottom -> non_null
+ | Ok head_of_kind_value_non_null ->
+ (id2, head_of_kind_value_non_null) :: non_null)
+ [] heads
+ in
+ match non_nulls with
+ | [] -> Bottom, env
+ | _ :: _ -> (
+ match n_way_join_head_of_kind_value_non_null env non_nulls with
+ | Unknown, env -> Unknown, env
+ | Known head, env -> Ok head, env)
+ with Unknown_result -> Unknown, env
in
match[@warning "-4"] non_null, is_null with
- | Unknown, Maybe_null -> Unknown
- | _, _ -> Known { non_null; is_null }
-
-and join_head_of_kind_value_non_null env
- (head1 : TG.head_of_kind_value_non_null)
- (head2 : TG.head_of_kind_value_non_null) :
- TG.head_of_kind_value_non_null Or_unknown.t =
- match head1, head2 with
- | ( Variant
- { blocks = blocks1;
- immediates = imms1;
- extensions = extensions1;
- is_unique = is_unique1
- },
- Variant
- { blocks = blocks2;
- immediates = imms2;
- extensions = extensions2;
- is_unique = is_unique2
- } ) ->
- let>+ blocks, immediates, extensions =
- join_variant env ~blocks1 ~imms1 ~extensions1 ~blocks2 ~imms2 ~extensions2
- in
- (* Uniqueness tracks whether duplication/lifting is allowed. It must always
- be propagated, both for meet and join. *)
- let is_unique = is_unique1 || is_unique2 in
- TG.Head_of_kind_value_non_null.create_variant ~is_unique ~blocks ~immediates
- ~extensions
- | ( Mutable_block { alloc_mode = alloc_mode1 },
- Mutable_block { alloc_mode = alloc_mode2 } ) ->
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- Known (TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode)
- | Boxed_float32 (n1, alloc_mode1), Boxed_float32 (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_float32 n alloc_mode
- | Boxed_float (n1, alloc_mode1), Boxed_float (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_float n alloc_mode
- | Boxed_int32 (n1, alloc_mode1), Boxed_int32 (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_int32 n alloc_mode
- | Boxed_int64 (n1, alloc_mode1), Boxed_int64 (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_int64 n alloc_mode
- | Boxed_nativeint (n1, alloc_mode1), Boxed_nativeint (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_nativeint n alloc_mode
- | Boxed_vec128 (n1, alloc_mode1), Boxed_vec128 (n2, alloc_mode2) ->
- let>+ n = join env n1 n2 in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Head_of_kind_value_non_null.create_boxed_vec128 n alloc_mode
- | ( Closures { by_function_slot = by_function_slot1; alloc_mode = alloc_mode1 },
- Closures
- { by_function_slot = by_function_slot2; alloc_mode = alloc_mode2 } ) ->
- let by_function_slot =
- join_row_like_for_closures env by_function_slot1 by_function_slot2
- in
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- Known
- (TG.Head_of_kind_value_non_null.create_closures by_function_slot
- alloc_mode)
- | String strs1, String strs2 ->
- let strs = String_info.Set.union strs1 strs2 in
- Known (TG.Head_of_kind_value_non_null.create_string strs)
- | ( Array
- { element_kind = element_kind1;
- length = length1;
- contents = array_contents1;
- alloc_mode = alloc_mode1
- },
- Array
- { element_kind = element_kind2;
- length = length2;
- contents = array_contents2;
- alloc_mode = alloc_mode2
- } ) ->
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- let element_kind = join_array_element_kinds element_kind1 element_kind2 in
- let contents =
- join_array_contents env array_contents1 array_contents2
- ~joined_element_kind:element_kind
- in
- let>+ length = join env length1 length2 in
- TG.Head_of_kind_value_non_null.create_array_with_contents ~element_kind
- ~length contents alloc_mode
- | ( ( Variant _ | Mutable_block _ | Boxed_float _ | Boxed_float32 _
- | Boxed_int32 _ | Boxed_vec128 _ | Boxed_int64 _ | Boxed_nativeint _
- | Closures _ | String _ | Array _ ),
- _ ) ->
- Unknown
-
-and join_array_contents env (array_contents1 : TG.array_contents Or_unknown.t)
- (array_contents2 : TG.array_contents Or_unknown.t)
- ~(joined_element_kind : _ Or_unknown_or_bottom.t) =
- join_unknown
- (fun env (array_contents1 : TG.array_contents)
- (array_contents2 : TG.array_contents) : TG.array_contents Or_unknown.t ->
- match array_contents1, array_contents2 with
- | Mutable, Mutable -> Known TG.Mutable
- | Mutable, Immutable _ | Immutable _, Mutable -> Unknown
- | Immutable { fields = fields1 }, Immutable { fields = fields2 } -> (
- if Array.length fields1 <> Array.length fields2
- then Unknown
- else
- match joined_element_kind with
- | Bottom | Unknown -> Unknown
- | Ok _ -> (
- let exception Unknown_result in
- try
- let fields =
- Array.init (Array.length fields1) (fun idx ->
- match join env fields1.(idx) fields2.(idx) with
- | Unknown -> raise Unknown_result
- | Known ty -> ty)
- in
- Known (TG.Immutable { fields })
- with Unknown_result -> Unknown)))
- env array_contents1 array_contents2
-
-and join_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t)
- ~(imms1 : TG.t Or_unknown.t) ~(extensions1 : TG.variant_extensions)
- ~(blocks2 : TG.Row_like_for_blocks.t Or_unknown.t)
- ~(imms2 : TG.t Or_unknown.t) ~(extensions2 : TG.variant_extensions) :
+ | (Unknown, env), Maybe_null -> Unknown, env
+ | (non_null, env), _ -> Known { non_null; is_null }, env
+
+and n_way_join_head_of_kind_value_non_null env
+ (heads : TG.head_of_kind_value_non_null Join_env.join_arg list) :
+ TG.head_of_kind_value_non_null n_way_join_result =
+ match heads with
+ | [] -> Misc.fatal_error "No n-way join of head of kind value non null"
+ | (first_id, first_head) :: other_heads -> (
+ let exception Unknown_result in
+ try
+ match first_head with
+ | Variant { blocks; immediates; extensions; is_unique } ->
+ let blocks, imms, extensions, is_unique =
+ List.fold_right
+ (fun (other_id, other_head)
+ (blocks, immediates, extensions, is_unique) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Variant
+ { blocks = other_blocks;
+ immediates = other_immediates;
+ extensions = other_extensions;
+ is_unique = other_is_unique
+ } ->
+ (* Uniqueness tracks whether duplication/lifting is allowed. It
+ must always be propagated, both for meet and join. *)
+ ( (other_id, other_blocks) :: blocks,
+ (other_id, other_immediates) :: immediates,
+ (other_id, other_extensions) :: extensions,
+ is_unique || other_is_unique )
+ | _ -> raise Unknown_result)
+ other_heads
+ ( [first_id, blocks],
+ [first_id, immediates],
+ [first_id, extensions],
+ is_unique )
+ in
+ let>+ blocks, immediates, extensions =
+ n_way_join_variant env ~blocks ~imms ~extensions
+ in
+ TG.Head_of_kind_value_non_null.create_variant ~is_unique ~blocks
+ ~immediates ~extensions
+ | Mutable_block { alloc_mode } ->
+ let alloc_mode =
+ List.fold_right
+ (fun (_, other_head) alloc_mode ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Mutable_block { alloc_mode = other_alloc_mode } ->
+ join_alloc_mode alloc_mode other_alloc_mode
+ | _ -> raise Unknown_result)
+ other_heads alloc_mode
+ in
+ ( Known (TG.Head_of_kind_value_non_null.create_mutable_block alloc_mode),
+ env )
+ | Boxed_float32 (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_float32 (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_float32 n alloc_mode
+ | Boxed_float (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_float (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_float n alloc_mode
+ | Boxed_int32 (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_int32 (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_int32 n alloc_mode
+ | Boxed_int64 (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_int64 (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_int64 n alloc_mode
+ | Boxed_nativeint (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_nativeint (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_nativeint n alloc_mode
+ | Boxed_vec128 (n, alloc_mode) ->
+ let ns, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ns, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Boxed_vec128 (other_n, other_alloc_mode) ->
+ ( (other_id, other_n) :: ns,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, n], alloc_mode)
+ in
+ let>+ n = n_way_join env ns in
+ TG.Head_of_kind_value_non_null.create_boxed_vec128 n alloc_mode
+ | Closures { by_function_slot; alloc_mode } ->
+ let function_slots, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (function_slots, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Closures
+ { by_function_slot = other_by_function_slot;
+ alloc_mode = other_alloc_mode
+ } ->
+ ( (other_id, other_by_function_slot) :: function_slots,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, by_function_slot], alloc_mode)
+ in
+ let by_function_slot, env =
+ n_way_join_row_like_for_closures env function_slots
+ in
+ ( Known
+ (TG.Head_of_kind_value_non_null.create_closures by_function_slot
+ alloc_mode),
+ env )
+ | String strs ->
+ let all_strs =
+ List.fold_right
+ (fun (_, other_head) all_strs ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | String other_strs -> String_info.Set.union other_strs all_strs
+ | _ -> raise Unknown_result)
+ other_heads strs
+ in
+ Known (TG.Head_of_kind_value_non_null.create_string all_strs), env
+ | Array { element_kind; length; contents; alloc_mode } ->
+ let lengths, contents, element_kind, alloc_mode =
+ List.fold_right
+ (fun (other_id, other_head) (ls, cs, element_kind, alloc_mode) ->
+ match[@warning "-fragile-match"]
+ (other_head : TG.head_of_kind_value_non_null)
+ with
+ | Array
+ { element_kind = other_element_kind;
+ length = other_length;
+ contents = other_contents;
+ alloc_mode = other_alloc_mode
+ } ->
+ ( (other_id, other_length) :: ls,
+ (other_id, other_contents) :: cs,
+ join_array_element_kinds other_element_kind element_kind,
+ join_alloc_mode alloc_mode other_alloc_mode )
+ | _ -> raise Unknown_result)
+ other_heads
+ ([first_id, length], [first_id, contents], element_kind, alloc_mode)
+ in
+ let contents, env =
+ n_way_join_array_contents env contents
+ ~joined_element_kind:element_kind
+ in
+ let>+ length = n_way_join env lengths in
+ TG.Head_of_kind_value_non_null.create_array_with_contents ~element_kind
+ ~length contents alloc_mode
+ with Unknown_result -> Unknown, env)
+
+and n_way_join_array_contents env
+ (array_contents : TG.array_contents Or_unknown.t Join_env.join_arg list)
+ ~(joined_element_kind : _ Or_unknown_or_bottom.t) : _ n_way_join_result =
+ n_way_join_unknown
+ (fun env (array_contents : TG.array_contents Join_env.join_arg list) :
+ TG.array_contents n_way_join_result ->
+ match array_contents with
+ | [] -> Misc.fatal_error "no n-way join for array contents"
+ | (_, Mutable) :: array_contents ->
+ if List.for_all
+ (fun (_, array_content) ->
+ match (array_content : TG.array_contents) with
+ | Mutable -> true
+ | Immutable _ -> false)
+ array_contents
+ then Known TG.Mutable, env
+ else Unknown, env
+ | (first_id, Immutable { fields = first_fields }) :: array_contents -> (
+ match joined_element_kind with
+ | Bottom | Unknown -> Unknown, env
+ | Ok _ -> (
+ let exception Unknown_result in
+ try
+ let other_fields =
+ List.fold_left
+ (fun acc (id, array_content) ->
+ match (array_content : TG.array_contents) with
+ | Mutable -> raise Unknown_result
+ | Immutable { fields = other_fields } ->
+ if Array.length other_fields <> Array.length first_fields
+ then raise Unknown_result
+ else (id, other_fields) :: acc)
+ [] array_contents
+ in
+ let env_ref = ref env in
+ let fields =
+ Array.init (Array.length first_fields) (fun idx ->
+ match
+ n_way_join !env_ref
+ ((first_id, first_fields.(idx))
+ :: List.rev_map
+ (fun (other_id, other_fields) ->
+ other_id, other_fields.(idx))
+ other_fields)
+ with
+ | Unknown, _ -> raise Unknown_result
+ | Known ty, env ->
+ env_ref := env;
+ ty)
+ in
+ Known (TG.Immutable { fields }), !env_ref
+ with Unknown_result -> Unknown, env)))
+ env array_contents
+
+and n_way_join_variant env
+ ~(blocks : TG.Row_like_for_blocks.t Or_unknown.t Join_env.join_arg list)
+ ~(imms : TG.t Or_unknown.t Join_env.join_arg list)
+ ~(extensions : TG.variant_extensions Join_env.join_arg list) :
(TG.Row_like_for_blocks.t Or_unknown.t
* TG.t Or_unknown.t
* TG.variant_extensions)
- Or_unknown.t =
- let blocks = join_unknown join_row_like_for_blocks env blocks1 blocks2 in
- let imms = join_unknown (join ?bound_name:None) env imms1 imms2 in
- let extensions : TG.variant_extensions =
- match extensions1, extensions2 with
- | No_extensions, Ext _ | Ext _, No_extensions | No_extensions, No_extensions
- ->
- No_extensions
- | ( Ext { when_immediate = when_immediate1; when_block = when_block1 },
- Ext { when_immediate = when_immediate2; when_block = when_block2 } ) ->
- let when_immediate =
- join_env_extension env when_immediate1 when_immediate2
+ n_way_join_result =
+ let blocks, env =
+ n_way_join_unknown n_way_join_row_like_for_blocks env blocks
+ in
+ let imms, env = n_way_join_unknown n_way_join env imms in
+ let (env, extensions) : _ * TG.variant_extensions =
+ let exception No_extensions in
+ try
+ let when_immediates, when_blocks =
+ List.fold_left
+ (fun (when_immediates, when_blocks) (id, extensions) ->
+ match (extensions : TG.variant_extensions) with
+ | No_extensions -> raise No_extensions
+ | Ext { when_immediate; when_block } ->
+ ( (id, when_immediate) :: when_immediates,
+ (id, when_block) :: when_blocks ))
+ ([], []) extensions
in
- let when_block = join_env_extension env when_block1 when_block2 in
+ let env0 = env in
+ let when_immediate, env = n_way_join_env_extension env when_immediates in
+ let when_block, env = n_way_join_env_extension env when_blocks in
if TEE.is_empty when_immediate && TEE.is_empty when_block
- then No_extensions
- else Ext { when_immediate; when_block }
+ then env0, TG.No_extensions
+ else env, TG.Ext { when_immediate; when_block }
+ with No_extensions -> env, TG.No_extensions
in
match blocks, imms, extensions with
- | Unknown, Unknown, No_extensions -> Unknown
+ | Unknown, Unknown, No_extensions -> Unknown, env
| (Unknown | Known _), (Unknown | Known _), (No_extensions | Ext _) ->
- Known (blocks, imms, extensions)
+ Known (blocks, imms, extensions), env
-and join_head_of_kind_naked_immediate env
- (head1 : TG.Head_of_kind_naked_immediate.t)
- (head2 : TG.Head_of_kind_naked_immediate.t) :
- TG.Head_of_kind_naked_immediate.t Or_unknown.t =
+and n_way_join_head_of_kind_naked_immediate env
+ (heads : TG.Head_of_kind_naked_immediate.t Join_env.join_arg list) :
+ TG.Head_of_kind_naked_immediate.t n_way_join_result =
let module I = Targetint_31_63 in
- match head1, head2 with
- | Naked_immediates is1, Naked_immediates is2 -> (
- assert (not (Targetint_31_63.Set.is_empty is1));
- assert (not (Targetint_31_63.Set.is_empty is2));
- let is = I.Set.union is1 is2 in
- let head = TG.Head_of_kind_naked_immediate.create_naked_immediates is in
+ let immediates, is_int, get_tag, is_null =
+ List.fold_left
+ (fun (immediates, is_int, get_tag, is_null) (id2, head2) ->
+ match (head2 : TG.head_of_kind_naked_immediate) with
+ | Is_int ty -> immediates, (id2, ty) :: is_int, get_tag, is_null
+ | Get_tag ty -> immediates, is_int, (id2, ty) :: get_tag, is_null
+ | Is_null ty -> immediates, is_int, get_tag, (id2, ty) :: is_null
+ | Naked_immediates is ->
+ I.Set.union is immediates, is_int, get_tag, is_null)
+ (I.Set.empty, [], [], []) heads
+ in
+ match is_int, get_tag, is_null with
+ | [], [], [] -> (
+ let head =
+ TG.Head_of_kind_naked_immediate.create_naked_immediates immediates
+ in
match head with
- | Ok head -> Known head
+ | Ok head -> Known head, env
| Bottom ->
Misc.fatal_error "Did not expect [Bottom] from [create_naked_immediates]")
- | Is_int ty1, Is_int ty2 ->
- let>+ ty = join env ty1 ty2 in
+ | _ :: _, [], [] when I.Set.is_empty immediates ->
+ let>+ ty = n_way_join env is_int in
TG.Head_of_kind_naked_immediate.create_is_int ty
- | Get_tag ty1, Get_tag ty2 ->
- let>+ ty = join env ty1 ty2 in
+ | [], _ :: _, [] when I.Set.is_empty immediates ->
+ let>+ ty = n_way_join env get_tag in
TG.Head_of_kind_naked_immediate.create_get_tag ty
- | Is_null ty1, Is_null ty2 ->
- let>+ ty = join env ty1 ty2 in
+ | [], [], _ :: _ when I.Set.is_empty immediates ->
+ let>+ ty = n_way_join env is_null in
TG.Head_of_kind_naked_immediate.create_is_null ty
(* From now on: Irregular cases *)
(* CR vlaviron: There could be improvements based on reduction (trying to
reduce the is_int and get_tag cases to naked_immediate sets, then joining
those) but this looks unlikely to be useful and could end up begin quite
expensive. *)
- | Is_int ty, Naked_immediates is_int | Naked_immediates is_int, Is_int ty -> (
- if I.Set.is_empty is_int
- then Known (TG.Head_of_kind_naked_immediate.create_is_int ty)
- else
- (* Slightly better than Unknown *)
- let head =
- TG.Head_of_kind_naked_immediate.create_naked_immediates
- (I.Set.add I.zero (I.Set.add I.one is_int))
- in
- match head with
- | Ok head -> Known head
- | Bottom ->
- Misc.fatal_error
- "Did not expect [Bottom] from [create_naked_immediates]")
- | Get_tag ty, Naked_immediates tags | Naked_immediates tags, Get_tag ty ->
- if I.Set.is_empty tags
- then Known (TG.Head_of_kind_naked_immediate.create_get_tag ty)
- else Unknown
- | Is_null ty, Naked_immediates is_null | Naked_immediates is_null, Is_null ty
- -> (
- if I.Set.is_empty is_null
- then Known (TG.Head_of_kind_naked_immediate.create_is_null ty)
- else
- (* Slightly better than Unknown *)
- let head =
- TG.Head_of_kind_naked_immediate.create_naked_immediates
- (I.Set.add I.zero (I.Set.add I.one is_null))
- in
- match head with
- | Ok head -> Known head
- | Bottom ->
- Misc.fatal_error
- "Did not expect [Bottom] from [create_naked_immediates]")
- | (Is_int _ | Get_tag _ | Is_null _), (Is_int _ | Get_tag _ | Is_null _) ->
- Unknown
+ | _, _ :: _, _ -> Unknown, env
+ | _ :: _, [], _ | _, [], _ :: _ -> (
+ (* Slightly better than Unknown *)
+ let head =
+ TG.Head_of_kind_naked_immediate.create_naked_immediates
+ (I.Set.add I.zero (I.Set.add I.one immediates))
+ in
+ match head with
+ | Ok head -> Known head, env
+ | Bottom ->
+ Misc.fatal_error "Did not expect [Bottom] from [create_naked_immediates]")
-and join_head_of_kind_naked_float32 _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_float32.union t1 t2)
+and n_way_join_head_of_kind_naked_float32 env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number
+ ~union:TG.Head_of_kind_naked_float32.union env t1 ts
-and join_head_of_kind_naked_float _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_float.union t1 t2)
+and n_way_join_head_of_kind_naked_float env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number ~union:TG.Head_of_kind_naked_float.union
+ env t1 ts
-and join_head_of_kind_naked_int32 _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_int32.union t1 t2)
+and n_way_join_head_of_kind_naked_int32 env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number ~union:TG.Head_of_kind_naked_int32.union
+ env t1 ts
-and join_head_of_kind_naked_int64 _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_int64.union t1 t2)
+and n_way_join_head_of_kind_naked_int64 env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number ~union:TG.Head_of_kind_naked_int64.union
+ env t1 ts
-and join_head_of_kind_naked_nativeint _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_nativeint.union t1 t2)
+and n_way_join_head_of_kind_naked_nativeint env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number
+ ~union:TG.Head_of_kind_naked_nativeint.union env t1 ts
-and join_head_of_kind_naked_vec128 _env t1 t2 : _ Or_unknown.t =
- Known (TG.Head_of_kind_naked_vec128.union t1 t2)
+and n_way_join_head_of_kind_naked_vec128 env t1 ts : _ n_way_join_result =
+ n_way_join_head_of_kind_naked_number ~union:TG.Head_of_kind_naked_vec128.union
+ env t1 ts
-and join_head_of_kind_rec_info _env t1 t2 : _ Or_unknown.t =
- if Rec_info_expr.equal t1 t2 then Known t1 else Unknown
+and n_way_join_head_of_kind_rec_info env (t1, _) ts : _ n_way_join_result =
+ if List.for_all (fun (_, t2) -> Rec_info_expr.equal t1 t2) ts
+ then Known t1, env
+ else Unknown, env
-and join_head_of_kind_region _env () () : _ Or_unknown.t = Known ()
+and n_way_join_head_of_kind_region env ((), _) (_ : unit Join_env.join_arg list)
+ : _ n_way_join_result =
+ Known (), env
(* Note that unlike the [join] function on types, for structures (closures
entry, row-like, etc.) the return type is [t] (and not [t Or_unknown.t]).
@@ -1944,351 +2245,459 @@ and join_head_of_kind_region _env () () : _ Or_unknown.t = Known ()
case gracefully. All join functions for structures can handle [Unknown]
results from generic [join]s without needing to propagate them. *)
-and join_row_like :
+and n_way_join_row_like :
'lattice 'shape 'maps_to 'row_tag 'known.
- join_maps_to:(Join_env.t -> 'shape -> 'maps_to -> 'maps_to -> 'maps_to) ->
+ n_way_join_maps_to:
+ (Join_env.t ->
+ 'shape ->
+ 'maps_to Join_env.join_arg list ->
+ 'maps_to * Join_env.t) ->
equal_index:('lattice -> 'lattice -> bool) ->
inter_index:('lattice -> 'lattice -> 'lattice) ->
- join_shape:('shape -> 'shape -> 'shape Or_unknown.t) ->
+ n_way_join_shape:('shape list -> 'shape Or_unknown_or_bottom.t) ->
merge_map_known:
- (('row_tag ->
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option ->
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) ->
- 'known ->
- 'known ->
- 'known) ->
+ ((Join_env.t ->
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t
+ Join_env.join_arg
+ list ->
+ (('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t
+ * Join_env.t)
+ Or_bottom.t) ->
+ Join_env.t ->
+ ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t)
+ Join_env.join_arg
+ list ->
+ 'known * Join_env.t) ->
Join_env.t ->
- known1:'known ->
- known2:'known ->
- other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
- other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t ->
+ known:
+ ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t)
+ Join_env.join_arg
+ list ->
+ other:
+ ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t
+ Join_env.join_arg
+ list ->
('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t)
- Or_unknown.t =
- fun ~join_maps_to ~equal_index ~inter_index ~join_shape ~merge_map_known
- join_env ~known1 ~known2 ~other1 ~other2 ->
- let join_index (i1 : ('lattice, 'shape) TG.row_like_index)
- (i2 : ('lattice, 'shape) TG.row_like_index) :
- ('lattice, 'shape) TG.row_like_index Or_unknown.t =
- match join_shape i1.shape i2.shape with
+ n_way_join_result =
+ fun ~n_way_join_maps_to ~equal_index ~inter_index ~n_way_join_shape
+ ~merge_map_known join_env ~known ~other ->
+ let n_way_join_index (is : ('lattice, 'shape) TG.row_like_index list) :
+ ('lattice, 'shape) TG.row_like_index Or_unknown_or_bottom.t =
+ match
+ n_way_join_shape
+ (List.map
+ (fun (i : ('lattice, 'shape) TG.row_like_index) -> i.shape)
+ is)
+ with
+ | Bottom -> Bottom
| Unknown -> Unknown
- | Known shape -> (
+ | Ok shape -> (
let return_index domain =
- Or_unknown.Known (TG.Row_like_index.create ~domain ~shape)
+ Or_unknown_or_bottom.Ok (TG.Row_like_index.create ~domain ~shape)
in
- match i1.domain, i2.domain with
- | Known i1', Known i2' ->
- if equal_index i1' i2'
- then return_index i1.domain
- else
- (* We can't represent exactly the union, This is the best
- approximation *)
- return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2'))
- | Known i1', At_least i2'
- | At_least i1', Known i2'
- | At_least i1', At_least i2' ->
- return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2')))
+ match is with
+ | [] -> Bottom
+ | i1 :: is -> (
+ match i1.domain with
+ | Known i1'
+ when List.for_all
+ (fun (i2 : ('lattice, 'shape) TG.row_like_index) ->
+ match i2.domain with
+ | Known i2' -> equal_index i1' i2'
+ | At_least _ ->
+ (* We can't represent exactly the union. Approximate with
+ [at_least (inter_index)] below. *)
+ false)
+ is ->
+ return_index i1.domain
+ | Known i1' | At_least i1' ->
+ return_index
+ (TG.Row_like_index_domain.at_least
+ (List.fold_left
+ (fun i1' (i2 : ('lattice, 'shape) TG.row_like_index) ->
+ match i2.domain with
+ | At_least i2' -> inter_index i1' i2'
+ | Known i2' -> inter_index i1' i2')
+ i1' is))))
in
- let join_case join_env
- (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t)
- (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) : _ Or_unknown.t
- =
- let index = join_index case1.index case2.index in
- Or_unknown.map index
- ~f:(fun (index : ('lattice, 'shape) TG.Row_like_index.t) ->
- let maps_to =
- join_maps_to join_env index.shape case1.maps_to case2.maps_to
- in
- let env_extension =
- join_env_extension join_env case1.env_extension case2.env_extension
- in
- TG.Row_like_case.create ~maps_to ~index ~env_extension)
- in
- let join_knowns
- (case1 :
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option)
- (case2 :
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) :
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option =
- match case1, case2 with
- | None, None -> None
- | Some Unknown, _ | _, Some Unknown -> Some Unknown
- | Some (Known case1), None -> (
- let only_case1 () =
- (* cf. Type_descr.join_head_or_unknown_or_bottom, we need to join these
- to ensure that free variables not present in the target env are
- cleaned out of the types. Same below *)
- (* CR pchambart: This seems terribly inefficient. *)
- let join_env =
- Join_env.create
- (Join_env.target_join_env join_env)
- ~left_env:(Join_env.left_join_env join_env)
- ~right_env:(Join_env.left_join_env join_env)
- in
- let case1 = join_case join_env case1 case1 in
- Some case1
+ let n_way_join_case join_env (cases : _ Join_env.join_arg list) :
+ _ n_way_join_result Or_bottom.t =
+ let index =
+ n_way_join_index (List.map (fun (_, case) -> case.TG.index) cases)
+ in
+ match index with
+ | Unknown -> Ok (Unknown, join_env)
+ | Bottom -> Bottom
+ | Ok index ->
+ let maps_to, join_env =
+ n_way_join_maps_to join_env index.shape
+ (List.map (fun (id, case) -> id, case.TG.maps_to) cases)
in
- match other2 with
- | Bottom -> only_case1 ()
- | Ok other_case -> Some (join_case join_env case1 other_case))
- | None, Some (Known case2) -> (
- let only_case2 () =
- (* See at the other bottom case *)
- let join_env =
- Join_env.create
- (Join_env.target_join_env join_env)
- ~left_env:(Join_env.right_join_env join_env)
- ~right_env:(Join_env.right_join_env join_env)
- in
- let case2 = join_case join_env case2 case2 in
- Some case2
+ let env_extension, join_env =
+ n_way_join_env_extension join_env
+ (List.map (fun (id, case) -> id, case.TG.env_extension) cases)
in
- match other1 with
- | Bottom -> only_case2 ()
- | Ok other_case -> Some (join_case join_env other_case case2))
- | Some (Known case1), Some (Known case2) ->
- Some (join_case join_env case1 case2)
- in
- let known =
- merge_map_known
- (fun _tag case1 case2 -> join_knowns case1 case2)
- known1 known2
+ Ok
+ ( Known (TG.Row_like_case.create ~maps_to ~index ~env_extension),
+ join_env )
in
- let other :
- ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t Or_unknown.t =
- match other1, other2 with
- | Bottom, Bottom -> Known Bottom
- | Ok other1, Bottom ->
- (* See the previous cases *)
- let env =
- Join_env.create
- (Join_env.target_join_env join_env)
- ~left_env:(Join_env.left_join_env join_env)
- ~right_env:(Join_env.left_join_env join_env)
- in
- let other1 = join_case env other1 other1 in
- Or_unknown.map other1 ~f:(fun other1 -> Or_bottom.Ok other1)
- | Bottom, Ok other2 ->
- (* See the previous cases *)
- let env =
- Join_env.create
- (Join_env.target_join_env join_env)
- ~left_env:(Join_env.right_join_env join_env)
- ~right_env:(Join_env.right_join_env join_env)
+ let n_way_join_knowns join_env cases : _ n_way_join_result Or_bottom.t =
+ let exception Unknown_result in
+ try
+ let cases =
+ List.map
+ (fun (id, case) ->
+ match (case : _ Or_unknown.t) with
+ | Unknown -> raise Unknown_result
+ | Known case -> id, case)
+ cases
in
- let other2 = join_case env other2 other2 in
- Or_unknown.map other2 ~f:(fun other2 -> Or_bottom.Ok other2)
- | Ok other1, Ok other2 ->
- Or_unknown.map (join_case join_env other1 other2) ~f:(fun case ->
- Or_bottom.Ok case)
+ n_way_join_case join_env cases
+ with Unknown_result -> Ok (Unknown, join_env)
in
- Or_unknown.map other ~f:(fun other -> known, other)
-
-and join_row_like_for_blocks env
- ({ known_tags = known1; other_tags = other1; alloc_mode = alloc_mode1 } :
- TG.Row_like_for_blocks.t)
- ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } :
- TG.Row_like_for_blocks.t) =
- let join_shape shape1 shape2 : _ Or_unknown.t =
- if K.Block_shape.equal shape1 shape2 then Known shape1 else Unknown
+ let known, join_env = merge_map_known n_way_join_knowns join_env known in
+ let other : _ Or_bottom.t n_way_join_result =
+ let others =
+ List.fold_left
+ (fun acc (id, other) ->
+ match (other : _ Or_bottom.t) with
+ | Bottom -> acc
+ | Ok other -> (id, other) :: acc)
+ [] other
+ in
+ match n_way_join_case join_env others with
+ | Bottom -> Known Bottom, join_env
+ | Ok others -> map_join_result others ~f:(fun case -> Or_bottom.Ok case)
in
- Or_unknown.map
- (join_row_like ~join_maps_to:join_int_indexed_product
- ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter
- ~join_shape ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1
- ~other2) ~f:(fun (known_tags, other_tags) ->
- let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in
- TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode)
-
-and join_row_like_for_closures env
- ({ known_closures = known1; other_closures = other1 } :
- TG.Row_like_for_closures.t)
- ({ known_closures = known2; other_closures = other2 } :
- TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t =
- let merge_map_known join_case known1 known2 =
- Function_slot.Map.merge
- (fun function_slot case1 case2 ->
- let case1 = Option.map Or_unknown.known case1 in
- let case2 = Option.map Or_unknown.known case2 in
- match (join_case function_slot case1 case2 : _ Or_unknown.t option) with
- | None -> None
- | Some (Known case) -> Some case
- | Some Unknown ->
+ match other with
+ | Known other, join_env -> Known (known, other), join_env
+ | Unknown, join_env -> Unknown, join_env
+
+and n_way_join_row_like_for_blocks env
+ (row_like_for_blocks : TG.Row_like_for_blocks.t Join_env.join_arg list) :
+ _ n_way_join_result =
+ let split_or_bottom =
+ List.fold_left
+ (fun (acc : _ Or_bottom.t) (id, (row_like : TG.row_like_for_blocks)) :
+ _ Or_bottom.t ->
+ if TG.Row_like_for_blocks.is_bottom row_like
+ then acc
+ else
+ match acc with
+ | Bottom ->
+ Ok
+ ( [id, (row_like.known_tags, row_like.other_tags)],
+ [id, row_like.other_tags],
+ row_like.alloc_mode )
+ | Ok (known, other, alloc_mode) ->
+ Ok
+ ( (id, (row_like.known_tags, row_like.other_tags)) :: known,
+ (id, row_like.other_tags) :: other,
+ join_alloc_mode alloc_mode row_like.alloc_mode ))
+ Or_bottom.Bottom row_like_for_blocks
+ in
+ match split_or_bottom with
+ | Bottom -> Known TG.Row_like_for_blocks.bottom, env
+ | Ok (known, other, alloc_mode) ->
+ let n_way_join_shape shapes : _ Or_unknown_or_bottom.t =
+ match shapes with
+ | [] -> Bottom
+ | shape1 :: shapes ->
+ if List.for_all (K.Block_shape.equal shape1) shapes
+ then Ok shape1
+ else Unknown
+ in
+ let merge_map_known =
+ generic_merge_map_known ~filter_map:Tag.Map.filter_map ~map:Tag.Map.map
+ ~merge:Tag.Map.merge ~bottom:Tag.Map.empty ~other:Or_unknown.known
+ in
+ map_join_result
+ (n_way_join_row_like ~n_way_join_maps_to:n_way_join_int_indexed_product
+ ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter
+ ~n_way_join_shape ~merge_map_known env ~known ~other)
+ ~f:(fun (known_tags, other_tags) ->
+ TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode)
+
+and n_way_join_row_like_for_closures env
+ (closures : TG.Row_like_for_closures.t Join_env.join_arg list) :
+ TG.Row_like_for_closures.t * _ =
+ let known, other =
+ match closures with
+ | [] -> Misc.fatal_error "Join row_like for no closures."
+ | (id1, { known_closures = known1; other_closures = other1 })
+ :: other_closures ->
+ List.fold_left
+ (fun (known, other)
+ (id2, { TG.known_closures = known2; TG.other_closures = other2 }) ->
+ (id2, (known2, other2)) :: known, (id2, other2) :: other)
+ ([id1, (known1, other1)], [id1, other1])
+ other_closures
+ in
+ let merge_map_known join_case env knowns =
+ generic_merge_map_known ~filter_map:Function_slot.Map.filter_map
+ ~map:Function_slot.Map.map ~merge:Function_slot.Map.merge
+ ~bottom:Function_slot.Map.empty
+ ~other:(fun case -> case)
+ (fun env cases ->
+ let cases =
+ List.map (fun (id, case) -> id, Or_unknown.known case) cases
+ in
+ match (join_case env cases : (_ Or_unknown.t * _) Or_bottom.t) with
+ | Bottom -> Or_bottom.Bottom
+ | Ok (Known case, env) -> Or_bottom.Ok (case, env)
+ | Ok (Unknown, _) ->
Misc.fatal_error "Join row_like case for closures returned Unknown")
- known1 known2
+ env knowns
in
match
- join_row_like
- ~join_maps_to:(fun env () x y -> join_closures_entry env x y)
+ n_way_join_row_like
+ ~n_way_join_maps_to:(fun env () entries ->
+ n_way_join_closures_entry env entries)
~equal_index:Set_of_closures_contents.equal
~inter_index:Set_of_closures_contents.inter
- ~join_shape:(fun () () -> Or_unknown.Known ())
- ~merge_map_known env ~known1 ~known2 ~other1 ~other2
+ ~n_way_join_shape:(fun _ -> Or_unknown_or_bottom.Ok ())
+ ~merge_map_known env ~known ~other
with
- | Known (known_closures, other_closures) ->
- TG.Row_like_for_closures.create_raw ~known_closures ~other_closures
- | Unknown ->
+ | Known (known_closures, other_closures), env ->
+ TG.Row_like_for_closures.create_raw ~known_closures ~other_closures, env
+ | Unknown, _ ->
Misc.fatal_error "Join row_like case for closures returned Unknown"
-and join_closures_entry env
- ({ function_types = function_types1;
- closure_types = closure_types1;
- value_slot_types = value_slot_types1
- } :
- TG.Closures_entry.t)
- ({ function_types = function_types2;
- closure_types = closure_types2;
- value_slot_types = value_slot_types2
- } :
- TG.Closures_entry.t) : TG.Closures_entry.t =
- let function_types =
- Function_slot.Map.merge
- (fun _function_slot func_type1 func_type2 ->
- match func_type1, func_type2 with
- | None, None | Some _, None | None, Some _ -> None
- | Some func_type1, Some func_type2 ->
- Some (join_function_type env func_type1 func_type2))
- function_types1 function_types2
+and n_way_join_closures_entry env
+ (entries : TG.Closures_entry.t Join_env.join_arg list) :
+ TG.Closures_entry.t * _ =
+ let function_types, closure_types, value_slot_types =
+ match entries with
+ | [] -> Function_slot.Map.empty, [], []
+ | ( id1,
+ { TG.function_types = function_types1;
+ TG.closure_types = closure_types1;
+ TG.value_slot_types = value_slot_types1
+ } )
+ :: entries ->
+ let function_types =
+ Function_slot.Map.map
+ (fun func_type -> [id1, func_type])
+ function_types1
+ in
+ List.fold_left
+ (fun (function_types, closure_types, value_slot_types)
+ ( id2,
+ { TG.function_types = function_types2;
+ TG.closure_types = closure_types2;
+ TG.value_slot_types = value_slot_types2
+ } ) ->
+ let function_types =
+ Function_slot.Map.merge
+ (fun _ vals_opt val2_opt ->
+ match vals_opt, val2_opt with
+ | None, None -> None
+ | None, Some val2 -> Some [id2, val2]
+ | Some _, None -> vals_opt
+ | Some vals, Some val2 -> Some ((id2, val2) :: vals))
+ function_types function_types2
+ in
+ ( function_types,
+ (id2, closure_types2) :: closure_types,
+ (id2, value_slot_types2) :: value_slot_types ))
+ (function_types, [id1, closure_types1], [id1, value_slot_types1])
+ entries
in
- let closure_types =
- join_function_slot_indexed_product env closure_types1 closure_types2
+ let function_types, env =
+ let env_ref = ref env in
+ let function_types =
+ Function_slot.Map.map
+ (fun func_types ->
+ let func_type, env = n_way_join_function_type !env_ref func_types in
+ env_ref := env;
+ func_type)
+ function_types
+ in
+ function_types, !env_ref
in
- let value_slot_types =
- join_value_slot_indexed_product env value_slot_types1 value_slot_types2
+ let closure_types, env =
+ n_way_join_function_slot_indexed_product env closure_types
in
- TG.Closures_entry.create ~function_types ~closure_types ~value_slot_types
+ let value_slot_types, env =
+ n_way_join_value_slot_indexed_product env value_slot_types
+ in
+ TG.Closures_entry.create ~function_types ~closure_types ~value_slot_types, env
-and join_generic_product :
- 'key 'key_map.
+and n_way_join_generic_product :
+ 'product 'join_map 'map 'index.
Join_env.t ->
- components_by_index1:'key_map ->
- components_by_index2:'key_map ->
+ 'product Join_env.join_arg list ->
+ empty:'map ->
+ components_by_index:('product -> 'map) ->
+ map:((TG.t -> TG.t Join_env.join_arg list) -> 'map -> 'join_map) ->
merge:
- (('key -> TG.t option -> TG.t option -> TG.t option) ->
- 'key_map ->
- 'key_map ->
- 'key_map) ->
- 'key_map =
- fun env ~components_by_index1 ~components_by_index2 ~merge ->
- merge
- (fun _index ty1_opt ty2_opt ->
- match ty1_opt, ty2_opt with
- | None, _ | _, None -> None
- | Some ty1, Some ty2 -> (
- match join env ty1 ty2 with Known ty -> Some ty | Unknown -> None))
- components_by_index1 components_by_index2
-
-and join_function_slot_indexed_product env
- ({ function_slot_components_by_index = components_by_index1 } :
- TG.Product.Function_slot_indexed.t)
- ({ function_slot_components_by_index = components_by_index2 } :
- TG.Product.Function_slot_indexed.t) : TG.Product.Function_slot_indexed.t =
- let function_slot_components_by_index =
- join_generic_product env ~components_by_index1 ~components_by_index2
- ~merge:Function_slot.Map.merge
+ (('index ->
+ TG.t Join_env.join_arg list option ->
+ TG.t option ->
+ TG.t Join_env.join_arg list option) ->
+ 'join_map ->
+ 'map ->
+ 'join_map) ->
+ filter_map:
+ (('index -> TG.t Join_env.join_arg list -> TG.t option) ->
+ 'join_map ->
+ 'map) ->
+ 'map * Join_env.t =
+ fun env indexed_products ~empty ~components_by_index:get_components_by_index
+ ~map ~merge ~filter_map ->
+ match indexed_products with
+ | [] -> empty, env
+ | (id1, indexed_product1) :: indexed_products ->
+ let components_by_index =
+ List.fold_left
+ (fun components_by_index (id2, indexed_product2) ->
+ merge
+ (fun _ vals_opt val2_opt ->
+ match vals_opt, val2_opt with
+ | None, _ | _, None -> None
+ | Some vals, Some val2 -> Some ((id2, val2) :: vals))
+ components_by_index
+ (get_components_by_index indexed_product2))
+ (map
+ (fun val1 -> [id1, val1])
+ (get_components_by_index indexed_product1))
+ indexed_products
+ in
+ let env_ref = ref env in
+ let components_by_index =
+ filter_map
+ (fun _index tys ->
+ match n_way_join !env_ref tys with
+ | Known ty, env ->
+ env_ref := env;
+ Some ty
+ | Unknown, env ->
+ env_ref := env;
+ None)
+ components_by_index
+ in
+ components_by_index, !env_ref
+
+and n_way_join_function_slot_indexed_product env
+ (function_slots_indexed :
+ TG.Product.Function_slot_indexed.t Join_env.join_arg list) :
+ TG.Product.Function_slot_indexed.t * _ =
+ let function_slot_components_by_index, env =
+ n_way_join_generic_product env function_slots_indexed
+ ~filter_map:Function_slot.Map.filter_map ~empty:Function_slot.Map.empty
+ ~map:Function_slot.Map.map ~merge:Function_slot.Map.merge
+ ~components_by_index:(fun { TG.function_slot_components_by_index } ->
+ function_slot_components_by_index)
in
- TG.Product.Function_slot_indexed.create function_slot_components_by_index
-
-and join_value_slot_indexed_product env
- ({ value_slot_components_by_index = components_by_index1 } :
- TG.Product.Value_slot_indexed.t)
- ({ value_slot_components_by_index = components_by_index2 } :
- TG.Product.Value_slot_indexed.t) : TG.Product.Value_slot_indexed.t =
- let value_slot_components_by_index =
- join_generic_product env ~components_by_index1 ~components_by_index2
- ~merge:Value_slot.Map.merge
+ TG.Product.Function_slot_indexed.create function_slot_components_by_index, env
+
+and n_way_join_value_slot_indexed_product env
+ (value_slots_indexed :
+ TG.Product.Value_slot_indexed.t Join_env.join_arg list) :
+ TG.Product.Value_slot_indexed.t * _ =
+ let value_slot_components_by_index, env =
+ n_way_join_generic_product env value_slots_indexed
+ ~filter_map:Value_slot.Map.filter_map ~empty:Value_slot.Map.empty
+ ~map:Value_slot.Map.map ~merge:Value_slot.Map.merge
+ ~components_by_index:(fun { TG.value_slot_components_by_index } ->
+ value_slot_components_by_index)
in
- TG.Product.Value_slot_indexed.create value_slot_components_by_index
-
-and join_int_indexed_product env shape (fields1 : TG.Product.Int_indexed.t)
- (fields2 : TG.Product.Int_indexed.t) : TG.Product.Int_indexed.t =
- let length1 = Array.length fields1 in
- let length2 = Array.length fields2 in
- let length = min length1 length2 in
- let exception Exit in
- let all_phys_equal =
- try
- for index = 0 to length - 1 do
- if fields1.(index) != fields2.(index) then raise Exit
- done;
- true
- with Exit -> false
+ TG.Product.Value_slot_indexed.create value_slot_components_by_index, env
+
+and n_way_join_int_indexed_product env shape
+ (fields : TG.Product.Int_indexed.t Join_env.join_arg list) :
+ TG.Product.Int_indexed.t * Join_env.t =
+ let length =
+ match fields with
+ | [] -> Misc.fatal_error "Join of empty int indexed product."
+ | (_, first_fields) :: other_fields ->
+ List.fold_left
+ (fun length (_, other_fields) -> min length (Array.length other_fields))
+ (Array.length first_fields)
+ other_fields
in
- let fields =
- if all_phys_equal
- then
- if Int.equal length1 length
- then fields1
- else (
- assert (Int.equal length2 length);
- fields2)
- else
+ let fields, env =
+ let env_ref = ref env in
+ let fields =
Array.init length (fun index ->
- if fields1.(index) == fields2.(index)
- then fields1.(index)
- else
- match join env fields1.(index) fields2.(index) with
- | Unknown -> MTC.unknown_from_shape shape index
- | Known ty -> ty)
+ (* CR bclement: if fields are all physically equal and only involve
+ variables defined in the central env, we should reuse the type. *)
+ let fields =
+ List.map (fun (id, fields) -> id, fields.(index)) fields
+ in
+ match n_way_join !env_ref fields with
+ | Unknown, env ->
+ env_ref := env;
+ MTC.unknown_from_shape shape index
+ | Known ty, env ->
+ env_ref := env;
+ ty)
+ in
+ fields, !env_ref
in
- TG.Product.Int_indexed.create_from_array fields
+ TG.Product.Int_indexed.create_from_array fields, env
-and join_function_type (env : Join_env.t)
- (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t)
- (func_type2 : TG.Function_type.t Or_unknown_or_bottom.t) :
- TG.Function_type.t Or_unknown_or_bottom.t =
- match func_type1, func_type2 with
- | Bottom, func_type | func_type, Bottom -> func_type
- | Unknown, _ | _, Unknown -> Unknown
- | ( Ok { code_id = code_id1; rec_info = rec_info1 },
- Ok { code_id = code_id2; rec_info = rec_info2 } ) -> (
- let target_typing_env = Join_env.target_join_env env in
- (* As a note, sometimes it might be preferable not to do the code age
- relation join, and take the hit of an indirect call in exchange for
- calling specialised versions of the code. Maybe an annotation would be
- needed. Dolan thinks there isn't a single good answer here and we should
- maybe just not do the join. (The code age relation meet would remain
- though as it's useful elsewhere.) *)
- match
- Code_age_relation.join
- ~target_t:(TE.code_age_relation target_typing_env)
- ~resolver:(TE.code_age_relation_resolver target_typing_env)
- (TE.code_age_relation (Join_env.left_join_env env))
- (TE.code_age_relation (Join_env.right_join_env env))
- code_id1 code_id2
- with
- | Unknown -> Unknown
- | Known code_id -> (
- match join env rec_info1 rec_info2 with
- | Known rec_info -> Ok (TG.Function_type.create code_id ~rec_info)
- | Unknown -> Unknown))
-
-and join_env_extension env (ext1 : TEE.t) (ext2 : TEE.t) : TEE.t =
- let equations =
- Name.Map.merge
- (fun name ty1_opt ty2_opt ->
- match ty1_opt, ty2_opt with
- | None, _ | _, None -> None
- | Some ty1, Some ty2 -> (
- match join env ty1 ty2 with
- | Known ty ->
- if MTC.is_alias_of_name ty name
- then
- (* This is rare but not anomalous. It may mean that [ty1] and
- [ty2] are both alias types which canonicalize to [name], for
- instance. In any event, if the best type available for [name]
- is [= name], we effectively know nothing, so we drop [name].
- ([name = name] would be rejected by [TE.add_equation]
- anyway.) *)
- None
- else (
- (* This should always pass due to the [is_alias_of_name] check. *)
- MTC.check_equation name ty;
- Some ty)
- | Unknown -> None))
- (TEE.to_map ext1) (TEE.to_map ext2)
- in
- TEE.from_map equations
+and n_way_join_function_type (env : Join_env.t)
+ (func_types :
+ TG.Function_type.t Or_unknown_or_bottom.t Join_env.join_arg list) :
+ TG.Function_type.t Or_unknown_or_bottom.t * _ =
+ let exception Unknown_result in
+ try
+ let func_types =
+ List.fold_left
+ (fun func_types (id2, func_type2) ->
+ match (func_type2 : TG.Function_type.t Or_unknown_or_bottom.t) with
+ | Bottom -> func_types
+ | Unknown -> raise Unknown_result
+ | Ok func_type2 -> (id2, func_type2) :: func_types)
+ [] func_types
+ in
+ match func_types with
+ | [] -> Bottom, env
+ | (id1, { code_id = code_id1; rec_info = rec_info1 }) :: func_types -> (
+ let target_typing_env = Join_env.target_join_env env in
+ let code_id, _, rec_infos =
+ List.fold_left
+ (fun (code_id1, code_age_relation1, rec_infos)
+ (id2, { TG.code_id = code_id2; rec_info = rec_info2 }) ->
+ (* As a note, sometimes it might be preferable not to do the code
+ age relation join, and take the hit of an indirect call in
+ exchange for calling specialised versions of the code. Maybe an
+ annotation would be needed. Dolan thinks there isn't a single
+ good answer here and we should maybe just not do the join. (The
+ code age relation meet would remain though as it's useful
+ elsewhere.) *)
+ match
+ Code_age_relation.join
+ ~target_t:(TE.code_age_relation target_typing_env)
+ ~resolver:(TE.code_age_relation_resolver target_typing_env)
+ code_age_relation1
+ (TE.code_age_relation (Join_env.joined_env env id2))
+ code_id1 code_id2
+ with
+ | Unknown -> raise Unknown_result
+ | Known code_id ->
+ ( code_id,
+ TE.code_age_relation target_typing_env,
+ (id2, rec_info2) :: rec_infos ))
+ ( code_id1,
+ TE.code_age_relation (Join_env.joined_env env id1),
+ [id1, rec_info1] )
+ func_types
+ in
+ match n_way_join env rec_infos with
+ | Known rec_info, env ->
+ Ok (TG.Function_type.create code_id ~rec_info), env
+ | Unknown, env -> Unknown, env)
+ with Unknown_result -> Unknown, env
+
+and n_way_join_env_extension env exts =
+ match
+ Join_env.n_way_join_env_extension ~n_way_join_type:n_way_join ~meet_type env
+ exts
+ with
+ | Bottom -> TEE.empty, env
+ | Ok (ext, env) -> ext, env
(* Exposed to the outside world with Or_bottom type *)
let meet env ty1 ty2 : _ Or_bottom.t =
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.mli b/middle_end/flambda2/types/meet_and_n_way_join.mli
index 67f367e9539..1c5f65af5d5 100644
--- a/middle_end/flambda2/types/meet_and_n_way_join.mli
+++ b/middle_end/flambda2/types/meet_and_n_way_join.mli
@@ -21,13 +21,11 @@ val meet :
Type_grammar.t ->
(Type_grammar.t * Typing_env.t) Or_bottom.t
-(** Least upper bound of two types. *)
-val join :
- ?bound_name:Name.t ->
- Typing_env.Join_env.t ->
- Type_grammar.t ->
- Type_grammar.t ->
- Type_grammar.t Or_unknown.t
+(** Least upper bound of many types. *)
+val n_way_join :
+ Join_env.t ->
+ Type_grammar.t Join_env.join_arg list ->
+ Type_grammar.t Or_unknown.t * Join_env.t
val meet_shape :
Typing_env.t ->
From 287dd64908bdcc62852fab0306b404a081f07894 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 13 Feb 2025 11:17:11 +0100
Subject: [PATCH 03/12] Type isolation and doc
---
middle_end/flambda2/types/env/join_env.ml | 872 +++++++++++++++-------
1 file changed, 599 insertions(+), 273 deletions(-)
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
index 114f3f86fc5..d417cb1853f 100644
--- a/middle_end/flambda2/types/env/join_env.ml
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -77,6 +77,167 @@ end = struct
let succ n = n + 1
end
+(* The following are intended to help make sure we don't confuse things (names,
+ simples) that are living in one of the joined environments and those that
+ live in the target environment.
+
+ In particular, one simple in a joined environment can have multiple names in
+ the target environment if they have been demoted. *)
+
+module Thing_in_env (Thing : Container_types.S) () : sig
+ include Container_types.S with type t = private Thing.t
+
+ val create : Thing.t -> t
+end = struct
+ include Thing
+
+ let create thing = thing
+end
+
+module Name_in_target_env = struct
+ include Thing_in_env (Name) ()
+end
+
+module Simple_in_target_env : sig
+ include module type of Thing_in_env (Simple) ()
+
+ val name : Name_in_target_env.t -> t
+end = struct
+ include Thing_in_env (Simple) ()
+
+ let name (name : Name_in_target_env.t) = create (Simple.name (name :> Name.t))
+end
+
+module Name_in_one_joined_env = struct
+ include Thing_in_env (Name) ()
+end
+
+module Simple_in_one_joined_env : sig
+ include module type of Thing_in_env (Simple) ()
+
+ val pattern_match :
+ t ->
+ name:(Name_in_one_joined_env.t -> coercion:Coercion.t -> 'a) ->
+ const:(Reg_width_const.t -> 'a) ->
+ 'a
+end = struct
+ include Thing_in_env (Simple) ()
+
+ let pattern_match (t : t) ~name:on_name ~const =
+ Simple.pattern_match
+ (t :> Simple.t)
+ ~name:(fun name ~coercion ->
+ on_name (Name_in_one_joined_env.create name) ~coercion)
+ ~const
+end
+
+module Simple_in_joined_envs : sig
+ include
+ Container_types.S
+ with type t = private Simple_in_one_joined_env.t Index.Map.t
+
+ val fold :
+ (Index.t -> Simple_in_one_joined_env.t -> 'a -> 'a) -> t -> 'a -> 'a
+
+ val distinct_from_simple_in_target_env : t -> Simple_in_target_env.t -> t
+
+ val apply_coercion : t -> Coercion.t -> t
+
+ val is_empty : t -> bool
+
+ val empty : t
+
+ val in_same_envs : t -> as_:t -> t
+
+ val is_defined_in : Index.Set.t -> t -> bool
+
+ val raw_name : t -> string
+
+ val add : Index.t -> Simple_in_one_joined_env.t -> t -> t
+
+ val of_list : (Index.t * Simple.t) list -> t
+end = struct
+ module T0 = struct
+ type t = Simple_in_one_joined_env.t Index.Map.t
+
+ let print = Index.Map.print Simple_in_one_joined_env.print
+
+ let hash map =
+ Index.Map.fold
+ (fun index simple hash ->
+ Hashtbl.hash
+ (hash, Index.hash index, Simple_in_one_joined_env.hash simple))
+ map (Hashtbl.hash 0)
+
+ let equal = Index.Map.equal Simple_in_one_joined_env.equal
+
+ let compare = Index.Map.compare Simple_in_one_joined_env.compare
+ end
+
+ include T0
+ include Container_types.Make (T0)
+
+ let fold = Index.Map.fold
+
+ let is_empty = Index.Map.is_empty
+
+ let empty = Index.Map.empty
+
+ let add = Index.Map.add
+
+ let apply_coercion t coercion =
+ if Coercion.is_id coercion
+ then t
+ else
+ Index.Map.map
+ (fun (simple : Simple_in_one_joined_env.t) ->
+ Simple_in_one_joined_env.create
+ (Simple.apply_coercion_exn (simple :> Simple.t) coercion))
+ t
+
+ let distinct_from_simple_in_target_env (t : t)
+ (simple_in_target_env : Simple_in_target_env.t) =
+ Index.Map.filter_map
+ (fun _ (simple_in_one_joined_env : Simple_in_one_joined_env.t) ->
+ if Simple.equal
+ (simple_in_one_joined_env :> Simple.t)
+ (simple_in_target_env :> Simple.t)
+ then None
+ else Some simple_in_one_joined_env)
+ t
+
+ let in_same_envs t ~as_ = Index.Map.inter (fun _ _ simple -> simple) as_ t
+
+ let is_defined_in envs t = Index.Set.subset envs (Index.Map.keys t)
+
+ let raw_name (t : t) =
+ let shared_name =
+ try
+ Index.Map.fold
+ (fun _ simple raw_name ->
+ Simple.pattern_match' simple
+ ~const:(fun _ -> raw_name)
+ ~symbol:(fun _ ~coercion:_ -> raw_name)
+ ~var:(fun var ~coercion:_ ->
+ let var_name = Variable.raw_name var in
+ match raw_name with
+ | None -> Some var_name
+ | Some raw_name when String.equal raw_name var_name ->
+ Some raw_name
+ | Some _ -> raise Not_found))
+ (t :> Simple.t Index.Map.t)
+ None
+ with Not_found -> None
+ in
+ match shared_name with Some raw_name -> raw_name | None -> "join_var"
+
+ let of_list list =
+ List.fold_left
+ (fun t (index, simple) ->
+ Index.Map.add index (Simple_in_one_joined_env.create simple) t)
+ empty list
+end
+
module Join_aliases : sig
type t
@@ -100,20 +261,26 @@ module Join_aliases : sig
{b Note}: the [simples] must be canonical in their environment. *)
val find :
- mem_name:(Name.t -> bool) ->
- is_bound_strictly_earlier:(Name.t -> than:Simple.t -> bool) ->
- Simple.t Index.Map.t ->
+ exists_in_target_env:
+ (Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
+ is_bound_strictly_earlier:
+ (Name_in_target_env.t -> than:Simple_in_target_env.t -> bool) ->
+ Simple_in_joined_envs.t ->
t ->
- Simple.t Or_unknown_or_bottom.t
+ Simple_in_target_env.t Or_unknown_or_bottom.t
(** [add_existential_var ~mem_name simples t] returns a fresh variable [var]
and an updated [t] where [var] is associated with the [simples]. *)
val add_existential_var :
- mem_name:(Name.t -> bool) -> Simple.t Index.Map.t -> t -> Variable.t * t
+ exists_in_target_env:
+ (Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
+ Simple_in_joined_envs.t ->
+ t ->
+ Variable.t * t
type 'a add_result =
- { values_in_target_env : 'a Index.Map.t Variable.Map.t;
- touched_variables : Variable.Set.t
+ { values_in_target_env : 'a Index.Map.t Name_in_target_env.Map.t;
+ touched_variables : Name_in_target_env.Set.t
}
(** [add_in_target_env ~mem_name t values values_in_target_env] adds the values
@@ -125,19 +292,20 @@ module Join_aliases : sig
for all variables [target_var] in the target environment that are equal to
[var] in the joined environment at [index]. *)
val add_in_target_env :
- mem_name:(Name.t -> bool) ->
+ exists_in_target_env:
+ (Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
t ->
- 'a Variable.Map.t Index.Map.t ->
- 'a Index.Map.t Variable.Map.t ->
+ 'a Name_in_one_joined_env.Map.t Index.Map.t ->
+ 'a Index.Map.t Name_in_target_env.Map.t ->
'a add_result
type join_result = private
- { demoted_in_target_env : Simple.t Variable.Map.t;
+ { demoted_in_target_env : Simple_in_target_env.t Name_in_target_env.Map.t;
(** Variables that should be demoted in the target env as a result of the
join.
The demoted variables are no longer present in [t]. *)
- demoted_in_some_envs : Simple.t Index.Map.t Variable.Map.t;
+ demoted_in_some_envs : Simple_in_joined_envs.t Name_in_target_env.Map.t;
(** Variables that have been demoted in some (possibly all, if
they have been demoted to distinct canonicals) of the joined
environments, but not in the target enviroment.
@@ -148,38 +316,23 @@ module Join_aliases : sig
}
val n_way_join :
- mem_name:(Name.t -> bool) ->
- is_bound_strictly_earlier:(Name.t -> than:Simple.t -> bool) ->
+ exists_in_target_env:
+ (Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
+ is_bound_strictly_earlier:
+ (Name_in_target_env.t -> than:Simple_in_target_env.t -> bool) ->
t ->
- Simple.t Variable.Map.t Index.Map.t ->
+ Simple_in_one_joined_env.t Name_in_one_joined_env.Map.t Index.Map.t ->
join_result Or_bottom.t
end = struct
- module Indexed_simple = Container_types.Make (struct
- type t = Simple.t Index.Map.t
-
- let print = Index.Map.print Simple.print
-
- let hash map =
- Index.Map.fold
- (fun index simple hash ->
- Hashtbl.hash (hash, Index.hash index, Simple.hash simple))
- map (Hashtbl.hash 0)
-
- let equal = Index.Map.equal Simple.equal
-
- let compare = Index.Map.compare Simple.compare
- end)
-
- module ISM = Indexed_simple.Map
-
type t =
- { joined_simples : Variable.t ISM.t;
+ { joined_simples : Name_in_target_env.t Simple_in_joined_envs.Map.t;
(** Maps a tuple of simples in the joined environments to the variable
that represents it in the target environment, if any.
If there is a mapping [simples -> var] in [joined_simples], then
[demoted_from_target_env(var) = simples]. *)
- demoted_from_target_env : Simple.t Index.Map.t Variable.Map.t;
+ demoted_from_target_env :
+ Simple_in_joined_envs.t Name_in_target_env.Map.t;
(** Maps a variable defined in the target environment to its
canonicals in each joined environment {b where it has been
demoted}.
@@ -197,23 +350,37 @@ end = struct
the case for the shared variable with the latest binding time
(because a shared variable with an earlier binding time can never
be demoted to a shared variable with a later binding time). *)
- names_in_target_env : Variable.Set.t Variable.Map.t Index.Map.t
+ names_in_target_env :
+ Name_in_target_env.Set.t Name_in_one_joined_env.Map.t Index.Map.t
(** Maps a variable in a joined environment to the set of
(other) variables it is equal to in the target environment. *)
}
let empty =
- { joined_simples = ISM.empty;
- demoted_from_target_env = Variable.Map.empty;
+ { joined_simples = Simple_in_joined_envs.Map.empty;
+ demoted_from_target_env = Name_in_target_env.Map.empty;
names_in_target_env = Index.Map.empty
}
- let find ~mem_name ~is_bound_strictly_earlier (simples : Simple.t Index.Map.t)
- t : _ Or_unknown_or_bottom.t =
- let[@inline] mem_simple simple =
- Simple.pattern_match simple
- ~const:(fun _ -> true)
- ~name:(fun name ~coercion:_ -> mem_name name)
+ let find
+ ~(exists_in_target_env :
+ Name_in_one_joined_env.t -> Name_in_target_env.t option)
+ ~(is_bound_strictly_earlier :
+ Name_in_target_env.t -> than:Simple_in_target_env.t -> bool)
+ (simples : Simple_in_joined_envs.t) t : _ Or_unknown_or_bottom.t =
+ let[@inline] simple_exists_in_target_env simple_in_one_joined_env =
+ Simple_in_one_joined_env.pattern_match simple_in_one_joined_env
+ ~const:(fun const ->
+ Some (Simple_in_target_env.create (Simple.const const)))
+ ~name:(fun name_in_one_joined_env ~coercion ->
+ match exists_in_target_env name_in_one_joined_env with
+ | None -> None
+ | Some name_in_target_env ->
+ Some
+ (Simple_in_target_env.create
+ (Simple.with_coercion
+ (Simple.name (name_in_target_env :> Name.t))
+ coercion)))
in
(* We need to determine if the provided set of simples (which are assumed to
be canonicals in their own environment) has an existing name in the
@@ -256,22 +423,33 @@ end = struct
defined in the target environment to combine tests for cases 1) and
2). *)
let latest_bound_simple =
- Index.Map.fold
+ Simple_in_joined_envs.fold
(fun _ simple acc : _ Or_unknown_or_bottom.t ->
match (acc : _ Or_unknown_or_bottom.t) with
- | Bottom | Unknown -> if mem_simple simple then Ok simple else Unknown
+ | Bottom | Unknown -> (
+ match simple_exists_in_target_env simple with
+ | None -> Unknown
+ | Some simple -> Ok simple)
| Ok existing_simple -> (
- match Simple.must_be_var simple with
+ match Simple.must_be_var (simple :> Simple.t) with
| None -> acc
- | Some (var, _coercion) ->
- if mem_name (Name.var var)
- then
+ | Some (var, coercion) -> (
+ match
+ exists_in_target_env
+ (Name_in_one_joined_env.create (Name.var var))
+ with
+ | None -> acc
+ | Some name_in_target_env ->
(* NB: These are not actually aliases in the target env yet. *)
- if is_bound_strictly_earlier (Name.var var)
+ if is_bound_strictly_earlier name_in_target_env
~than:existing_simple
- then Ok simple
- else acc
- else acc))
+ then
+ Ok
+ (Simple_in_target_env.create
+ (Simple.with_coercion
+ (Simple.name (name_in_target_env :> Name.t))
+ coercion))
+ else acc)))
simples Or_unknown_or_bottom.Bottom
in
let[@local] find_local_variable () : _ Or_unknown_or_bottom.t =
@@ -280,9 +458,9 @@ end = struct
This means that we might end up creating more local variables than
would be strictly necessary, but they have more precise types. *)
- match ISM.find_opt simples t.joined_simples with
+ match Simple_in_joined_envs.Map.find_opt simples t.joined_simples with
| None -> Unknown
- | Some var -> Ok (Simple.var var)
+ | Some name -> Ok (Simple_in_target_env.name name)
in
match latest_bound_simple with
| Bottom -> Bottom
@@ -290,28 +468,28 @@ end = struct
(* Join of existential variables can only be case 3) or 4) *)
find_local_variable ()
| Ok latest_bound_simple -> (
- match Simple.must_be_var latest_bound_simple with
+ let earlier_bound_simples =
+ Simple_in_joined_envs.distinct_from_simple_in_target_env simples
+ latest_bound_simple
+ in
+ match Simple.must_be_name (latest_bound_simple :> Simple.t) with
| None ->
(* Case 1), 3), or 4) *)
- if Index.Map.for_all
- (fun _ simple -> Simple.equal simple latest_bound_simple)
- simples
+ if Simple_in_joined_envs.is_empty earlier_bound_simples
then Ok latest_bound_simple
else find_local_variable ()
- | Some (var, coercion) ->
+ | Some (name, coercion) ->
(* Case 2), 3), or 4) *)
- let coercion_to_var = Coercion.inverse coercion in
+ let coercion_to_name = Coercion.inverse coercion in
let earlier_bound_simples =
- Index.Map.filter_map
- (fun _ simple ->
- if Simple.equal simple latest_bound_simple
- then None
- else Some (Simple.apply_coercion_exn simple coercion_to_var))
- simples
+ Simple_in_joined_envs.apply_coercion earlier_bound_simples
+ coercion_to_name
in
- let canonicals_for_var =
- Option.value ~default:Index.Map.empty
- (Variable.Map.find_opt var t.demoted_from_target_env)
+ let canonicals_for_name =
+ Option.value ~default:Simple_in_joined_envs.empty
+ (Name_in_target_env.Map.find_opt
+ (Name_in_target_env.create name)
+ t.demoted_from_target_env)
in
(* Consider the case where we have [a -> (1:b, 2:c)], i.e. [a] has been
demoted to [b] in environment [1] and to [c] in environment [2], but
@@ -331,104 +509,118 @@ end = struct
extension, so we favor preserving equalities for variables defined in
the target env and precision for existential variables (cf
[find_local_variable]). *)
- let canonicals_for_var =
- Index.Map.inter
- (fun _ _ canonical -> canonical)
- simples canonicals_for_var
+ let canonicals_for_name =
+ Simple_in_joined_envs.in_same_envs ~as_:simples canonicals_for_name
in
- if Index.Map.equal Simple.equal earlier_bound_simples canonicals_for_var
+ if Simple_in_joined_envs.equal earlier_bound_simples canonicals_for_name
then Ok latest_bound_simple
else find_local_variable ())
- let add_existential_var ~mem_name simples t =
- let shared_name =
- try
- Index.Map.fold
- (fun _ simple raw_name ->
- Simple.pattern_match' simple
- ~const:(fun _ -> raw_name)
- ~symbol:(fun _ ~coercion:_ -> raw_name)
- ~var:(fun var ~coercion:_ ->
- let var_name = Variable.raw_name var in
- match raw_name with
- | None -> Some var_name
- | Some raw_name when String.equal raw_name var_name ->
- Some raw_name
- | Some _ -> raise Not_found))
- simples None
- with Not_found -> None
- in
- let raw_name =
- match shared_name with Some raw_name -> raw_name | None -> "join_var"
- in
+ let add_existential_var ~exists_in_target_env simples t =
+ (* We have encountered a [Simple_in_joined_envs.t] that does not cleanly
+ correspond to the demotion of a name in the target env, e.g. we have type
+ "= a" on the left and "= b" on the right but no variable that is equal to
+ "a" on the left and "b" on the right yet.
+
+ We now create a new existential variable for this pair of values, and
+ record it so that it can be found by [find] if we encounter the same set
+ of values later. *)
+ let raw_name = Simple_in_joined_envs.raw_name simples in
let var = Variable.create raw_name in
- let joined_simples = ISM.add simples var t.joined_simples in
+ let var_as_name = Name_in_target_env.create (Name.var var) in
+ let joined_simples =
+ Simple_in_joined_envs.Map.add simples var_as_name t.joined_simples
+ in
let demoted_from_target_env =
- Variable.Map.add var simples t.demoted_from_target_env
+ Name_in_target_env.Map.add var_as_name simples t.demoted_from_target_env
in
let names_in_target_env =
- Index.Map.fold
+ Simple_in_joined_envs.fold
(fun index simple names_in_target_env ->
- match Simple.must_be_var simple with
- | Some (joined_var, coercion)
- when Coercion.is_id coercion && mem_name (Name.var joined_var) ->
- Index.Map.update index
- (fun names_from_this_env_in_target_env ->
- let names_from_this_env_in_target_env =
- Option.value ~default:Variable.Map.empty
- names_from_this_env_in_target_env
- in
- Some
- (Variable.Map.update joined_var
- (function
- | None -> Some (Variable.Set.singleton var)
- | Some existing_vars ->
- Some (Variable.Set.add var existing_vars))
- names_from_this_env_in_target_env))
- names_in_target_env
+ match Simple.must_be_var (simple :> Simple.t) with
+ | Some (joined_var, coercion) when Coercion.is_id coercion -> (
+ let name_in_joined_env =
+ Name_in_one_joined_env.create (Name.var joined_var)
+ in
+ match exists_in_target_env name_in_joined_env with
+ | None -> names_in_target_env
+ | Some (name_in_target_env : Name_in_target_env.t) ->
+ Index.Map.update index
+ (fun names_from_this_env_in_target_env ->
+ let names_from_this_env_in_target_env =
+ Option.value ~default:Name_in_one_joined_env.Map.empty
+ names_from_this_env_in_target_env
+ in
+ Some
+ (Name_in_one_joined_env.Map.update name_in_joined_env
+ (function
+ | None ->
+ Some
+ (Name_in_target_env.Set.singleton
+ name_in_target_env)
+ | Some existing_names ->
+ Some
+ (Name_in_target_env.Set.add name_in_target_env
+ existing_names))
+ names_from_this_env_in_target_env))
+ names_in_target_env)
| _ -> names_in_target_env)
simples t.names_in_target_env
in
var, { joined_simples; names_in_target_env; demoted_from_target_env }
- let find_canonicals demoted_var t =
- match Variable.Map.find_opt demoted_var t.demoted_from_target_env with
+ let find_canonicals demoted_in_target_env t =
+ match
+ Name_in_target_env.Map.find_opt demoted_in_target_env
+ t.demoted_from_target_env
+ with
| Some canonicals -> canonicals
| None ->
- Misc.fatal_errorf "Variable %a was not demoted." Variable.print
- demoted_var
+ Misc.fatal_errorf "Variable %a was not demoted." Name_in_target_env.print
+ demoted_in_target_env
- let forget_demoted_var demoted_var t =
- (* [demoted_var] is demoted to [simple] in all environments.
+ let forget_demoted_var demoted_in_target_env t =
+ (* [demoted_in_target_env] is demoted to the same simple in all
+ environments.
Remove it from all maps (except [map_to_canonical], which records the
- demotion) -- for all intents and purposes, we only need to consider the
- canonical [simple]. *)
- let canonicals = find_canonicals demoted_var t in
+ demotion) -- we don't need to treat it as an name in the target env of
+ joined simples, since we have its new canonical instead. *)
+ let canonicals = find_canonicals demoted_in_target_env t in
let demoted_from_target_env =
- Variable.Map.remove demoted_var t.demoted_from_target_env
+ Name_in_target_env.Map.remove demoted_in_target_env
+ t.demoted_from_target_env
in
let names_in_target_env =
- Index.Map.fold
+ Simple_in_joined_envs.fold
(fun index simple names_in_target_env ->
- match Simple.must_be_var simple with
+ match Simple.must_be_var (simple :> Simple.t) with
| Some (var, coercion) when Coercion.is_id coercion ->
+ let name_in_joined_env =
+ Name_in_one_joined_env.create (Name.var var)
+ in
Index.Map.update index
(fun names_for_index ->
let names_for_index =
- Option.value ~default:Variable.Map.empty names_for_index
+ Option.value ~default:Name_in_one_joined_env.Map.empty
+ names_for_index
in
let names_for_index =
- Variable.Map.update var
+ Name_in_one_joined_env.Map.update name_in_joined_env
(fun names ->
let names =
- Option.value ~default:Variable.Set.empty names
+ Option.value ~default:Name_in_target_env.Set.empty names
in
- let names = Variable.Set.remove demoted_var names in
- if Variable.Set.is_empty names then None else Some names)
+ let names =
+ Name_in_target_env.Set.remove demoted_in_target_env
+ names
+ in
+ if Name_in_target_env.Set.is_empty names
+ then None
+ else Some names)
names_for_index
in
- if Variable.Map.is_empty names_for_index
+ if Name_in_one_joined_env.Map.is_empty names_for_index
then None
else Some names_for_index)
names_in_target_env
@@ -437,118 +629,203 @@ end = struct
in
{ t with demoted_from_target_env; names_in_target_env }
- let expand_to_names_in_target_env ~mem_name ~update_names names_in_target_env
- table acc =
+ (* This function is responsible for recording demotions, represented as a map
+ from names to their {b current canonical simple} in each joined env.
+
+ This means we must:
+
+ - Update the [names_in_target_env] map to ensure the keys are canonicals in
+ the corresponding joined env and, if demoting a name that exists in the
+ target env, include the new name as an alias of the new canonical.
+
+ - Update the [demoted_from_target_env] map with the new canonicals in the
+ joined envs (recall that [demoted_from_target_env] only stores canonicals
+ in the joined envs that are *distinct* from the name in the target env). *)
+ let apply_demotions ~exists_in_target_env t all_demotions =
Index.Map.fold
- (fun index values (acc, names_in_target_env, touched_vars) ->
+ (fun index values
+ (demoted_from_target_env, names_in_target_env, touched_vars) ->
let names_from_this_env_in_target_env =
- Option.value ~default:Variable.Map.empty
+ Option.value ~default:Name_in_one_joined_env.Map.empty
(Index.Map.find_opt index names_in_target_env)
in
- let acc, names_from_this_env_in_target_env, touched_vars =
- Variable.Map.fold
- (fun var value
- (acc, names_from_this_env_in_target_env, touched_vars) ->
+ let ( demoted_from_target_env,
+ names_from_this_env_in_target_env,
+ touched_vars ) =
+ Name_in_one_joined_env.Map.fold
+ (fun demoted_var
+ (canonical_in_joined_env : Simple_in_one_joined_env.t)
+ ( demoted_from_target_env,
+ names_from_this_env_in_target_env,
+ touched_vars ) ->
+ (* Usually, we expect that there is no entry in the
+ [names_in_target_env] map for a variable we are demoting, since
+ we only introduce entries on canonicals.
+
+ However if we are processing an env extension with a demotion
+ [y -> z], we could have demoted [x -> y] at the toplevel
+ [cut_and_n_way_join], which would have introduced a mapping
+ from [y] to [{ x }] (since [x] is a name for [y] in the target
+ env). In this case, we need to remove the mapping for [y]
+ (since it is no longer canonical in the extension) and
+ introduce the mapping [z -> { x }] (if [y] does not exist in
+ the target env) or [z -> { x, y }] (if [y] exists in the target
+ env) instead. *)
let vars_in_target_env =
- Option.value ~default:Variable.Set.empty
- (Variable.Map.find_opt var names_from_this_env_in_target_env)
+ Option.value ~default:Name_in_target_env.Set.empty
+ (Name_in_one_joined_env.Map.find_opt demoted_var
+ names_from_this_env_in_target_env)
in
let vars_in_target_env =
- if mem_name (Name.var var)
- then Variable.Set.add var vars_in_target_env
- else vars_in_target_env
+ match exists_in_target_env demoted_var with
+ | None -> vars_in_target_env
+ | Some name_in_target_env ->
+ Name_in_target_env.Set.add name_in_target_env
+ vars_in_target_env
in
let names_from_this_env_in_target_env =
- update_names var vars_in_target_env value
- names_from_this_env_in_target_env
+ let names_from_this_env_in_target_env =
+ Name_in_one_joined_env.Map.remove demoted_var
+ names_from_this_env_in_target_env
+ in
+ match
+ Simple.must_be_var (canonical_in_joined_env :> Simple.t)
+ with
+ | Some (canonical_var, coercion) when Coercion.is_id coercion ->
+ Name_in_one_joined_env.Map.update
+ (Name_in_one_joined_env.create (Name.var canonical_var))
+ (function
+ | None -> Some vars_in_target_env
+ | Some existing_vars ->
+ Some
+ (Name_in_target_env.Set.union existing_vars
+ vars_in_target_env))
+ names_from_this_env_in_target_env
+ | _ -> names_from_this_env_in_target_env
in
- let acc =
- Variable.Set.fold
+ let demoted_from_target_env =
+ Name_in_target_env.Set.fold
(fun var_in_target_env values ->
- Variable.Map.update var_in_target_env
- (function
- | None -> Some (Index.Map.singleton index value)
- | Some values_in_other_envs ->
- Some (Index.Map.add index value values_in_other_envs))
+ Name_in_target_env.Map.update var_in_target_env
+ (fun canonical_in_joined_envs ->
+ let canonical_in_joined_envs =
+ Option.value ~default:Simple_in_joined_envs.empty
+ canonical_in_joined_envs
+ in
+ Some
+ (Simple_in_joined_envs.add index
+ canonical_in_joined_env canonical_in_joined_envs))
values)
- vars_in_target_env acc
+ vars_in_target_env demoted_from_target_env
in
- ( acc,
+ ( demoted_from_target_env,
names_from_this_env_in_target_env,
- Variable.Set.union vars_in_target_env touched_vars ))
+ Name_in_target_env.Set.union vars_in_target_env touched_vars ))
values
- (acc, names_from_this_env_in_target_env, touched_vars)
+ ( demoted_from_target_env,
+ names_from_this_env_in_target_env,
+ touched_vars )
in
- ( acc,
+ ( demoted_from_target_env,
Index.Map.add index names_from_this_env_in_target_env
names_in_target_env,
touched_vars ))
- table
- (acc, names_in_target_env, Variable.Set.empty)
+ all_demotions
+ ( t.demoted_from_target_env,
+ t.names_in_target_env,
+ Name_in_target_env.Set.empty )
type 'a add_result =
- { values_in_target_env : 'a Index.Map.t Variable.Map.t;
- touched_variables : Variable.Set.t
+ { values_in_target_env : 'a Index.Map.t Name_in_target_env.Map.t;
+ touched_variables : Name_in_target_env.Set.t
}
- let add_in_target_env ~mem_name t table values_by_index =
- let values_in_target_env, _names_in_target_env, touched_variables =
- expand_to_names_in_target_env ~mem_name
- ~update_names:(fun _ _ _ names -> names)
- t.names_in_target_env table values_by_index
+ (* Takes a map of values in joined envs (i.e. a map from canonical names in a
+ joined env to values of type ['a] for each joined env) and transforms it
+ into a map of values in the target env by adding the values on name [n] to
+ all the aliases of [n] that are canonical in the target env. *)
+ let add_in_target_env ~exists_in_target_env t values_in_joined_envs
+ values_in_target_env =
+ let values_in_target_env, touched_variables =
+ Index.Map.fold
+ (fun index values_in_joined_env (values_in_target_env, touched_vars) ->
+ let names_from_this_env_in_target_env =
+ Option.value ~default:Name_in_one_joined_env.Map.empty
+ (Index.Map.find_opt index t.names_in_target_env)
+ in
+ let values_in_target_env, touched_vars =
+ Name_in_one_joined_env.Map.fold
+ (fun var value (acc, touched_vars) ->
+ let vars_in_target_env =
+ Option.value ~default:Name_in_target_env.Set.empty
+ (Name_in_one_joined_env.Map.find_opt var
+ names_from_this_env_in_target_env)
+ in
+ let vars_in_target_env =
+ match exists_in_target_env var with
+ | None -> vars_in_target_env
+ | Some name_in_target_env ->
+ Name_in_target_env.Set.add name_in_target_env
+ vars_in_target_env
+ in
+ let values_in_target_env =
+ Name_in_target_env.Set.fold
+ (fun var_in_target_env values ->
+ Name_in_target_env.Map.update var_in_target_env
+ (function
+ | None -> Some (Index.Map.singleton index value)
+ | Some values_in_other_envs ->
+ Some
+ (Index.Map.add index value values_in_other_envs))
+ values)
+ vars_in_target_env acc
+ in
+ ( values_in_target_env,
+ Name_in_target_env.Set.union vars_in_target_env touched_vars ))
+ values_in_joined_env
+ (values_in_target_env, touched_vars)
+ in
+ values_in_target_env, touched_vars)
+ values_in_joined_envs
+ (values_in_target_env, Name_in_target_env.Set.empty)
in
{ values_in_target_env; touched_variables }
type join_result =
- { demoted_in_target_env : Simple.t Variable.Map.t;
- demoted_in_some_envs : Simple.t Index.Map.t Variable.Map.t;
+ { demoted_in_target_env : Simple_in_target_env.t Name_in_target_env.Map.t;
+ demoted_in_some_envs : Simple_in_joined_envs.t Name_in_target_env.Map.t;
t : t
}
- let n_way_join0 ~mem_name ~is_bound_strictly_earlier t all_demotions =
+ let n_way_join0 ~exists_in_target_env ~is_bound_strictly_earlier t
+ all_demotions =
let demoted_from_target_env, names_in_target_env, touched_vars =
- expand_to_names_in_target_env ~mem_name
- ~update_names:
- (fun demoted_var names_of_demoted_in_target_env canonical_simple
- names_from_this_env_in_target_env ->
- let names_from_this_env_in_target_env =
- Variable.Map.remove demoted_var names_from_this_env_in_target_env
- in
- match Simple.must_be_var canonical_simple with
- | Some (canonical_var, coercion)
- when Coercion.is_id coercion && mem_name (Name.var canonical_var) ->
- Variable.Map.update canonical_var
- (function
- | None -> Some names_of_demoted_in_target_env
- | Some existing_vars ->
- Some
- (Variable.Set.union existing_vars
- names_of_demoted_in_target_env))
- names_from_this_env_in_target_env
- | _ -> names_from_this_env_in_target_env)
- t.names_in_target_env all_demotions t.demoted_from_target_env
+ apply_demotions ~exists_in_target_env t all_demotions
in
let t = { t with demoted_from_target_env; names_in_target_env } in
let all_indices = Index.Map.keys all_demotions in
- Variable.Set.fold
+ Name_in_target_env.Set.fold
(fun demoted_var { demoted_in_target_env; demoted_in_some_envs; t } ->
let canonicals = find_canonicals demoted_var t in
let[@local] is_demoted_in_some_envs t =
let demoted_in_some_envs =
- Variable.Map.add demoted_var canonicals demoted_in_some_envs
+ Name_in_target_env.Map.add demoted_var canonicals
+ demoted_in_some_envs
in
{ demoted_in_target_env; demoted_in_some_envs; t }
in
let[@local] is_demoted_in_all_envs t =
let joined_simples =
- ISM.add canonicals demoted_var t.joined_simples
+ Simple_in_joined_envs.Map.add canonicals demoted_var
+ t.joined_simples
in
is_demoted_in_some_envs { t with joined_simples }
in
let[@local] is_demoted_in_target_env canonical t =
let t = forget_demoted_var demoted_var t in
let demoted_in_target_env =
- Variable.Map.add demoted_var canonical demoted_in_target_env
+ Name_in_target_env.Map.add demoted_var canonical
+ demoted_in_target_env
in
{ demoted_in_target_env; demoted_in_some_envs; t }
in
@@ -558,27 +835,31 @@ end = struct
environments.
This can only happen in the presence of env extensions. *)
- if not (Index.Set.subset all_indices (Index.Map.keys canonicals))
+ if not (Simple_in_joined_envs.is_defined_in all_indices canonicals)
then is_demoted_in_some_envs t
else
- match find ~mem_name ~is_bound_strictly_earlier canonicals t with
+ match
+ find ~exists_in_target_env ~is_bound_strictly_earlier canonicals t
+ with
| Bottom ->
Misc.fatal_error
"Unexpected bottom for non-empty set of canonicals."
| Unknown -> is_demoted_in_all_envs t
| Ok simple -> is_demoted_in_target_env simple t)
touched_vars
- { demoted_in_target_env = Variable.Map.empty;
- demoted_in_some_envs = Variable.Map.empty;
+ { demoted_in_target_env = Name_in_target_env.Map.empty;
+ demoted_in_some_envs = Name_in_target_env.Map.empty;
t
}
- let n_way_join ~mem_name ~is_bound_strictly_earlier t all_demotions =
+ let n_way_join ~exists_in_target_env ~is_bound_strictly_earlier t
+ all_demotions =
if Index.Map.is_empty all_demotions
then Or_bottom.Bottom
else
Or_bottom.Ok
- (n_way_join0 ~mem_name ~is_bound_strictly_earlier t all_demotions)
+ (n_way_join0 ~exists_in_target_env ~is_bound_strictly_earlier t
+ all_demotions)
end
module Join_equations = struct
@@ -590,15 +871,16 @@ module Join_equations = struct
{b Note}: A variable can have a more precise joined type if, and only if,
it has been given a new type in {b all} the joined environments. *)
- type t = ET.t Index.Map.t Variable.Map.t
+ type t = ET.t Index.Map.t Name_in_target_env.Map.t
- let empty = Variable.Map.empty
+ let empty = Name_in_target_env.Map.empty
let find var t =
- Option.value ~default:Index.Map.empty (Variable.Map.find_opt var t)
+ Option.value ~default:Index.Map.empty
+ (Name_in_target_env.Map.find_opt var t)
let n_way_join ~n_way_join_type vars equations st =
- Variable.Map.fold
+ Name_in_target_env.Map.fold
(fun var types (equations, st) ->
let types =
Index.Map.fold
@@ -607,28 +889,30 @@ module Join_equations = struct
in
match (n_way_join_type st types : _ Or_unknown.t * _) with
| Unknown, st -> equations, st
- | Known ty, st -> Variable.Map.add var ty equations, st)
+ | Known ty, st -> Name_in_target_env.Map.add var ty equations, st)
vars (equations, st)
let add_joined_simple ~joined_envs demoted_var canonicals joined_types =
- Variable.Map.update demoted_var
+ Name_in_target_env.Map.update demoted_var
(fun types_of_demoted_var ->
let types_of_demoted_var =
Option.value ~default:Index.Map.empty types_of_demoted_var
in
let types_of_demoted_var =
- Index.Map.fold
+ Simple_in_joined_envs.fold
(fun index canonical types_of_demoted_var ->
let env = Index.Map.find index joined_envs in
+ let canonical_simple = (canonical :> Simple.t) in
let ty =
- Simple.pattern_match canonical
+ Simple.pattern_match canonical_simple
~const:More_type_creators.type_for_const
~name:(fun name ~coercion ->
TG.apply_coercion (TE.find env name None) coercion)
in
let expanded =
Expand_head.expand_head0 env ty
- ~known_canonical_simple_at_in_types_mode:(Some canonical)
+ ~known_canonical_simple_at_in_types_mode:
+ (Some canonical_simple)
in
Index.Map.add index expanded types_of_demoted_var)
canonicals types_of_demoted_var
@@ -642,8 +926,8 @@ module Symbol_projection = struct
include Container_types.Make (Symbol_projection)
end
-let n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
- join_aliases joined_envs all_symbol_projections =
+let n_way_join_symbol_projections ~exists_in_target_env
+ ~is_bound_strictly_earlier join_aliases joined_envs all_symbol_projections =
let joined_projections =
Index.Map.fold
(fun index symbol_projections acc ->
@@ -654,11 +938,15 @@ let n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
TE.get_canonical_simple_exn typing_env (Simple.var var)
~min_name_mode:Name_mode.in_types
in
+ let canonical = Simple_in_one_joined_env.create canonical in
Symbol_projection.Map.update symbol_projection
- (function
- | None -> Some (Index.Map.singleton index canonical)
- | Some projections_in_other_envs ->
- Some (Index.Map.add index canonical projections_in_other_envs))
+ (fun joined_projections ->
+ let joined_projections =
+ Option.value joined_projections
+ ~default:Simple_in_joined_envs.empty
+ in
+ Some
+ (Simple_in_joined_envs.add index canonical joined_projections))
acc)
symbol_projections acc)
all_symbol_projections Symbol_projection.Map.empty
@@ -666,16 +954,16 @@ let n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
let all_indices = Index.Map.keys joined_envs in
Symbol_projection.Map.fold
(fun symbol_projection simples symbol_projections ->
- if not (Index.Set.subset all_indices (Index.Map.keys simples))
+ if not (Simple_in_joined_envs.is_defined_in all_indices simples)
then symbol_projections
else
match
- Join_aliases.find ~mem_name ~is_bound_strictly_earlier simples
- join_aliases
+ Join_aliases.find ~exists_in_target_env ~is_bound_strictly_earlier
+ simples join_aliases
with
| Bottom | Unknown -> symbol_projections
| Ok simple -> (
- match Simple.must_be_var simple with
+ match Simple.must_be_var (simple :> Simple.t) with
| Some (var, coercion) when Coercion.is_id coercion ->
Variable.Map.add var symbol_projection symbol_projections
| _ -> symbol_projections))
@@ -685,7 +973,7 @@ type t =
{ join_aliases : Join_aliases.t;
join_types : Join_equations.t;
existential_vars : K.t Variable.Map.t;
- pending_vars : Simple.t Index.Map.t Variable.Map.t;
+ pending_vars : Simple_in_joined_envs.t Name_in_target_env.Map.t;
(* Existential variables that have been defined by their names in all the
joined environment, but whose type has not yet been computed. *)
joined_envs : TE.t Index.Map.t;
@@ -697,9 +985,9 @@ type t =
}
type join_result =
- { demoted_in_target_env : Simple.t Variable.Map.t;
+ { demoted_in_target_env : Simple_in_target_env.t Name_in_target_env.Map.t;
extra_variables : K.t Variable.Map.t;
- equations : TG.t Variable.Map.t;
+ equations : TG.t Name_in_target_env.Map.t;
symbol_projections : Symbol_projection.t Variable.Map.t
}
@@ -717,12 +1005,21 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
match Name.must_be_var_opt name with
| None -> demotions, expanded_equations
| Some var -> (
+ let name_in_joined_env =
+ Name_in_one_joined_env.create (Name.var var)
+ in
+ (* Note: we must compute the current canonical here, because
+ [Join_aliases.n_way_join] expects a fully compressed map
+ demotions (i.e. the right-hand side must not themselves be
+ demoted) *)
match
TE.get_alias_then_canonical_simple_exn
~min_name_mode:Name_mode.in_types typing_env ty
with
| canonical_simple ->
- ( Variable.Map.add var canonical_simple demotions,
+ ( Name_in_one_joined_env.Map.add name_in_joined_env
+ (Simple_in_one_joined_env.create canonical_simple)
+ demotions,
expanded_equations )
| exception Not_found ->
let expanded =
@@ -730,9 +1027,11 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
~known_canonical_simple_at_in_types_mode:
(Some (Simple.var var))
in
- demotions, Variable.Map.add var expanded expanded_equations))
+ ( demotions,
+ Name_in_one_joined_env.Map.add name_in_joined_env expanded
+ expanded_equations )))
equations
- (Variable.Map.empty, Variable.Map.empty)
+ (Name_in_one_joined_env.Map.empty, Name_in_one_joined_env.Map.empty)
in
( Index.Map.add index demotions all_demotions,
Index.Map.add index expanded_equations all_expanded_equations,
@@ -740,34 +1039,43 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
all_levels
(Index.Map.empty, Index.Map.empty, Index.Map.empty)
in
- let mem_name = TE.mem ~min_name_mode:Name_mode.in_types t.target_env in
- let is_bound_strictly_earlier name ~than =
- TE.alias_is_bound_strictly_earlier t.target_env ~bound_name:name ~alias:than
+ let target_env = t.target_env in
+ let exists_in_target_env (name : Name_in_one_joined_env.t) =
+ if TE.mem ~min_name_mode:Name_mode.in_types target_env (name :> Name.t)
+ then Some (Name_in_target_env.create (name :> Name.t))
+ else None
+ in
+ let is_bound_strictly_earlier (name : Name_in_target_env.t)
+ ~(than : Simple_in_target_env.t) =
+ TE.alias_is_bound_strictly_earlier t.target_env
+ ~bound_name:(name :> Name.t)
+ ~alias:(than :> Simple.t)
in
match
- Join_aliases.n_way_join ~mem_name ~is_bound_strictly_earlier t.join_aliases
- all_demotions
+ Join_aliases.n_way_join ~exists_in_target_env ~is_bound_strictly_earlier
+ t.join_aliases all_demotions
with
| Bottom -> Bottom
| Ok { demoted_in_target_env; demoted_in_some_envs; t = join_aliases } ->
let join_types =
- Variable.Map.fold
+ Name_in_target_env.Map.fold
(Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
demoted_in_some_envs t.join_types
in
let { Join_aliases.values_in_target_env = join_types;
touched_variables = touched_vars
} =
- Join_aliases.add_in_target_env ~mem_name join_aliases
+ Join_aliases.add_in_target_env ~exists_in_target_env join_aliases
all_expanded_equations join_types
in
let touched_vars =
- Variable.Set.union touched_vars (Variable.Map.keys demoted_in_some_envs)
+ Name_in_target_env.Set.union touched_vars
+ (Name_in_target_env.Map.keys demoted_in_some_envs)
in
let t = { t with join_aliases; join_types } in
let all_indices = Index.Map.keys t.joined_envs in
let equations_to_join =
- Variable.Set.fold
+ Name_in_target_env.Set.fold
(fun var new_vars ->
let types = Join_equations.find var t.join_types in
if not (Index.Set.subset all_indices (Index.Map.keys types))
@@ -778,19 +1086,20 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
let types =
Index.Map.inter (fun _ _ expanded -> expanded) t.joined_envs types
in
- Variable.Map.add var types new_vars)
- touched_vars Variable.Map.empty
+ Name_in_target_env.Map.add var types new_vars)
+ touched_vars Name_in_target_env.Map.empty
in
let rec loop equations_to_join joined_equations t =
let equations, t =
Join_equations.n_way_join ~n_way_join_type equations_to_join
joined_equations t
in
- if Variable.Map.is_empty t.pending_vars
+ if Name_in_target_env.Map.is_empty t.pending_vars
then
let symbol_projections =
- n_way_join_symbol_projections ~mem_name ~is_bound_strictly_earlier
- t.join_aliases t.joined_envs all_symbol_projections
+ n_way_join_symbol_projections ~exists_in_target_env
+ ~is_bound_strictly_earlier t.join_aliases t.joined_envs
+ all_symbol_projections
in
Or_bottom.Ok
{ demoted_in_target_env;
@@ -800,19 +1109,19 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
}
else
let join_types =
- Variable.Map.fold
+ Name_in_target_env.Map.fold
(Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
t.pending_vars t.join_types
in
let equations_to_join =
- Variable.Map.mapi
+ Name_in_target_env.Map.mapi
(fun var _ -> Join_equations.find var join_types)
t.pending_vars
in
- let pending_vars = Variable.Map.empty in
+ let pending_vars = Name_in_target_env.Map.empty in
loop equations_to_join equations { t with pending_vars; join_types }
in
- loop equations_to_join Variable.Map.empty t
+ loop equations_to_join Name_in_target_env.Map.empty t
let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env
joined_envs =
@@ -831,7 +1140,7 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env
{ join_aliases = Join_aliases.empty;
join_types = Join_equations.empty;
existential_vars = Variable.Map.empty;
- pending_vars = Variable.Map.empty;
+ pending_vars = Name_in_target_env.Map.empty;
joined_envs;
target_env
}
@@ -851,17 +1160,19 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env
extra_variables target_env
in
let target_env =
- Variable.Map.fold
- (fun var simple target_env ->
- let kind = TG.kind (TE.find target_env (Name.var var) None) in
+ Name_in_target_env.Map.fold
+ (fun name (simple : Simple_in_target_env.t) target_env ->
+ let name = (name :> Name.t) in
+ let simple = (simple :> Simple.t) in
+ let kind = TG.kind (TE.find target_env name None) in
let ty = TG.alias_type_of kind simple in
- TE.add_equation ~meet_type target_env (Name.var var) ty)
+ TE.add_equation ~meet_type target_env name ty)
demoted_in_target_env target_env
in
let target_env =
- Variable.Map.fold
- (fun var ty target_env ->
- TE.add_equation ~meet_type target_env (Name.var var) ty)
+ Name_in_target_env.Map.fold
+ (fun name ty target_env ->
+ TE.add_equation ~meet_type target_env (name :> Name.t) ty)
equations target_env
in
let target_env =
@@ -906,7 +1217,7 @@ let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
{ join_aliases = t.join_aliases;
join_types = t.join_types;
existential_vars = t.existential_vars;
- pending_vars = Variable.Map.empty;
+ pending_vars = Name_in_target_env.Map.empty;
joined_envs;
target_env = t.target_env
}
@@ -918,20 +1229,23 @@ let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
if not (Variable.Map.is_empty symbol_projections)
then Misc.fatal_error "Unexpected symbol projections in env extension.";
let joined_equations =
- Variable.Map.fold
- (fun var simple equations ->
+ Name_in_target_env.Map.fold
+ (fun name (simple : Simple_in_target_env.t) equations ->
let kind =
- match Variable.Map.find_opt var extra_variables with
- | Some kind -> kind
- | None -> TG.kind (TE.find t.target_env (Name.var var) None)
+ match Name.must_be_var_opt (name :> Name.t) with
+ | None -> TG.kind (TE.find t.target_env (name :> Name.t) None)
+ | Some var -> (
+ match Variable.Map.find_opt var extra_variables with
+ | Some kind -> kind
+ | None -> TG.kind (TE.find t.target_env (name :> Name.t) None))
in
- let ty = TG.alias_type_of kind simple in
- Name.Map.add (Name.var var) ty equations)
+ let ty = TG.alias_type_of kind (simple :> Simple.t) in
+ Name.Map.add (name :> Name.t) ty equations)
demoted_in_target_env Name.Map.empty
in
let joined_equations =
- Variable.Map.fold
- (fun var ty equations -> Name.Map.add (Name.var var) ty equations)
+ Name_in_target_env.Map.fold
+ (fun name ty equations -> Name.Map.add (name :> Name.t) ty equations)
equations joined_equations
in
(* Preserve existential vars since we can't bind them in extensions. *)
@@ -939,23 +1253,35 @@ let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
Or_bottom.Ok (TEE.from_map joined_equations, { t with existential_vars })
let n_way_join_simples t kind simples : _ Or_bottom.t * _ =
- let simples = Index.Map.of_list simples in
- let mem_name = TE.mem ~min_name_mode:Name_mode.in_types t.target_env in
- let is_bound_strictly_earlier name ~than =
- TE.alias_is_bound_strictly_earlier t.target_env ~bound_name:name ~alias:than
+ let simples = Simple_in_joined_envs.of_list simples in
+ let target_env = t.target_env in
+ let exists_in_target_env (name : Name_in_one_joined_env.t) =
+ if TE.mem ~min_name_mode:Name_mode.in_types target_env (name :> Name.t)
+ then Some (Name_in_target_env.create (name :> Name.t))
+ else None
+ in
+ let is_bound_strictly_earlier (name : Name_in_target_env.t)
+ ~(than : Simple_in_target_env.t) =
+ TE.alias_is_bound_strictly_earlier t.target_env
+ ~bound_name:(name :> Name.t)
+ ~alias:(than :> Simple.t)
in
match
- Join_aliases.find ~mem_name ~is_bound_strictly_earlier simples
+ Join_aliases.find ~exists_in_target_env ~is_bound_strictly_earlier simples
t.join_aliases
with
| Bottom -> Bottom, t
- | Ok simple -> Ok simple, t
+ | Ok simple -> Ok (simple :> Simple.t), t
| Unknown ->
let var, join_aliases =
- Join_aliases.add_existential_var ~mem_name simples t.join_aliases
+ Join_aliases.add_existential_var ~exists_in_target_env simples
+ t.join_aliases
in
+ let var_as_name = Name_in_target_env.create (Name.var var) in
let existential_vars = Variable.Map.add var kind t.existential_vars in
- let pending_vars = Variable.Map.add var simples t.pending_vars in
+ let pending_vars =
+ Name_in_target_env.Map.add var_as_name simples t.pending_vars
+ in
Ok (Simple.var var), { t with existential_vars; join_aliases; pending_vars }
type env_id = Index.t
From 9262222832549ebe83b96031c380c23f50d8dfb9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 13 Feb 2025 13:27:53 +0100
Subject: [PATCH 04/12] Restrict types to available environments before joining
---
middle_end/flambda2/types/env/join_env.ml | 18 ++++++++++++++++--
1 file changed, 16 insertions(+), 2 deletions(-)
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
index d417cb1853f..c942ee126bf 100644
--- a/middle_end/flambda2/types/env/join_env.ml
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -149,6 +149,8 @@ module Simple_in_joined_envs : sig
val in_same_envs : t -> as_:t -> t
+ val in_envs : 'a Index.Map.t -> t -> t
+
val is_defined_in : Index.Set.t -> t -> bool
val raw_name : t -> string
@@ -206,6 +208,8 @@ end = struct
else Some simple_in_one_joined_env)
t
+ let in_envs envs t = Index.Map.inter (fun _ _ simple -> simple) envs t
+
let in_same_envs t ~as_ = Index.Map.inter (fun _ _ simple -> simple) as_ t
let is_defined_in envs t = Index.Set.subset envs (Index.Map.keys t)
@@ -1059,7 +1063,12 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
| Ok { demoted_in_target_env; demoted_in_some_envs; t = join_aliases } ->
let join_types =
Name_in_target_env.Map.fold
- (Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
+ (fun name_in_target_env canonicals ->
+ let canonicals =
+ Simple_in_joined_envs.in_envs all_levels canonicals
+ in
+ Join_equations.add_joined_simple ~joined_envs:t.joined_envs
+ name_in_target_env canonicals)
demoted_in_some_envs t.join_types
in
let { Join_aliases.values_in_target_env = join_types;
@@ -1110,7 +1119,12 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
else
let join_types =
Name_in_target_env.Map.fold
- (Join_equations.add_joined_simple ~joined_envs:t.joined_envs)
+ (fun name_in_target_env canonicals ->
+ let canonicals =
+ Simple_in_joined_envs.in_envs all_levels canonicals
+ in
+ Join_equations.add_joined_simple ~joined_envs:t.joined_envs
+ name_in_target_env canonicals)
t.pending_vars t.join_types
in
let equations_to_join =
From 8e078b5d0991a189b1d8781698e449aaef5184a4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 13 Feb 2025 13:29:52 +0100
Subject: [PATCH 05/12] Do not expose potential Not_found exceptions
---
middle_end/flambda2/types/env/join_env.ml | 19 +++++++++++--------
1 file changed, 11 insertions(+), 8 deletions(-)
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
index c942ee126bf..b516606ec80 100644
--- a/middle_end/flambda2/types/env/join_env.ml
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -77,6 +77,12 @@ end = struct
let succ n = n + 1
end
+let get_nth_joined_env index joined_envs =
+ match Index.Map.find_opt index env.joined_envs with
+ | Some typing_env -> typing_env
+ | None ->
+ Misc.fatal_error "Joined environment %a is not available." Index.print index
+
(* The following are intended to help make sure we don't confuse things (names,
simples) that are living in one of the joined environments and those that
live in the target environment.
@@ -905,7 +911,7 @@ module Join_equations = struct
let types_of_demoted_var =
Simple_in_joined_envs.fold
(fun index canonical types_of_demoted_var ->
- let env = Index.Map.find index joined_envs in
+ let env = get_nth_joined_env index joined_envs in
let canonical_simple = (canonical :> Simple.t) in
let ty =
Simple.pattern_match canonical_simple
@@ -935,7 +941,7 @@ let n_way_join_symbol_projections ~exists_in_target_env
let joined_projections =
Index.Map.fold
(fun index symbol_projections acc ->
- let typing_env = Index.Map.find index joined_envs in
+ let typing_env = get_nth_joined_env index joined_envs in
Variable.Map.fold
(fun var symbol_projection acc ->
let canonical =
@@ -1002,7 +1008,7 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
(all_demotions, all_expanded_equations, all_symbol_projections) ->
let symbol_projections = TEL.symbol_projections level in
let equations = TEL.equations level in
- let typing_env = Index.Map.find index t.joined_envs in
+ let typing_env = get_nth_joined_env index t.joined_envs in
let demotions, expanded_equations =
Name.Map.fold
(fun name ty (demotions, expanded_equations) ->
@@ -1202,7 +1208,7 @@ let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
let joined_levels, joined_envs =
List.fold_left
(fun (joined_levels, joined_envs) (index, extension) ->
- let parent_env = Index.Map.find index t.joined_envs in
+ let parent_env = get_nth_joined_env index t.joined_envs in
(* The extension is not guaranteed to still be in canonical form, but we
need the equations to be in canonical form to known which variables
are actually touched by the extension, so we add it once then cut it.
@@ -1306,7 +1312,4 @@ let target_join_env { target_env; _ } = target_env
type n_way_join_type = t -> TG.t join_arg list -> TG.t Or_unknown.t * t
-let joined_env env index =
- match Index.Map.find_opt index env.joined_envs with
- | Some typing_env -> typing_env
- | None -> Misc.fatal_error "Invalid joined environment."
+let joined_env env index = get_nth_joined_env index env.joined_envs
From 9c285d3b512b8bd8fe39f1edc8c3435b89c16169 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 13 Feb 2025 14:00:59 +0100
Subject: [PATCH 06/12] Typo
---
middle_end/flambda2/types/env/join_env.ml | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
index b516606ec80..4a1b1129c0f 100644
--- a/middle_end/flambda2/types/env/join_env.ml
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -78,10 +78,11 @@ end = struct
end
let get_nth_joined_env index joined_envs =
- match Index.Map.find_opt index env.joined_envs with
+ match Index.Map.find_opt index joined_envs with
| Some typing_env -> typing_env
| None ->
- Misc.fatal_error "Joined environment %a is not available." Index.print index
+ Misc.fatal_errorf "Joined environment %a is not available." Index.print
+ index
(* The following are intended to help make sure we don't confuse things (names,
simples) that are living in one of the joined environments and those that
From f559e8a4c39ac64e59e052b79e209b530dc20f25 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Fri, 14 Mar 2025 10:37:46 +0100
Subject: [PATCH 07/12] Review
---
middle_end/flambda2/types/env/join_env.ml | 142 ++++++++++++----------
1 file changed, 79 insertions(+), 63 deletions(-)
diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml
index 4a1b1129c0f..92b5f880acf 100644
--- a/middle_end/flambda2/types/env/join_env.ml
+++ b/middle_end/flambda2/types/env/join_env.ml
@@ -108,11 +108,14 @@ end
module Simple_in_target_env : sig
include module type of Thing_in_env (Simple) ()
- val name : Name_in_target_env.t -> t
+ val name : ?coercion:Coercion.t -> Name_in_target_env.t -> t
end = struct
include Thing_in_env (Simple) ()
- let name (name : Name_in_target_env.t) = create (Simple.name (name :> Name.t))
+ let name ?(coercion = Coercion.id) (name : Name_in_target_env.t) =
+ let simple_without_coercion = Simple.name (name :> Name.t) in
+ let simple = Simple.with_coercion simple_without_coercion coercion in
+ create simple
end
module Name_in_one_joined_env = struct
@@ -138,7 +141,7 @@ end = struct
~const
end
-module Simple_in_joined_envs : sig
+module Simples_in_joined_envs : sig
include
Container_types.S
with type t = private Simple_in_one_joined_env.t Index.Map.t
@@ -254,7 +257,7 @@ module Join_aliases : sig
val empty : t
- (** [find ~mem_name ~is_bound_strictly_earlier simples t] is:
+ (** [find ~exists_in_target_env ~is_bound_strictly_earlier simples t] is:
- [Bottom] if [simples] is empty;
- [Ok simple] if there is a [simple] that is equal to each of the [simples]
@@ -262,8 +265,8 @@ module Join_aliases : sig
introduced with [add_existential_var] for this set of [simples];
- [Unknown] otherwise.
- [mem_name] should return [true] if the name is defined in the target
- environment (false if it is a local variable of a joined environment).
+ [exists_in_target_env] converts a [Name_in_one_joined_env.t] into a
+ [Name_in_target_env.t] if the name exists in the target environment.
[is_bound_strictly_earlier] determines whether a {b shared} name (i.e.
defined in the target env and in all joined envs) is bound earlier than
@@ -276,7 +279,7 @@ module Join_aliases : sig
(Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
is_bound_strictly_earlier:
(Name_in_target_env.t -> than:Simple_in_target_env.t -> bool) ->
- Simple_in_joined_envs.t ->
+ Simples_in_joined_envs.t ->
t ->
Simple_in_target_env.t Or_unknown_or_bottom.t
@@ -285,11 +288,11 @@ module Join_aliases : sig
val add_existential_var :
exists_in_target_env:
(Name_in_one_joined_env.t -> Name_in_target_env.t option) ->
- Simple_in_joined_envs.t ->
+ Simples_in_joined_envs.t ->
t ->
Variable.t * t
- type 'a add_result =
+ type 'a add_result = private
{ values_in_target_env : 'a Index.Map.t Name_in_target_env.Map.t;
touched_variables : Name_in_target_env.Set.t
}
@@ -316,7 +319,7 @@ module Join_aliases : sig
join.
The demoted variables are no longer present in [t]. *)
- demoted_in_some_envs : Simple_in_joined_envs.t Name_in_target_env.Map.t;
+ demoted_in_some_envs : Simples_in_joined_envs.t Name_in_target_env.Map.t;
(** Variables that have been demoted in some (possibly all, if
they have been demoted to distinct canonicals) of the joined
environments, but not in the target enviroment.
@@ -336,14 +339,14 @@ module Join_aliases : sig
join_result Or_bottom.t
end = struct
type t =
- { joined_simples : Name_in_target_env.t Simple_in_joined_envs.Map.t;
+ { joined_simples : Name_in_target_env.t Simples_in_joined_envs.Map.t;
(** Maps a tuple of simples in the joined environments to the variable
that represents it in the target environment, if any.
If there is a mapping [simples -> var] in [joined_simples], then
[demoted_from_target_env(var) = simples]. *)
demoted_from_target_env :
- Simple_in_joined_envs.t Name_in_target_env.Map.t;
+ Simples_in_joined_envs.t Name_in_target_env.Map.t;
(** Maps a variable defined in the target environment to its
canonicals in each joined environment {b where it has been
demoted}.
@@ -364,21 +367,37 @@ end = struct
names_in_target_env :
Name_in_target_env.Set.t Name_in_one_joined_env.Map.t Index.Map.t
(** Maps a variable in a joined environment to the set of
- (other) variables it is equal to in the target environment. *)
+ (other) variables it is equal to in the target environment.
+
+ {b Note}: Although we use [Name_in_one_joined_env] and
+ [Name_in_target_env] here, we are only interested in {b
+ variables}; in particular, symbols are irrelevant (they are always
+ their own canonicals and can't be renamed during join). *)
}
let empty =
- { joined_simples = Simple_in_joined_envs.Map.empty;
+ { joined_simples = Simples_in_joined_envs.Map.empty;
demoted_from_target_env = Name_in_target_env.Map.empty;
names_in_target_env = Index.Map.empty
}
+ (* Accumulator type for computing the simple with latest binding time from a
+ set. *)
+ type latest_bound_simple =
+ | No_simple (** No [Simple.t] at all (bottom case). *)
+ | Only_local_simples
+ (** Non-empty, but only [Simple.t] that do not exist in the target
+ environment. *)
+ | Latest_bound of Simple_in_target_env.t
+ (** The [Simple.t] with the latest binding time amongst those that exist
+ in the target environment. *)
+
let find
~(exists_in_target_env :
Name_in_one_joined_env.t -> Name_in_target_env.t option)
~(is_bound_strictly_earlier :
Name_in_target_env.t -> than:Simple_in_target_env.t -> bool)
- (simples : Simple_in_joined_envs.t) t : _ Or_unknown_or_bottom.t =
+ (simples : Simples_in_joined_envs.t) t : _ Or_unknown_or_bottom.t =
let[@inline] simple_exists_in_target_env simple_in_one_joined_env =
Simple_in_one_joined_env.pattern_match simple_in_one_joined_env
~const:(fun const ->
@@ -387,11 +406,7 @@ end = struct
match exists_in_target_env name_in_one_joined_env with
| None -> None
| Some name_in_target_env ->
- Some
- (Simple_in_target_env.create
- (Simple.with_coercion
- (Simple.name (name_in_target_env :> Name.t))
- coercion)))
+ Some (Simple_in_target_env.name ~coercion name_in_target_env))
in
(* We need to determine if the provided set of simples (which are assumed to
be canonicals in their own environment) has an existing name in the
@@ -434,14 +449,14 @@ end = struct
defined in the target environment to combine tests for cases 1) and
2). *)
let latest_bound_simple =
- Simple_in_joined_envs.fold
- (fun _ simple acc : _ Or_unknown_or_bottom.t ->
- match (acc : _ Or_unknown_or_bottom.t) with
- | Bottom | Unknown -> (
+ Simples_in_joined_envs.fold
+ (fun _ simple acc ->
+ match acc with
+ | No_simple | Only_local_simples -> (
match simple_exists_in_target_env simple with
- | None -> Unknown
- | Some simple -> Ok simple)
- | Ok existing_simple -> (
+ | None -> Only_local_simples
+ | Some simple -> Latest_bound simple)
+ | Latest_bound existing_simple -> (
match Simple.must_be_var (simple :> Simple.t) with
| None -> acc
| Some (var, coercion) -> (
@@ -455,13 +470,13 @@ end = struct
if is_bound_strictly_earlier name_in_target_env
~than:existing_simple
then
- Ok
+ Latest_bound
(Simple_in_target_env.create
(Simple.with_coercion
(Simple.name (name_in_target_env :> Name.t))
coercion))
else acc)))
- simples Or_unknown_or_bottom.Bottom
+ simples No_simple
in
let[@local] find_local_variable () : _ Or_unknown_or_bottom.t =
(* When looking for an existential variable, we only look for exact
@@ -469,35 +484,35 @@ end = struct
This means that we might end up creating more local variables than
would be strictly necessary, but they have more precise types. *)
- match Simple_in_joined_envs.Map.find_opt simples t.joined_simples with
+ match Simples_in_joined_envs.Map.find_opt simples t.joined_simples with
| None -> Unknown
| Some name -> Ok (Simple_in_target_env.name name)
in
match latest_bound_simple with
- | Bottom -> Bottom
- | Unknown ->
+ | No_simple -> Bottom
+ | Only_local_simples ->
(* Join of existential variables can only be case 3) or 4) *)
find_local_variable ()
- | Ok latest_bound_simple -> (
+ | Latest_bound latest_bound_simple -> (
let earlier_bound_simples =
- Simple_in_joined_envs.distinct_from_simple_in_target_env simples
+ Simples_in_joined_envs.distinct_from_simple_in_target_env simples
latest_bound_simple
in
match Simple.must_be_name (latest_bound_simple :> Simple.t) with
| None ->
(* Case 1), 3), or 4) *)
- if Simple_in_joined_envs.is_empty earlier_bound_simples
+ if Simples_in_joined_envs.is_empty earlier_bound_simples
then Ok latest_bound_simple
else find_local_variable ()
| Some (name, coercion) ->
(* Case 2), 3), or 4) *)
let coercion_to_name = Coercion.inverse coercion in
let earlier_bound_simples =
- Simple_in_joined_envs.apply_coercion earlier_bound_simples
+ Simples_in_joined_envs.apply_coercion earlier_bound_simples
coercion_to_name
in
let canonicals_for_name =
- Option.value ~default:Simple_in_joined_envs.empty
+ Option.value ~default:Simples_in_joined_envs.empty
(Name_in_target_env.Map.find_opt
(Name_in_target_env.create name)
t.demoted_from_target_env)
@@ -521,14 +536,15 @@ end = struct
the target env and precision for existential variables (cf
[find_local_variable]). *)
let canonicals_for_name =
- Simple_in_joined_envs.in_same_envs ~as_:simples canonicals_for_name
+ Simples_in_joined_envs.in_same_envs ~as_:simples canonicals_for_name
in
- if Simple_in_joined_envs.equal earlier_bound_simples canonicals_for_name
+ if Simples_in_joined_envs.equal earlier_bound_simples
+ canonicals_for_name
then Ok latest_bound_simple
else find_local_variable ())
let add_existential_var ~exists_in_target_env simples t =
- (* We have encountered a [Simple_in_joined_envs.t] that does not cleanly
+ (* We have encountered a [Simples_in_joined_envs.t] that does not cleanly
correspond to the demotion of a name in the target env, e.g. we have type
"= a" on the left and "= b" on the right but no variable that is equal to
"a" on the left and "b" on the right yet.
@@ -536,17 +552,17 @@ end = struct
We now create a new existential variable for this pair of values, and
record it so that it can be found by [find] if we encounter the same set
of values later. *)
- let raw_name = Simple_in_joined_envs.raw_name simples in
+ let raw_name = Simples_in_joined_envs.raw_name simples in
let var = Variable.create raw_name in
let var_as_name = Name_in_target_env.create (Name.var var) in
let joined_simples =
- Simple_in_joined_envs.Map.add simples var_as_name t.joined_simples
+ Simples_in_joined_envs.Map.add simples var_as_name t.joined_simples
in
let demoted_from_target_env =
Name_in_target_env.Map.add var_as_name simples t.demoted_from_target_env
in
let names_in_target_env =
- Simple_in_joined_envs.fold
+ Simples_in_joined_envs.fold
(fun index simple names_in_target_env ->
match Simple.must_be_var (simple :> Simple.t) with
| Some (joined_var, coercion) when Coercion.is_id coercion -> (
@@ -603,7 +619,7 @@ end = struct
t.demoted_from_target_env
in
let names_in_target_env =
- Simple_in_joined_envs.fold
+ Simples_in_joined_envs.fold
(fun index simple names_in_target_env ->
match Simple.must_be_var (simple :> Simple.t) with
| Some (var, coercion) when Coercion.is_id coercion ->
@@ -654,7 +670,7 @@ end = struct
in the joined envs that are *distinct* from the name in the target env). *)
let apply_demotions ~exists_in_target_env t all_demotions =
Index.Map.fold
- (fun index values
+ (fun index demotions
(demoted_from_target_env, names_in_target_env, touched_vars) ->
let names_from_this_env_in_target_env =
Option.value ~default:Name_in_one_joined_env.Map.empty
@@ -716,23 +732,23 @@ end = struct
in
let demoted_from_target_env =
Name_in_target_env.Set.fold
- (fun var_in_target_env values ->
+ (fun var_in_target_env demoted_from_target_env ->
Name_in_target_env.Map.update var_in_target_env
(fun canonical_in_joined_envs ->
let canonical_in_joined_envs =
- Option.value ~default:Simple_in_joined_envs.empty
+ Option.value ~default:Simples_in_joined_envs.empty
canonical_in_joined_envs
in
Some
- (Simple_in_joined_envs.add index
+ (Simples_in_joined_envs.add index
canonical_in_joined_env canonical_in_joined_envs))
- values)
+ demoted_from_target_env)
vars_in_target_env demoted_from_target_env
in
( demoted_from_target_env,
names_from_this_env_in_target_env,
Name_in_target_env.Set.union vars_in_target_env touched_vars ))
- values
+ demotions
( demoted_from_target_env,
names_from_this_env_in_target_env,
touched_vars )
@@ -804,7 +820,7 @@ end = struct
type join_result =
{ demoted_in_target_env : Simple_in_target_env.t Name_in_target_env.Map.t;
- demoted_in_some_envs : Simple_in_joined_envs.t Name_in_target_env.Map.t;
+ demoted_in_some_envs : Simples_in_joined_envs.t Name_in_target_env.Map.t;
t : t
}
@@ -827,7 +843,7 @@ end = struct
in
let[@local] is_demoted_in_all_envs t =
let joined_simples =
- Simple_in_joined_envs.Map.add canonicals demoted_var
+ Simples_in_joined_envs.Map.add canonicals demoted_var
t.joined_simples
in
is_demoted_in_some_envs { t with joined_simples }
@@ -846,7 +862,7 @@ end = struct
environments.
This can only happen in the presence of env extensions. *)
- if not (Simple_in_joined_envs.is_defined_in all_indices canonicals)
+ if not (Simples_in_joined_envs.is_defined_in all_indices canonicals)
then is_demoted_in_some_envs t
else
match
@@ -910,7 +926,7 @@ module Join_equations = struct
Option.value ~default:Index.Map.empty types_of_demoted_var
in
let types_of_demoted_var =
- Simple_in_joined_envs.fold
+ Simples_in_joined_envs.fold
(fun index canonical types_of_demoted_var ->
let env = get_nth_joined_env index joined_envs in
let canonical_simple = (canonical :> Simple.t) in
@@ -954,10 +970,10 @@ let n_way_join_symbol_projections ~exists_in_target_env
(fun joined_projections ->
let joined_projections =
Option.value joined_projections
- ~default:Simple_in_joined_envs.empty
+ ~default:Simples_in_joined_envs.empty
in
Some
- (Simple_in_joined_envs.add index canonical joined_projections))
+ (Simples_in_joined_envs.add index canonical joined_projections))
acc)
symbol_projections acc)
all_symbol_projections Symbol_projection.Map.empty
@@ -965,7 +981,7 @@ let n_way_join_symbol_projections ~exists_in_target_env
let all_indices = Index.Map.keys joined_envs in
Symbol_projection.Map.fold
(fun symbol_projection simples symbol_projections ->
- if not (Simple_in_joined_envs.is_defined_in all_indices simples)
+ if not (Simples_in_joined_envs.is_defined_in all_indices simples)
then symbol_projections
else
match
@@ -984,7 +1000,7 @@ type t =
{ join_aliases : Join_aliases.t;
join_types : Join_equations.t;
existential_vars : K.t Variable.Map.t;
- pending_vars : Simple_in_joined_envs.t Name_in_target_env.Map.t;
+ pending_vars : Simples_in_joined_envs.t Name_in_target_env.Map.t;
(* Existential variables that have been defined by their names in all the
joined environment, but whose type has not yet been computed. *)
joined_envs : TE.t Index.Map.t;
@@ -1070,12 +1086,12 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
| Ok { demoted_in_target_env; demoted_in_some_envs; t = join_aliases } ->
let join_types =
Name_in_target_env.Map.fold
- (fun name_in_target_env canonicals ->
+ (fun name_in_target_env canonicals join_types ->
let canonicals =
- Simple_in_joined_envs.in_envs all_levels canonicals
+ Simples_in_joined_envs.in_envs all_levels canonicals
in
Join_equations.add_joined_simple ~joined_envs:t.joined_envs
- name_in_target_env canonicals)
+ name_in_target_env canonicals join_types)
demoted_in_some_envs t.join_types
in
let { Join_aliases.values_in_target_env = join_types;
@@ -1128,7 +1144,7 @@ let n_way_join_levels ~n_way_join_type t all_levels : _ Or_bottom.t =
Name_in_target_env.Map.fold
(fun name_in_target_env canonicals ->
let canonicals =
- Simple_in_joined_envs.in_envs all_levels canonicals
+ Simples_in_joined_envs.in_envs all_levels canonicals
in
Join_equations.add_joined_simple ~joined_envs:t.joined_envs
name_in_target_env canonicals)
@@ -1274,7 +1290,7 @@ let n_way_join_env_extension ~n_way_join_type ~meet_type t envs_with_extensions
Or_bottom.Ok (TEE.from_map joined_equations, { t with existential_vars })
let n_way_join_simples t kind simples : _ Or_bottom.t * _ =
- let simples = Simple_in_joined_envs.of_list simples in
+ let simples = Simples_in_joined_envs.of_list simples in
let target_env = t.target_env in
let exists_in_target_env (name : Name_in_one_joined_env.t) =
if TE.mem ~min_name_mode:Name_mode.in_types target_env (name :> Name.t)
From 60658f27bfc09ed6fa299777f08483bb24e58e46 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Fri, 14 Mar 2025 13:28:59 +0100
Subject: [PATCH 08/12] Add flambda2-join-algorithm flag
---
driver/flambda_backend_args.ml | 27 +++++
driver/flambda_backend_args.mli | 1 +
driver/flambda_backend_flags.ml | 5 +
driver/flambda_backend_flags.mli | 4 +
middle_end/flambda2/types/flambda2_types.ml | 17 ++-
middle_end/flambda2/types/join_levels.ml | 120 ++++++++++----------
middle_end/flambda2/types/meet.ml | 29 +++++
middle_end/flambda2/types/meet.mli | 28 +++++
middle_end/flambda2/ui/flambda_features.ml | 16 +++
middle_end/flambda2/ui/flambda_features.mli | 9 ++
10 files changed, 188 insertions(+), 68 deletions(-)
create mode 100644 middle_end/flambda2/types/meet.ml
create mode 100644 middle_end/flambda2/types/meet.mli
diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml
index 9fb199fb33b..088dc52359d 100644
--- a/driver/flambda_backend_args.ml
+++ b/driver/flambda_backend_args.ml
@@ -268,6 +268,15 @@ let mk_flambda2_advanced_meet f =
Printf.sprintf " Use an advanced meet algorithm (deprecated) (Flambda 2 only)"
;;
+let mk_flambda2_join_algorithm f =
+ "-flambda2-join-algorithm", Arg.Symbol (["binary"; "n-way"; "checked"], f),
+ Printf.sprintf " Select the join algorithm to use (Flambda 2 only)\n \
+ \ Valid values are: \n\
+ \ \"binary\" is the legacy binary join;\n\
+ \ \"n-way\" is the new n-way join;\n\
+ \ \"checked\" runs both algorithms and compares them (use for \
+ debugging)."
+;;
let mk_flambda2_join_points f =
"-flambda2-join-points", Arg.Unit f,
@@ -777,6 +786,7 @@ module type Flambda_backend_options = sig
val no_flambda2_result_types : unit -> unit
val flambda2_basic_meet : unit -> unit
val flambda2_advanced_meet : unit -> unit
+ val flambda2_join_algorithm : string -> unit
val flambda2_unbox_along_intra_function_control_flow : unit -> unit
val no_flambda2_unbox_along_intra_function_control_flow : unit -> unit
val flambda2_backend_cse_at_toplevel : unit -> unit
@@ -916,6 +926,7 @@ struct
F.no_flambda2_result_types;
mk_flambda2_basic_meet F.flambda2_basic_meet;
mk_flambda2_advanced_meet F.flambda2_advanced_meet;
+ mk_flambda2_join_algorithm F.flambda2_join_algorithm;
mk_flambda2_unbox_along_intra_function_control_flow
F.flambda2_unbox_along_intra_function_control_flow;
mk_no_flambda2_unbox_along_intra_function_control_flow
@@ -1126,6 +1137,15 @@ module Flambda_backend_options_impl = struct
Flambda2.function_result_types := Flambda_backend_flags.Set Flambda_backend_flags.Never
let flambda2_basic_meet () = ()
let flambda2_advanced_meet () = ()
+ let flambda2_join_algorithm algorithm =
+ match algorithm with
+ | "binary" ->
+ Flambda2.join_algorithm := Flambda_backend_flags.Set Flambda_backend_flags.Binary
+ | "n-way" ->
+ Flambda2.join_algorithm := Flambda_backend_flags.Set Flambda_backend_flags.N_way
+ | "checked" ->
+ Flambda2.join_algorithm := Flambda_backend_flags.Set Flambda_backend_flags.Checked
+ | _ -> () (* This should not occur as we use Arg.Symbol *)
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 =
@@ -1456,6 +1476,13 @@ module Extra_params = struct
| _ ->
Misc.fatal_error "Syntax: flambda2-meet_algorithm=basic|advanced");
true
+ | "flambda2-join-algorithm" ->
+ (match String.lowercase_ascii v with
+ | "binary" | "n-way" | "checked" as v ->
+ Flambda_backend_options_impl.flambda2_join_algorithm v
+ | _ ->
+ Misc.fatal_error "Syntax: flambda2-join-algorithm=binary|n-way|checked");
+ true
| "flambda2-unbox-along-intra-function-control-flow" ->
set Flambda2.unbox_along_intra_function_control_flow
| "flambda2-backend-cse-at-toplevel" ->
diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli
index df351862c8d..867d1100538 100644
--- a/driver/flambda_backend_args.mli
+++ b/driver/flambda_backend_args.mli
@@ -91,6 +91,7 @@ module type Flambda_backend_options = sig
val no_flambda2_result_types : unit -> unit
val flambda2_basic_meet : unit -> unit
val flambda2_advanced_meet : unit -> unit
+ val flambda2_join_algorithm : string -> unit
val flambda2_unbox_along_intra_function_control_flow : unit -> unit
val no_flambda2_unbox_along_intra_function_control_flow : unit -> unit
val flambda2_backend_cse_at_toplevel : unit -> unit
diff --git a/driver/flambda_backend_flags.ml b/driver/flambda_backend_flags.ml
index 222874057f2..cf1acd79f68 100644
--- a/driver/flambda_backend_flags.ml
+++ b/driver/flambda_backend_flags.ml
@@ -96,6 +96,7 @@ 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 join_algorithm = Binary | N_way | Checked
type opt_level = Oclassic | O2 | O3
type 'a or_default = Set of 'a | Default
@@ -128,6 +129,7 @@ module Flambda2 = struct
let backend_cse_at_toplevel = false
let cse_depth = 2
let join_depth = 5
+ let join_algorithm = Binary
let function_result_types = Never
let enable_reaper = false
let unicode = true
@@ -141,6 +143,7 @@ module Flambda2 = struct
backend_cse_at_toplevel : bool;
cse_depth : int;
join_depth : int;
+ join_algorithm : join_algorithm;
function_result_types : function_result_types;
enable_reaper : bool;
unicode : bool;
@@ -154,6 +157,7 @@ module Flambda2 = struct
backend_cse_at_toplevel = Default.backend_cse_at_toplevel;
cse_depth = Default.cse_depth;
join_depth = Default.join_depth;
+ join_algorithm = Default.join_algorithm;
function_result_types = Default.function_result_types;
enable_reaper = Default.enable_reaper;
unicode = Default.unicode;
@@ -187,6 +191,7 @@ module Flambda2 = struct
let backend_cse_at_toplevel = ref Default
let cse_depth = ref Default
let join_depth = ref Default
+ let join_algorithm = ref Default
let unicode = ref Default
let kind_checks = ref Default
let function_result_types = ref Default
diff --git a/driver/flambda_backend_flags.mli b/driver/flambda_backend_flags.mli
index 170b8597129..a16861dc49b 100644
--- a/driver/flambda_backend_flags.mli
+++ b/driver/flambda_backend_flags.mli
@@ -83,6 +83,7 @@ val long_frames_threshold : int ref
val caml_apply_inline_fast_path : bool ref
type function_result_types = Never | Functors_only | All_functions
+type join_algorithm = Binary | N_way | Checked
type opt_level = Oclassic | O2 | O3
type 'a or_default = Set of 'a | Default
@@ -109,6 +110,7 @@ module Flambda2 : sig
val backend_cse_at_toplevel : bool
val cse_depth : int
val join_depth : int
+ val join_algorithm : join_algorithm
val function_result_types : function_result_types
val enable_reaper : bool
val unicode : bool
@@ -125,6 +127,7 @@ module Flambda2 : sig
backend_cse_at_toplevel : bool;
cse_depth : int;
join_depth : int;
+ join_algorithm : join_algorithm;
function_result_types : function_result_types;
enable_reaper : bool;
unicode : bool;
@@ -141,6 +144,7 @@ module Flambda2 : sig
val backend_cse_at_toplevel : bool or_default ref
val cse_depth : int or_default ref
val join_depth : int or_default ref
+ val join_algorithm : join_algorithm or_default ref
val enable_reaper : bool or_default ref
val unicode : bool or_default ref
val kind_checks : bool or_default ref
diff --git a/middle_end/flambda2/types/flambda2_types.ml b/middle_end/flambda2/types/flambda2_types.ml
index c6243a5f09a..40fcc6b8152 100644
--- a/middle_end/flambda2/types/flambda2_types.ml
+++ b/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.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.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.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.meet_type ())
module Alias_set = Aliases.Alias_set
end
@@ -43,7 +43,7 @@ type typing_env_extension = Typing_env_extension.t
include Type_grammar
include More_type_creators
include Expand_head
-include Meet_and_join
+include Meet
include Provers
include Reify
include Join_levels
@@ -54,10 +54,9 @@ let remove_outermost_alias env ty =
module Equal_types_for_debug = struct
let equal_type env t1 t2 =
- Equal_types_for_debug.equal_type ~meet_type:Meet_and_join.meet_type env t1
- t2
+ Equal_types_for_debug.equal_type ~meet_type:(Meet.meet_type ()) env t1 t2
let equal_env_extension env ext1 ext2 =
- Equal_types_for_debug.equal_env_extension ~meet_type:Meet_and_join.meet_type
- env ext1 ext2
+ Equal_types_for_debug.equal_env_extension ~meet_type:(Meet.meet_type ()) env
+ ext1 ext2
end
diff --git a/middle_end/flambda2/types/join_levels.ml b/middle_end/flambda2/types/join_levels.ml
index e1a6139c1b7..7560997a292 100644
--- a/middle_end/flambda2/types/join_levels.ml
+++ b/middle_end/flambda2/types/join_levels.ml
@@ -44,7 +44,7 @@ let check_join_inputs ~env_at_fork _envs_with_levels ~params
extra_lifted_consts_in_use_envs
let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
- ~extra_lifted_consts_in_use_envs ~extra_allowed_names:_ =
+ ~extra_lifted_consts_in_use_envs =
let params = Bound_parameters.to_list params in
check_join_inputs ~env_at_fork:definition_typing_env ts_and_use_ids ~params
~extra_lifted_consts_in_use_envs;
@@ -53,61 +53,63 @@ let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
~n_way_join_type:Meet_and_n_way_join.n_way_join definition_typing_env
~cut_after ts
-let ignore_names =
- String.split_on_char ','
- (Option.value ~default:""
- (Sys.getenv_opt "FLAMBDA2_JOIN_DEBUG_IGNORE_NAMES"))
-
-let cut_and_n_way_join_checked definition_typing_env ts_and_use_ids ~params
- ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
- let scope = TE.current_scope definition_typing_env in
- let typing_env = TE.increment_scope definition_typing_env in
- let old_joined_env =
- Join_levels_old.cut_and_n_way_join typing_env ts_and_use_ids ~params
- ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names
- in
- let old_joined_level = TE.cut old_joined_env ~cut_after:scope in
- let new_joined_env =
- cut_and_n_way_join typing_env ts_and_use_ids ~params ~cut_after
- ~extra_lifted_consts_in_use_envs ~extra_allowed_names
- in
- let new_joined_level = TE.cut new_joined_env ~cut_after:scope in
- (let distinct_names =
- Equal_types_for_debug.names_with_non_equal_types_level_ignoring_name_mode
- ~meet_type:Meet_and_join.meet_type typing_env old_joined_level
- new_joined_level
- in
- let distinct_names =
- Name.Set.filter
- (fun name ->
- match Name.must_be_var_opt name with
- | Some var ->
- let raw_name = Variable.raw_name var in
- not (List.exists (String.equal raw_name) ignore_names)
- | None -> true)
- distinct_names
- in
- if not (Name.Set.is_empty distinct_names)
- then (
- Format.eprintf "@[<v 1>%s Distinct joins %s@ " (String.make 22 '=')
- (String.make 22 '=');
- if Flambda_features.debug_flambda2 ()
- then
- List.iteri
- (fun i (t, _, _) ->
- let level = TE.cut t ~cut_after in
- Format.eprintf "@[<v 1>-- Level %d --@ %a@]@ " i TEL.print level)
- ts_and_use_ids;
- Format.eprintf "@[<v 1>-- Old join --@ %a@]@ " TEL.print old_joined_level;
- Format.eprintf "@[<v 1>-- New join --@ %a@]@ " TEL.print new_joined_level;
- Format.eprintf "@[Names with distinct types:@ %a@]" Name.Set.print
- distinct_names;
- Format.eprintf "@]@\n%s@." (String.make 60 '=')));
- TE.add_env_extension_from_level definition_typing_env new_joined_level
- ~meet_type:Meet_and_join.meet_type
-
-let cut_and_n_way_join =
- match Sys.getenv "FLAMBDA2_JOIN_ALGORITHM" with
- | "old" -> Join_levels_old.cut_and_n_way_join
- | "checked" -> cut_and_n_way_join_checked
- | _ | (exception Not_found) -> cut_and_n_way_join
+let cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
+ ~extra_lifted_consts_in_use_envs ~extra_allowed_names =
+ match Flambda_features.join_algorithm () with
+ | Binary ->
+ Join_levels_old.cut_and_n_way_join definition_typing_env ts_and_use_ids
+ ~params ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names
+ | N_way ->
+ cut_and_n_way_join definition_typing_env ts_and_use_ids ~params ~cut_after
+ ~extra_lifted_consts_in_use_envs
+ | Checked ->
+ let ignore_names =
+ String.split_on_char ','
+ (Option.value ~default:""
+ (Sys.getenv_opt "FLAMBDA2_JOIN_DEBUG_IGNORE_NAMES"))
+ in
+ let scope = TE.current_scope definition_typing_env in
+ let typing_env = TE.increment_scope definition_typing_env in
+ let old_joined_env =
+ Join_levels_old.cut_and_n_way_join typing_env ts_and_use_ids ~params
+ ~cut_after ~extra_lifted_consts_in_use_envs ~extra_allowed_names
+ in
+ let old_joined_level = TE.cut old_joined_env ~cut_after:scope in
+ let new_joined_env =
+ cut_and_n_way_join typing_env ts_and_use_ids ~params ~cut_after
+ ~extra_lifted_consts_in_use_envs
+ in
+ let new_joined_level = TE.cut new_joined_env ~cut_after:scope in
+ (let distinct_names =
+ Equal_types_for_debug.names_with_non_equal_types_level_ignoring_name_mode
+ ~meet_type:(Meet.meet_type ()) typing_env old_joined_level
+ new_joined_level
+ in
+ let distinct_names =
+ Name.Set.filter
+ (fun name ->
+ match Name.must_be_var_opt name with
+ | Some var ->
+ let raw_name = Variable.raw_name var in
+ not (List.exists (String.equal raw_name) ignore_names)
+ | None -> true)
+ distinct_names
+ in
+ if not (Name.Set.is_empty distinct_names)
+ then (
+ Format.eprintf "@[<v 1>%s Distinct joins %s@ " (String.make 22 '=')
+ (String.make 22 '=');
+ if Flambda_features.debug_flambda2 ()
+ then
+ List.iteri
+ (fun i (t, _, _) ->
+ let level = TE.cut t ~cut_after in
+ Format.eprintf "@[<v 1>-- Level %d --@ %a@]@ " i TEL.print level)
+ ts_and_use_ids;
+ Format.eprintf "@[<v 1>-- Old join --@ %a@]@ " TEL.print old_joined_level;
+ Format.eprintf "@[<v 1>-- New join --@ %a@]@ " TEL.print new_joined_level;
+ Format.eprintf "@[Names with distinct types:@ %a@]" Name.Set.print
+ distinct_names;
+ Format.eprintf "@]@\n%s@." (String.make 60 '=')));
+ TE.add_env_extension_from_level definition_typing_env new_joined_level
+ ~meet_type:(Meet.meet_type ())
diff --git a/middle_end/flambda2/types/meet.ml b/middle_end/flambda2/types/meet.ml
new file mode 100644
index 00000000000..a92e8abcbb9
--- /dev/null
+++ b/middle_end/flambda2/types/meet.ml
@@ -0,0 +1,29 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Vincent Laviron, OCamlPro *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2024 OCamlPro SAS *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+let meet env t1 t2 =
+ if Flambda_features.use_n_way_join ()
+ then Meet_and_n_way_join.meet env t1 t2
+ else Meet_and_join.meet env t1 t2
+
+let[@inline] meet_type () =
+ if Flambda_features.use_n_way_join ()
+ then Meet_and_n_way_join.meet_type
+ else Meet_and_join.meet_type
+
+let meet_shape env t ~shape =
+ if Flambda_features.use_n_way_join ()
+ then Meet_and_n_way_join.meet_shape env t ~shape
+ else Meet_and_join.meet_shape env t ~shape
diff --git a/middle_end/flambda2/types/meet.mli b/middle_end/flambda2/types/meet.mli
new file mode 100644
index 00000000000..cf7c373920b
--- /dev/null
+++ b/middle_end/flambda2/types/meet.mli
@@ -0,0 +1,28 @@
+(**************************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Vincent Laviron, OCamlPro *)
+(* Basile Clément, OCamlPro *)
+(* *)
+(* Copyright 2024 OCamlPro SAS *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+val meet :
+ Typing_env.t ->
+ Type_grammar.t ->
+ Type_grammar.t ->
+ (Type_grammar.t * Typing_env.t) Or_bottom.t
+
+val meet_type : unit -> Typing_env.meet_type
+
+val meet_shape :
+ Typing_env.t ->
+ Type_grammar.t ->
+ shape:Type_grammar.t ->
+ Typing_env.t Or_bottom.t
diff --git a/middle_end/flambda2/ui/flambda_features.ml b/middle_end/flambda2/ui/flambda_features.ml
index 6de2d216a61..0db0b6e54d9 100644
--- a/middle_end/flambda2/ui/flambda_features.ml
+++ b/middle_end/flambda2/ui/flambda_features.ml
@@ -57,6 +57,22 @@ let join_depth () =
!Flambda_backend_flags.Flambda2.join_depth
|> with_default ~f:(fun d -> d.join_depth)
+type join_algorithm = Flambda_backend_flags.join_algorithm =
+ | Binary
+ | N_way
+ | Checked
+
+let join_algorithm () =
+ !Flambda_backend_flags.Flambda2.join_algorithm
+ |> with_default ~f:(fun d -> d.join_algorithm)
+
+let use_n_way_join () =
+ match join_algorithm () with
+ | Binary | Checked ->
+ (* In checked mode, this only impacts [join] when called from [meet]. *)
+ false
+ | N_way -> true
+
let enable_reaper () =
!Flambda_backend_flags.Flambda2.enable_reaper
|> with_default ~f:(fun d -> d.enable_reaper)
diff --git a/middle_end/flambda2/ui/flambda_features.mli b/middle_end/flambda2/ui/flambda_features.mli
index 418b04d7f64..e88a2e8c3b9 100644
--- a/middle_end/flambda2/ui/flambda_features.mli
+++ b/middle_end/flambda2/ui/flambda_features.mli
@@ -36,6 +36,15 @@ val cse_depth : unit -> int
val join_depth : unit -> int
+val use_n_way_join : unit -> bool
+
+type join_algorithm = Flambda_backend_flags.join_algorithm =
+ | Binary
+ | N_way
+ | Checked
+
+val join_algorithm : unit -> join_algorithm
+
val enable_reaper : unit -> bool
val kind_checks : unit -> bool
From 0d8ee036db7c2a9afd21fcc69bbf9c26868f79de Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Mon, 24 Mar 2025 17:25:10 +0100
Subject: [PATCH 09/12] Test the new join on CI
---
.github/workflows/build.yml | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 171f2db88db..4ad9c8023c5 100644
--- a/.github/workflows/build.yml
+++ b/.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-expert-cont-lifting-budget=200'
+ ocamlparam: '_,O3=1,flambda2-expert-cont-lifting-budget=200,flambda2-join-algorithm=n-way'
- 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-expert-cont-lifting-budget=200,cfg-invariants=1,cfg-eliminate-dead-trap-handlers=1'
+ ocamlparam: '_,O3=1,flambda2-expert-cont-lifting-budget=200,cfg-invariants=1,cfg-eliminate-dead-trap-handlers=1,flambda2-join-algorithm=n-way'
- name: flambda2_frame_pointers_oclassic_polling
config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion --enable-flambda-invariants
From 2ef424497679526cd9f9ffcf59c6dbce1c29d0ec Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 10 Apr 2025 16:33:04 +0200
Subject: [PATCH 10/12] Clarify comment
---
middle_end/flambda2/types/meet_and_n_way_join.ml | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml
index da83b9cd047..6a50a1dd9fb 100644
--- a/middle_end/flambda2/types/meet_and_n_way_join.ml
+++ b/middle_end/flambda2/types/meet_and_n_way_join.ml
@@ -356,8 +356,10 @@ let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type ~n_way_join
in
let when_a_level = TE.cut env_a ~cut_after:join_scope in
let when_b_level = TE.cut env_b ~cut_after:join_scope in
- (* Either [meet_a] or [meet_b] could have introduced new variables, which
- need to be added to the result environment. *)
+ (* New variables introduced by either [meet_a] or [meet_b] are not
+ guaranteed to end up in the [result_env] (in fact, they will probably
+ get renamed), but they can still appear in [a_result] and [b_result],
+ so we need to add them back. *)
let result_env = add_defined_vars result_env when_a_level in
let result_env = add_defined_vars result_env when_b_level in
let extensions =
From b514bdc937b5d3ee70f7d28ad6f4f70e21f65abf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Thu, 10 Apr 2025 17:14:31 +0200
Subject: [PATCH 11/12] ocamlformat
---
middle_end/flambda2/types/meet_and_n_way_join.ml | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml
index 6a50a1dd9fb..6dd9b8f25e4 100644
--- a/middle_end/flambda2/types/meet_and_n_way_join.ml
+++ b/middle_end/flambda2/types/meet_and_n_way_join.ml
@@ -357,9 +357,9 @@ let meet_disjunction ~meet_a ~meet_b ~bottom_a ~bottom_b ~meet_type ~n_way_join
let when_a_level = TE.cut env_a ~cut_after:join_scope in
let when_b_level = TE.cut env_b ~cut_after:join_scope in
(* New variables introduced by either [meet_a] or [meet_b] are not
- guaranteed to end up in the [result_env] (in fact, they will probably
- get renamed), but they can still appear in [a_result] and [b_result],
- so we need to add them back. *)
+ guaranteed to end up in the [result_env] (in fact, they will probably get
+ renamed), but they can still appear in [a_result] and [b_result], so we
+ need to add them back. *)
let result_env = add_defined_vars result_env when_a_level in
let result_env = add_defined_vars result_env when_b_level in
let extensions =
From eef1fb5297b1d409453e9f3284bdfd1e1b896712 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Basile=20Cl=C3=A9ment?= <basile.clement@ocamlpro.com>
Date: Fri, 11 Apr 2025 10:08:06 +0200
Subject: [PATCH 12/12] Rename let>+ to let>>+
---
.../flambda2/types/meet_and_n_way_join.ml | 44 +++++++++----------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml
index 6dd9b8f25e4..35dc21365e9 100644
--- a/middle_end/flambda2/types/meet_and_n_way_join.ml
+++ b/middle_end/flambda2/types/meet_and_n_way_join.ml
@@ -44,7 +44,7 @@ type 'a n_way_join_result = 'a Or_unknown.t * Join_env.t
let map_join_result ~f (v, env) = Or_unknown.map ~f v, env
-let ( let>+ ) x f = map_join_result ~f x
+let ( let>>+ ) x f = map_join_result ~f x
let add_equation (simple : Simple.t) ty_of_simple env ~meet_type :
unit meet_result =
@@ -1698,7 +1698,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Value head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_value env ((id1, head1) :: heads)
in
ET.create_value head
@@ -1709,7 +1709,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_immediate head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_immediate env ((id1, head1) :: heads)
in
ET.create_naked_immediate head
@@ -1720,7 +1720,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_float32 head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_float32 env (head1, id1) heads
in
ET.create_naked_float32 head
@@ -1731,7 +1731,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_float head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_float env (head1, id1) heads
in
ET.create_naked_float head
@@ -1742,7 +1742,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_int32 head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_int32 env (head1, id1) heads
in
ET.create_naked_int32 head
@@ -1753,7 +1753,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_int64 head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_int64 env (head1, id1) heads
in
ET.create_naked_int64 head
@@ -1764,7 +1764,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_nativeint head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_nativeint env (head1, id1) heads
in
ET.create_naked_nativeint head
@@ -1775,7 +1775,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Naked_vec128 head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_naked_vec128 env (head1, id1) heads
in
ET.create_naked_vec128 head
@@ -1786,7 +1786,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Rec_info head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_rec_info env (head1, id1) heads
in
ET.create_rec_info head
@@ -1797,7 +1797,7 @@ and n_way_join_expanded_head env kind (expandeds : ET.t Join_env.join_arg list)
| Region head -> head | _ -> assert false)
expandeds
in
- let>+ head =
+ let>>+ head =
n_way_join_head_of_kind_region env (head1, id1) heads
in
ET.create_region head
@@ -1885,7 +1885,7 @@ and n_way_join_head_of_kind_value_non_null env
[first_id, extensions],
is_unique )
in
- let>+ blocks, immediates, extensions =
+ let>>+ blocks, immediates, extensions =
n_way_join_variant env ~blocks ~imms ~extensions
in
TG.Head_of_kind_value_non_null.create_variant ~is_unique ~blocks
@@ -1918,7 +1918,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_float32 n alloc_mode
| Boxed_float (n, alloc_mode) ->
let ns, alloc_mode =
@@ -1934,7 +1934,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_float n alloc_mode
| Boxed_int32 (n, alloc_mode) ->
let ns, alloc_mode =
@@ -1950,7 +1950,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_int32 n alloc_mode
| Boxed_int64 (n, alloc_mode) ->
let ns, alloc_mode =
@@ -1966,7 +1966,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_int64 n alloc_mode
| Boxed_nativeint (n, alloc_mode) ->
let ns, alloc_mode =
@@ -1982,7 +1982,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_nativeint n alloc_mode
| Boxed_vec128 (n, alloc_mode) ->
let ns, alloc_mode =
@@ -1998,7 +1998,7 @@ and n_way_join_head_of_kind_value_non_null env
other_heads
([first_id, n], alloc_mode)
in
- let>+ n = n_way_join env ns in
+ let>>+ n = n_way_join env ns in
TG.Head_of_kind_value_non_null.create_boxed_vec128 n alloc_mode
| Closures { by_function_slot; alloc_mode } ->
let function_slots, alloc_mode =
@@ -2061,7 +2061,7 @@ and n_way_join_head_of_kind_value_non_null env
n_way_join_array_contents env contents
~joined_element_kind:element_kind
in
- let>+ length = n_way_join env lengths in
+ let>>+ length = n_way_join env lengths in
TG.Head_of_kind_value_non_null.create_array_with_contents ~element_kind
~length contents alloc_mode
with Unknown_result -> Unknown, env)
@@ -2183,13 +2183,13 @@ and n_way_join_head_of_kind_naked_immediate env
| Bottom ->
Misc.fatal_error "Did not expect [Bottom] from [create_naked_immediates]")
| _ :: _, [], [] when I.Set.is_empty immediates ->
- let>+ ty = n_way_join env is_int in
+ let>>+ ty = n_way_join env is_int in
TG.Head_of_kind_naked_immediate.create_is_int ty
| [], _ :: _, [] when I.Set.is_empty immediates ->
- let>+ ty = n_way_join env get_tag in
+ let>>+ ty = n_way_join env get_tag in
TG.Head_of_kind_naked_immediate.create_get_tag ty
| [], [], _ :: _ when I.Set.is_empty immediates ->
- let>+ ty = n_way_join env is_null in
+ let>>+ ty = n_way_join env is_null in
TG.Head_of_kind_naked_immediate.create_is_null ty
(* From now on: Irregular cases *)
(* CR vlaviron: There could be improvements based on reduction (trying to