diff --git a/middle_end/flambda/types/env/aliases.ml b/middle_end/flambda/types/env/aliases.ml
index c0621a330afc..a11c5c75a6a2 100644
--- a/middle_end/flambda/types/env/aliases.ml
+++ b/middle_end/flambda/types/env/aliases.ml
@@ -19,163 +19,288 @@ module Aliases_of_canonical_element : sig
 
   val print : Format.formatter -> t -> unit
 
-  val invariant : t -> unit
+  val invariant
+     : t
+    -> binding_times_and_modes:(Binding_time.With_name_mode.t Simple.Map.t)
+    -> unit
 
   val empty : t
-  val is_empty : t -> bool
 
-  val add : t -> Simple.t -> Name_mode.t -> t
+  val add : t -> Simple.t -> Binding_time.With_name_mode.t -> t
 
-  val find_earliest_candidates
+  val earliest_alias_exn
      : t
-    -> min_name_mode:Name_mode.t
-    -> Simple.Set.t option
+    -> min_name_mode:Name_mode.t option
+    -> Simple.t
 
   val all : t -> Simple.Set.t
 
   val mem : t -> Simple.t -> bool
 
   val union : t -> t -> t
-  val inter : t -> t -> t
 
-  val rename : (Simple.t -> Simple.t) -> t -> t
+  val disjoint : t -> t -> bool
 
-  val merge : t -> t -> t
+  val rename : (Simple.t -> Simple.t) -> t -> t
 
   val move_variables_to_mode_in_types : t -> t
 end = struct
+  module Earliest_alias : sig
+    type t =
+      | Earliest of {
+          (* Calling this "name" because it's factually always a name, and it's
+             about to become a Name.t anyway *)
+          name : Simple.t;
+          binding_time : Binding_time.t;
+        }
+      | No_alias
+
+    val exists : t -> bool
+    val update : t -> Simple.t -> Binding_time.t -> t
+    val union : t -> t -> t
+    val map_name : t -> f:(Simple.t -> Simple.t) -> t
+    val print : Format.formatter -> t -> unit
+  end = struct
+    type t =
+      | Earliest of {
+          name : Simple.t;
+          binding_time : Binding_time.t;
+        }
+      | No_alias
+
+    let exists = function
+      | Earliest _ -> true
+      | No_alias -> false
+
+    let update t new_name binding_time =
+      match t with
+      | No_alias ->
+        Earliest { name = new_name; binding_time }
+      | Earliest { binding_time = old_binding_time; _ } ->
+        if Binding_time.strictly_earlier binding_time ~than:old_binding_time
+        then Earliest { name = new_name; binding_time }
+        else t
+
+    let union t1 t2 =
+      match t2 with
+      | No_alias -> t1
+      | Earliest { name; binding_time } ->
+        update t1 name binding_time
+
+    let map_name t ~f =
+      match t with
+      | Earliest e ->
+        let name = f e.name in
+        Earliest { e with name }
+      | No_alias -> No_alias
+
+    let print ppf = function
+      | Earliest { name; binding_time } ->
+        Format.fprintf ppf
+          "@[<hov 1>(%a@ \
+           @[<hov 1>(binding_time@ %a)@])@]"
+          Simple.print name
+          Binding_time.print binding_time
+      | No_alias ->
+        Format.pp_print_string ppf "<none>"
+  end
   type t = {
-    aliases : Simple.Set.t Name_mode.Map.t;
     all : Simple.Set.t;
+    earliest : Earliest_alias.t;
+    earliest_normal : Earliest_alias.t;
+    (* Earliest alias whose name mode >= phantom (that is, normal or phantom) *)
+    earliest_ge_phantom : Earliest_alias.t;
+    (* Earliest alias whose name mode >= in-types *)
+    earliest_ge_in_types : Earliest_alias.t;
   }
 
-  let invariant _t = ()
-
-  let print ppf { aliases; all = _; } =
-    Name_mode.Map.print Simple.Set.print ppf aliases
-
   let empty = {
-    aliases = Name_mode.Map.empty;
     all = Simple.Set.empty;
+    earliest = No_alias;
+    earliest_normal = No_alias;
+    earliest_ge_phantom = No_alias;
+    earliest_ge_in_types = No_alias;
   }
 
