Implement a generic collection mechanism for lexical env lookup caches.

This also repurposes the `All_Diags_Trace` GNATCOLL trace which was
introduced recently but in fact never used.

Author: Roldak

langkit/compile_context.py

@@ -307,6 +307,35 @@ def kind_name(self) -> names.Name:
         return names.Name('Exception') + self.name
 
 
+@dataclasses.dataclass
+class CacheCollectionConf:
+    """
+    Describes a strategy to use for automatic cache collection.
+    """
+
+    threshold_increment: int
+    """
+    Indicates the number of additional lexical env cache entries needed after
+    the last cache collection to trigger a new one. To give an example,
+    assume that we reached the current threshold set to 1000 entries. Hence, a
+    collection is attempted. If after this collection the number of entries is
+    back to, say 800, then we add to it this ``threshold_increment``, say 200,
+    to get the new threshold. This means a new collection will be attempted
+    when we reach 1000 entries again. Must be positive.
+    """
+
+    decision_heuristic: Optional[LibraryEntity] = None
+    """
+    The heuristic to use to decide whether a given unit should have its lexical
+    env caches collected or not. When left to ``None``, this will use the
+    default heuristic which will end up clearing the caches of all units when
+    the collection threshold is reached.
+    """
+
+    def __post_init__(self):
+        assert self.threshold_increment > 0
+
+
 class CompileCtx:
     """State holder for native code emission."""
 
@@ -348,7 +377,8 @@ def __init__(self,
                  build_date: Optional[str] = None,
                  standalone: bool = False,
                  property_exceptions: Set[str] = set(),
-                 generate_unparser: bool = False):
+                 generate_unparser: bool = False,
+                 cache_collection_conf: Optional[CacheCollectionConf] = None):
         """Create a new context for code emission.
 
         :param lang_name: string (mixed case and underscore: see
@@ -455,6 +485,9 @@ def __init__(self,
 
         :param generate_unparser: If true, generate a pretty printer for the
             given grammar. False by default.
+
+        :param cache_collection_conf: If not None, setup the automatic cache
+            collection mechanism with this configuration.
         """
         from langkit.python_api import PythonAPISettings
         from langkit.ocaml_api import OCamlAPISettings
@@ -688,6 +721,13 @@ def __init__(self,
         Whether there is a RefEnvs action in environment specs.
         """
 
+        self.cache_collection_conf: Optional[CacheCollectionConf] = (
+            cache_collection_conf
+        )
+        """
+        The cache collection configuration to use for this language.
+        """
+
         self.template_lookup_extra_dirs: List[str] = (
             template_lookup_extra_dirs or []
         )
@@ -1037,6 +1077,13 @@ def add_with_clause(self, from_pkg, source_kind, to_pkg, use_clause=False,
         self.with_clauses[(from_pkg, source_kind)].append(
             (to_pkg, use_clause, is_private))
 
+    @property
+    def cache_collection_enabled(self) -> bool:
+        """
+        Return whether the automatic cache collection mechanism is enabled.
+        """
+        return self.cache_collection_conf is not None
+
     @property
     def sorted_logic_functors(self) -> List[Tuple[PropertyDef, int]]:
         return sorted(

langkit/support/langkit_support-lexical_envs_impl.adb

@@ -170,14 +170,31 @@ package body Langkit_Support.Lexical_Envs_Impl is
    ------------------------
 
    procedure Reset_Lookup_Cache (Self : Lexical_Env) is
-      Env : constant Lexical_Env_Access := Unwrap (Self);
+      use Lookup_Cache_Maps;
+
+      Env      : constant Lexical_Env_Access := Unwrap (Self);
+      C        : Cursor := First (Env.Lookup_Cache);
+      Removed  : Long_Long_Integer := 0;
    begin
-      for C of Env.Lookup_Cache loop
-         C.Elements.Destroy;
+      --  Use an explicit cursor iteration, as a `for of` loop introduces a
+      --  non-negligible runtime overhead.
+      while Has_Element (C) loop
+         declare
+            Elements : Lookup_Result_Item_Vectors.Vector renames
+              Env.Lookup_Cache.Reference (C).Elements;
+         begin
+            Removed := Removed + Long_Long_Integer (Elements.Length);
+            Elements.Destroy;
+            C := Next (C);
+         end;
       end loop;
 
       Env.Lookup_Cache.Clear;
       Env.Lookup_Cache_Valid := True;
+
+      if Removed > 0 and then Env.Node /= No_Node then
+         Notify_Cache_Updated (Env.Node, -Removed);
+      end if;
    end Reset_Lookup_Cache;
 
    -----------------------
@@ -1248,6 +1265,10 @@ package body Langkit_Support.Lexical_Envs_Impl is
               (Res_Key, Val, Cached_Res_Cursor, Inserted);
          end;
 
+         if Env.Node /= No_Node then
+            Notify_Cache_Looked_Up (Env.Node);
+         end if;
+
          if Inserted then
             Need_Cache := True;
             Outer_Results := Local_Results;
@@ -1274,6 +1295,9 @@ package body Langkit_Support.Lexical_Envs_Impl is
                   null;
                when Computed =>
                   Local_Results.Concat (Res_Val.Elements);
+                  if Env.Node /= No_Node then
+                     Notify_Cache_Hit (Env.Node);
+                  end if;
                   return;
                when None =>
                   Need_Cache := True;
@@ -1401,6 +1425,10 @@ package body Langkit_Support.Lexical_Envs_Impl is
                Caches_Trace.Trace ("INSERTING CACHE ENTRY " & Log_Id);
             end if;
 
+            if Env.Node /= No_Node then
+               Notify_Cache_Updated
+                 (Env.Node, Long_Long_Integer (Local_Results.Length));
+            end if;
             Env.Lookup_Cache.Include (Res_Key, (Computed, Local_Results));
             Outer_Results.Concat (Local_Results);
             Local_Results := Outer_Results;
@@ -2540,7 +2568,7 @@ package body Langkit_Support.Lexical_Envs_Impl is
 
    procedure Reset_Caches (Self : Lexical_Env) is
    begin
-      Unwrap (Self).Lookup_Cache_Valid := False;
+      Reset_Lookup_Cache (Self);
    end Reset_Caches;
 
    ----------------------

langkit/support/langkit_support-lexical_envs_impl.ads

@@ -97,6 +97,21 @@ generic
    --  Return the current version number of caches corresponding to Node's
    --  context, for cache invalidation purposes.
 
+   with procedure Notify_Cache_Updated
+     (Node : Node_Type; Delta_Amount : Long_Long_Integer) is null;
+   --  Callback procedure used when the number of entries in the lookup cache
+   --  of the lexical env held by the given node has changed by the given
+   --  amount (positive: N entries were added, negative: N entries were
+   --  removed). May trigger a cache collection.
+
+   with procedure Notify_Cache_Looked_Up (Node : Node_Type) is null;
+   --  Callback procedure used when the lookup cache associated with the given
+   --  node was looked up.
+
+   with procedure Notify_Cache_Hit (Node : Node_Type) is null;
+   --  Callback procedure used when the lookup cache associated with the given
+   --  node successfully returned a cached entry after a lookup.
+
    type Inner_Env_Assoc is private;
    with function Get_Key
      (Self : Inner_Env_Assoc) return Symbol_Type is <>;