Fix potential bug with caused by delaying the addition of aliases

lthls · lthls · commit c0dfa825b560 · 2021-02-17T15:52:10.000+01:00
diff --git a/middle_end/flambda/types/env/typing_env.rec.ml b/middle_end/flambda/types/env/typing_env.rec.ml
@@ -42,16 +42,16 @@ module Cached : sig
     -> Type_grammar.t
     -> Binding_time.t
     -> Name_mode.t
-    -> new_aliases:Aliases.t
     -> t
 
   val replace_variable_binding
      : t
     -> Variable.t
     -> Type_grammar.t
-    -> new_aliases:Aliases.t
     -> t
 
+  val with_aliases : t -> aliases:Aliases.t -> t
+
   val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t
 
   val find_symbol_projection : t -> Variable.t -> Symbol_projection.t option
@@ -125,27 +125,30 @@ end = struct
      (used to be add-or-replace), the [names_to_types] map addition was a
      major source of allocation. *)
 
-  let add_or_replace_binding t (name : Name.t) ty binding_time name_mode ~new_aliases =
+  let add_or_replace_binding t (name : Name.t) ty binding_time name_mode =
     let names_to_types =
       Name.Map.add name (ty, binding_time, name_mode) t.names_to_types
     in
     { names_to_types;
-      aliases = new_aliases;
+      aliases = t.aliases;
       symbol_projections = t.symbol_projections;
     }
 
-  let replace_variable_binding t var ty ~new_aliases =
+  let replace_variable_binding t var ty =
     let names_to_types =
       Name.Map.replace (Name.var var)
         (function (_old_ty, binding_time, name_mode) ->
           ty, binding_time, name_mode)
         t.names_to_types
     in
     { names_to_types;
-      aliases = new_aliases;
+      aliases = t.aliases;
       symbol_projections = t.symbol_projections;
     }
 
+  let with_aliases t ~aliases =
+    { t with aliases; }
+
   let add_symbol_projection t var proj =
     let symbol_projections = Variable.Map.add var proj t.symbol_projections in
     { t with symbol_projections; }
@@ -263,6 +266,12 @@ module One_level = struct
   let level t = t.level
   let just_after_level t = t.just_after_level
 
+  let with_aliases t ~aliases =
+    let just_after_level =
+      Cached.with_aliases t.just_after_level ~aliases
+    in
+    { t with just_after_level; }
+
   let is_empty t = Typing_env_level.is_empty t.level
 
 (*
@@ -737,6 +746,12 @@ let with_current_level_and_next_binding_time t ~current_level
   invariant t;
   t
 
+let with_aliases t ~aliases =
+  let current_level =
+    One_level.with_aliases t.current_level ~aliases
+  in
+  with_current_level t ~current_level
+
 let cached t = One_level.just_after_level t.current_level
 
 let add_variable_definition t var kind name_mode =
@@ -766,7 +781,6 @@ let add_variable_definition t var kind name_mode =
     Cached.add_or_replace_binding (cached t)
       name (Type_grammar.unknown kind)
       t.next_binding_time name_mode
-      ~new_aliases:(aliases t)
   in
   let current_level =
     One_level.create (current_scope t) level ~just_after_level
@@ -869,7 +883,7 @@ let invariant_for_new_equation t name ty =
     end
   end
 
-let rec add_equation0 t aliases name ty =
+let rec add_equation0 t name ty =
   if !Clflags.Flambda.Debug.concrete_types_only_on_canonicals then begin
     let is_concrete =
       match Type_grammar.get_alias_exn ty with
@@ -905,20 +919,18 @@ let rec add_equation0 t aliases name ty =
           then
             Cached.replace_variable_binding
               (One_level.just_after_level t.current_level)
-              var ty ~new_aliases:aliases
+              var ty
           else
             Cached.add_or_replace_binding
               (One_level.just_after_level t.current_level)
               name ty Binding_time.imported_variables Name_mode.in_types
-              ~new_aliases:aliases
         in
         just_after_level, t.closure_env)
       ~symbol:(fun _ ->
         let just_after_level =
           Cached.add_or_replace_binding
             (One_level.just_after_level t.current_level)
             name ty Binding_time.symbols Name_mode.normal
-            ~new_aliases:aliases
         in
         let closure_env =
           match t.closure_env with
@@ -987,15 +999,15 @@ and add_equation t name ty =
           end)
         ~const:(fun _ -> ())
   end;
-  let aliases, simple, rec_info, t, ty =
+  let simple, rec_info, t, ty =
     let aliases = aliases t in
     match Type_grammar.get_alias_exn ty with
     | exception Not_found ->
       (* Equations giving concrete types may only be added to the canonical
          element as known by the alias tracker (the actual canonical, ignoring
          any name modes). *)
       let canonical = Aliases.get_canonical_ignoring_name_mode aliases name in
-      aliases, canonical, None, t, ty
+      canonical, None, t, ty
     | alias_of ->
       let alias = Simple.name name in
       let kind = Type_grammar.kind ty in
@@ -1008,10 +1020,11 @@ and add_equation t name ty =
         Aliases.add aliases alias binding_time_and_mode_alias
           alias_of binding_time_and_mode_alias_of
       in
+      let t = with_aliases t ~aliases in
       let ty =
         Type_grammar.alias_type_of kind canonical_element
       in
-      aliases, alias_of, rec_info, t, ty
+      alias_of, rec_info, t, ty
   in
   (* Beware: if we're about to add the equation on a name which is different
      from the one that the caller passed in, then we need to make sure that the
@@ -1047,7 +1060,7 @@ and add_equation t name ty =
       | Bottom -> Type_grammar.bottom (Type_grammar.kind ty)
       | Ok ty -> ty
   in
-  let [@inline always] name name = add_equation0 t aliases name ty in
+  let [@inline always] name name = add_equation0 t name ty in
   Simple.pattern_match simple ~name ~const:(fun _ -> t)
 
 and add_env_extension t (env_extension : Typing_env_extension.t) =