-  let is_empty t = Simple.Set.is_empty t.all
-
-  let add t elt name_mode =
-    if Simple.Set.mem elt t.all then begin
+  let print ppf
+        { earliest; earliest_normal; earliest_ge_phantom; earliest_ge_in_types;
+          all } =
+    let pp_earliest field_name ppf (earliest : Earliest_alias.t) =
+      Format.fprintf ppf "@[<hov 1>@<0>%s(%s@ %a)@<0>%s@]"
+        (if Earliest_alias.exists earliest 
+         then Flambda_colours.normal ()
+         else Flambda_colours.elide ())
+        field_name
+        Earliest_alias.print earliest
+        (Flambda_colours.normal ())
+    in  
+    Format.fprintf ppf
+      "@[<hov 1>(\
+         %a@ %a@ %a@ %a@ \
+         @[<hov 1>(all@ %a)@])\
+         @]"
+      (pp_earliest "earliest") earliest
+      (pp_earliest "earliest_normal") earliest_normal
+      (pp_earliest "earliest_ge_phantom") earliest_ge_phantom
+      (pp_earliest "earliest_ge_in_types") earliest_ge_in_types
+      Simple.Set.print all
+      
+  let add t new_name binding_time_and_name_mode =
+    if Simple.Set.mem new_name t.all then begin
       Misc.fatal_errorf "%a already added to [Aliases_of_canonical_element]: \
-          %a"
-        Simple.print elt
+                         %a"
+        Simple.print new_name
         print t
     end;
-    let aliases =
-      Name_mode.Map.update name_mode
-        (function
-          | None -> Some (Simple.Set.singleton elt)
-          | Some elts ->
-            if !Clflags.flambda_invariant_checks then begin
-              assert (not (Simple.Set.mem elt elts))
-            end;
-            Some (Simple.Set.add elt elts))
-        t.aliases
+    let binding_time, name_mode =
+      Binding_time.With_name_mode.(
+        binding_time binding_time_and_name_mode,
+        name_mode binding_time_and_name_mode)
     in
-    let all = Simple.Set.add elt t.all in
-    { aliases;
-      all;
-    }
+    let update earliest =
+      Earliest_alias.update earliest new_name binding_time
+    in
+    let update_if_mode_ge mode earliest =
+      match Name_mode.compare_partial_order name_mode mode with
+      | Some c when c >= 0 -> update earliest
+      | _ -> earliest
+    in
+    let earliest = update t.earliest in
+    let earliest_normal =
+      update_if_mode_ge Name_mode.normal t.earliest_normal
+    in
+    let earliest_ge_phantom =
+      update_if_mode_ge Name_mode.phantom t.earliest_ge_phantom
+    in
+    let earliest_ge_in_types =
+      update_if_mode_ge Name_mode.in_types t.earliest_ge_in_types
+    in
+    let all = Simple.Set.add new_name t.all in
+    { earliest; earliest_normal; earliest_ge_phantom; earliest_ge_in_types;
+      all }
+
+  let find_earliest t ~(min_name_mode : Name_mode.t option) =
+    match min_name_mode with
+    | None -> t.earliest
+    | Some min_name_mode ->
+      begin match Name_mode.descr min_name_mode with
+      | Normal -> t.earliest_normal
+      | Phantom -> t.earliest_ge_phantom
+      | In_types -> t.earliest_ge_in_types
+      end
 
-  let find_earliest_candidates t ~min_name_mode =
-    Name_mode.Map.fold (fun order aliases res_opt ->
-        match res_opt with
-        | Some _ -> res_opt
-        | None ->
-          begin match
-            Name_mode.compare_partial_order
-              order min_name_mode
-          with
-          | None -> None
-          | Some result ->
-            if result >= 0 then Some aliases else None
-          end)
-      t.aliases
-      None
+  let invariant t ~binding_times_and_modes =
+    let describe_field name_mode =
+      match name_mode with
+      | None -> "overall"
+      | Some name_mode ->
+        begin match Name_mode.descr name_mode with
+          | Normal -> "normal"
+          | Phantom -> "phantom (or normal)"
+          | In_types -> "in-types (or normal)"
+        end
+    in
+    let check name binding_time name_mode (earliest : Earliest_alias.t) =
+      match earliest with
+      | No_alias -> ()
+      | Earliest e as earliest_as_recorded ->
+        if Binding_time.compare binding_time e.binding_time < 0 then
+          Misc.fatal_errorf
+            "@[<hov 1>Earliest %s alias %a@ has binding time %a,@ \
+             earlier than %a@ in %a\
+             @]"
+           (describe_field name_mode)
+           Simple.print name
+           Binding_time.print binding_time
+           Earliest_alias.print earliest_as_recorded
+           print t
+    in
+    Simple.Set.iter (fun name ->
+      let binding_time_and_mode =
+        Simple.Map.find name binding_times_and_modes
+      in
+      let binding_time, name_mode =
+        Binding_time.With_name_mode.(
+          binding_time binding_time_and_mode,
+          name_mode binding_time_and_mode)
+      in  
+      check name binding_time None t.earliest;
+      let earliest_in_mode = find_earliest t ~min_name_mode:(Some name_mode) in
+      check name binding_time (Some name_mode) earliest_in_mode
+    ) t.all;
+    let check_earliest min_name_mode =
+      match find_earliest t ~min_name_mode with
+      | No_alias -> ()
+      | Earliest e as earliest ->
+        if not (Simple.Set.mem e.name t.all) then begin
+          Misc.fatal_errorf
+            "@[<v>Aliases_of_canonical_element: Earliest %s not in map@ \
+             @[<hov 1>Alias: %a@ Map: %a@]@]"
+            (describe_field min_name_mode)
+            Earliest_alias.print earliest
+            Simple.Set.print t.all
+        end
+    in
+    List.iter check_earliest
+      [ None; 
+        Some Name_mode.normal;
+        Some Name_mode.phantom;
+        Some Name_mode.in_types ]
 
   let mem t elt =
     Simple.Set.mem elt t.all
 
   let all t = t.all
 
+  let earliest_alias_exn t ~min_name_mode =
+    match find_earliest t ~min_name_mode with
+    | Earliest { name; binding_time = _ } -> name
+    | No_alias -> raise Not_found
+
   let union t1 t2 =
-    let aliases =
-      Name_mode.Map.union (fun _order elts1 elts2 ->
-          Some (Simple.Set.union elts1 elts2))
-        t1.aliases t2.aliases
-    in
-    let t =
-      { aliases;
-        all = Simple.Set.union t1.all t2.all;
-      }
+    let all = Simple.Set.union t1.all t2.all in
+    let earliest =
+      Earliest_alias.union t1.earliest t2.earliest
     in
-    invariant t;
-    t
-
-  let inter t1 t2 =
-    let aliases =
-      Name_mode.Map.merge (fun _order elts1 elts2 ->
-          match elts1, elts2 with
-          | None, None | Some _, None | None, Some _ -> None
-          | Some elts1, Some elts2 -> Some (Simple.Set.inter elts1 elts2))
-        t1.aliases t2.aliases
+    let earliest_normal =
+      Earliest_alias.union t1.earliest_normal t2.earliest_normal
     in
-    let t =
-      { aliases;
-        all = Simple.Set.inter t1.all t2.all;
-      }
+    let earliest_ge_phantom =
+      Earliest_alias.union t1.earliest_ge_phantom t2.earliest_ge_phantom
     in
-    invariant t;
-    t
-
-  let rename rename_simple { aliases; all } =
-    let aliases =
-      Name_mode.Map.map (fun elts -> Simple.Set.map rename_simple elts)
-        aliases
+    let earliest_ge_in_types =
+      Earliest_alias.union t1.earliest_ge_in_types t2.earliest_ge_in_types
     in
+    { all; earliest; earliest_normal; earliest_ge_phantom;
+      earliest_ge_in_types; }
+
+  let disjoint t1 t2 =
+    Simple.Set.intersection_is_empty t1.all t2.all
+
+  let update_all_earliest
+        { all; earliest; earliest_normal;
+          earliest_ge_phantom; earliest_ge_in_types; } ~f =
+    let earliest = f earliest in
+    let earliest_normal = f earliest_normal in
+    let earliest_ge_phantom = f earliest_ge_phantom in
+    let earliest_ge_in_types = f earliest_ge_in_types in
+    { all; earliest; earliest_normal; earliest_ge_phantom;
+      earliest_ge_in_types; }
+
+  let rename rename_simple
+        ({ all; earliest = _; earliest_normal = _;
+           earliest_ge_phantom = _; earliest_ge_in_types = _; } as t) =
     let all = Simple.Set.map rename_simple all in
-    { aliases; all }
-
-  let merge t1 t2 =
-    let aliases =
-      Name_mode.Map.union (fun _mode set1 set2 ->
-          Some (Simple.Set.union set1 set2))
-        t1.aliases
-        t2.aliases
-    in
-    let all = Simple.Set.union t1.all t2.all in
-    { aliases; all; }
-
-  let move_variables_to_mode_in_types { aliases; all; } =
-    let (no_vars_aliases, all_variables) =
-      Name_mode.Map.fold (fun mode aliases (no_vars_aliases, all_variables) ->
-          let (vars, non_vars) = Simple.Set.partition Simple.is_var aliases in
-          let no_vars_aliases =
-            if Simple.Set.is_empty non_vars then no_vars_aliases
-            else Name_mode.Map.add mode non_vars no_vars_aliases
-          in
-          no_vars_aliases, Simple.Set.union vars all_variables)
-        aliases
-        (Name_mode.Map.empty, Simple.Set.empty)
-    in
-    let aliases =
-      if Name_mode.Map.mem Name_mode.in_types no_vars_aliases
-      then Misc.fatal_errorf "move_variables_to_mode_in_types: \
-             The following non-vars have mode In_types:@ %a"
-             Simple.Set.print
-             (Name_mode.Map.find Name_mode.in_types no_vars_aliases)
-      else
-        if Simple.Set.is_empty all_variables then no_vars_aliases
-        else Name_mode.Map.add Name_mode.in_types all_variables no_vars_aliases
+    let t =
+      update_all_earliest t ~f:(Earliest_alias.map_name ~f:rename_simple)
     in
-    { aliases; all; }
+    { t with all; }
+
+  let move_variables_to_mode_in_types t =
+    update_all_earliest t ~f:(fun earliest ->
+      match earliest with
+      | Earliest { name; _ } when Simple.is_var name -> No_alias
+      | _ -> earliest)
 end
 
 type t = {
@@ -218,11 +343,16 @@ let name_mode t elt =
   Binding_time.With_name_mode.name_mode
     (Simple.Map.find elt t.binding_times_and_modes)
 
+let binding_time_and_name_mode t elt =
+  Simple.Map.find elt t.binding_times_and_modes
+
+
 let invariant t =
   if !Clflags.flambda_invariant_checks then begin
     let _all_aliases : Simple.Set.t =
       Simple.Map.fold (fun canonical_element aliases all_aliases ->
-          Aliases_of_canonical_element.invariant aliases;
+          Aliases_of_canonical_element.invariant aliases
+            ~binding_times_and_modes:t.binding_times_and_modes;
           let aliases = Aliases_of_canonical_element.all aliases in
           if not (Simple.Set.for_all (fun elt ->
             defined_earlier t canonical_element ~than:elt) aliases)
@@ -298,15 +428,14 @@ let add_alias_between_canonical_elements t ~canonical_element ~to_be_demoted =
     if !Clflags.flambda_invariant_checks then begin
       assert (not (Aliases_of_canonical_element.mem
         aliases_of_canonical_element to_be_demoted));
-      assert (Aliases_of_canonical_element.is_empty (
-        Aliases_of_canonical_element.inter
-          aliases_of_canonical_element aliases_of_to_be_demoted))
+      assert (Aliases_of_canonical_element.disjoint
+        aliases_of_canonical_element aliases_of_to_be_demoted)
     end;
     let aliases =
       Aliases_of_canonical_element.add
         (Aliases_of_canonical_element.union aliases_of_to_be_demoted
           aliases_of_canonical_element)
-        to_be_demoted (name_mode t to_be_demoted)
+        to_be_demoted (binding_time_and_name_mode t to_be_demoted)
     in
     let aliases_of_canonical_elements =
       t.aliases_of_canonical_elements
@@ -481,21 +610,8 @@ Format.eprintf "looking for canonical for %a, candidate canonical %a, min order
 *)
     let find_earliest () =
       let aliases = get_aliases_of_canonical_element t ~canonical_element in
-      match
-        Aliases_of_canonical_element.find_earliest_candidates aliases
-          ~min_name_mode
-      with
-      | Some at_earliest_mode ->
-        (* Aliases_of_canonical_element.find_earliest_candidates only returns
-           non-empty sets *)
-        assert (not (Simple.Set.is_empty at_earliest_mode));
-        Simple.Set.fold (fun elt min_elt ->
-            if defined_earlier t elt ~than:min_elt
-            then elt
-            else min_elt)
-          at_earliest_mode
-          (Simple.Set.min_elt at_earliest_mode)
-      | None -> raise Not_found
+        Aliases_of_canonical_element.earliest_alias_exn aliases
+          ~min_name_mode:(Some min_name_mode)
     in
     match
       Name_mode.compare_partial_order
@@ -577,7 +693,7 @@ let merge t1 t2 =
     (* Warning: here the keys of the map can come from other
        compilation units, so we cannot assume the keys are disjoint *)
     Simple.Map.union (fun _simple aliases1 aliases2 ->
-        Some (Aliases_of_canonical_element.merge aliases1 aliases2))
+        Some (Aliases_of_canonical_element.union aliases1 aliases2))
       t1.aliases_of_canonical_elements
       t2.aliases_of_canonical_elements
   in