Use weak maps for tracking values checked at runtime. (#3672) (#3674)

src/core/builtins/builtins_settings.ml

@@ -222,7 +222,12 @@ let print_settings () =
     | (Value.Fun ([], _, _) | Value.FFI ([], _)) as value ->
         let value =
           Lang.apply
-            { Value.pos = None; value; methods = Value.Methods.empty }
+            {
+              Value.pos = None;
+              value;
+              methods = Value.Methods.empty;
+              id = Value.id ();
+            }
             []
         in
         [
@@ -242,7 +247,12 @@ let print_settings () =
 ```
 |} path
             (Value.to_string
-               { Value.pos = None; value; methods = Value.Methods.empty });
+               {
+                 Value.pos = None;
+                 value;
+                 methods = Value.Methods.empty;
+                 id = Value.id ();
+               });
         ]
   in
   let rec print_descr ~level ~path descr =

src/core/io/srt_io.ml

@@ -391,11 +391,17 @@ let () =
   Lifecycle.on_core_shutdown ~name:"srt shutdown" (fun () ->
       Atomic.set shutdown true)
 
+let id =
+  let counter = Atomic.make 0 in
+  fun () -> Atomic.fetch_and_add counter 1
+
 class virtual base =
   object
     val should_stop = Atomic.make false
+    val id = id ()
     method private should_stop = Atomic.get shutdown || Atomic.get should_stop
     method private set_should_stop = Atomic.set should_stop
+    method srt_id = id
   end
 
 class virtual networking_agent =
@@ -423,7 +429,9 @@ class virtual output_networking_agent =
   end
 
 module ToDisconnect = Liquidsoap_lang.Active_value.Make (struct
-  type t = < disconnect : unit >
+  type t = < disconnect : unit ; srt_id : int >
+
+  let id t = t#srt_id
 end)
 
 let to_disconnect = ToDisconnect.create 10

src/core/lang.mli

@@ -53,6 +53,7 @@ type value = Liquidsoap_lang.Value.t = {
   pos : Liquidsoap_lang.Pos.Option.t;
   value : in_value;
   methods : value Liquidsoap_lang.Value.Methods.t;
+  id : int;
 }
 
 and env = (string * value) list

src/core/lang_source.ml

@@ -22,6 +22,12 @@
 
 open Liquidsoap_lang.Lang
 
+module Alive_values_map = Liquidsoap_lang.Active_value.Make (struct
+  type t = Value.t
+
+  let id v = v.Value.id
+end)
+
 let log = Log.make ["lang"]
 let metadata_t = list_t (product_t string_t string_t)
 
@@ -295,15 +301,16 @@ let to_track = Track.of_value
     the currently defined source as argument). *)
 type 'a operator_method = string * scheme * string * ('a -> value)
 
+let checked_values = Alive_values_map.create 10
+
 (** Ensure that the frame contents of all the sources occurring in the value agree with [t]. *)
 let check_content v t =
-  let checked_values = ref [] in
   let check t t' = Typing.(t <: t') in
   let rec check_value v t =
-    if not (List.memq v !checked_values) then (
+    if not (Alive_values_map.mem checked_values v) then (
       (* We need to avoid checking the same value multiple times, otherwise we
          get an exponential blowup, see #1247. *)
-      checked_values := v :: !checked_values;
+      Alive_values_map.add checked_values v;
       match (v.Value.value, (Type.deref t).Type.descr) with
         | _, Type.Var _ -> ()
         | _ when Source_val.is_value v ->
@@ -489,8 +496,9 @@ let add_track_operator ~(category : Doc.Value.source) ~descr ?(flags = [])
   let category = `Track category in
   add_builtin ~category ~descr ~flags ?base name arguments return_t f
 
+let itered_values = Alive_values_map.create 10
+
 let iter_sources ?(on_imprecise = fun () -> ()) f v =
-  let itered_values = ref [] in
   let rec iter_term env v =
     let iter_base_term env v =
       match v.Term.term with
@@ -532,10 +540,10 @@ let iter_sources ?(on_imprecise = fun () -> ()) f v =
       v.Term.methods;
     iter_base_term env v
   and iter_value v =
-    if not (List.memq v !itered_values) then (
+    if not (Alive_values_map.mem itered_values v) then (
       (* We need to avoid checking the same value multiple times, otherwise we
          get an exponential blowup, see #1247. *)
-      itered_values := v :: !itered_values;
+      Alive_values_map.add itered_values v;
       Value.Methods.iter (fun _ v -> iter_value v) v.Value.methods;
       match v.value with
         | _ when Source_val.is_value v -> f (Source_val.of_value v)

src/lang/active_value.ml

@@ -24,32 +24,15 @@
 
 module type T = sig
   type t
+
+  val id : t -> int
 end
 
 module Make (T : T) = struct
-  type entry = { id : int; hash : int; value : T.t }
-
   include Weak.Make (struct
-    type t = entry
+    type t = T.t
 
-    let equal t t' = t.id = t'.id
-    let hash t = t.hash
+    let equal t t' = T.id t = T.id t'
+    let hash t = T.id t
   end)
-
-  type data = T.t
-
-  let counter = Atomic.make 0
-
-  let mk value =
-    { id = Atomic.fetch_and_add counter 1; hash = Hashtbl.hash value; value }
-
-  let merge t v = (merge t (mk v)).value
-  let add t v = add t (mk v)
-  let remove t v = remove t (mk v)
-  let find t v = (find t (mk v)).value
-  let find_opt t v = Option.map (fun { value; _ } -> value) (find_opt t (mk v))
-  let find_all t v = List.map (fun { value; _ } -> value) (find_all t (mk v))
-  let mem t v = mem t (mk v)
-  let iter fn = iter (fun { value; _ } -> fn value)
-  let fold fn = fold (fun { value; _ } acc -> fn value acc)
 end

src/lang/active_value.mli

@@ -24,6 +24,8 @@
 
 module type T = sig
   type t
+
+  val id : t -> int
 end
 
 module Make (T : T) : sig

src/lang/environment.ml

@@ -122,4 +122,6 @@ let add_module name =
         with _ -> ()));
   add_builtin ~register:false name
     ( ([], Type.make Type.unit),
-      Value.{ pos = None; value = unit; methods = Methods.empty } )
+      Value.
+        { pos = None; value = unit; methods = Methods.empty; id = Value.id () }
+    )

src/lang/evaluation.ml

@@ -225,7 +225,13 @@ and apply ?pos ~eval_check f l =
 
 and eval_base_term ~eval_check (env : Env.t) tm =
   let mk v =
-    Value.{ pos = tm.t.Type.pos; value = v; methods = Methods.empty }
+    Value.
+      {
+        pos = tm.t.Type.pos;
+        value = v;
+        methods = Methods.empty;
+        id = Value.id ();
+      }
   in
   match tm.term with
     | Ground g -> mk (Value.Ground g)

src/lang/lang.mli

@@ -53,6 +53,7 @@ type value = Value.t = {
   pos : Pos.Option.t;
   value : in_value;
   methods : value Methods.t;
+  id : int;
 }
 
 and env = (string * value) list

src/lang/lang_core.ml

@@ -33,6 +33,7 @@ type value = Value.t = {
   pos : Pos.Option.t;
   value : in_value;
   methods : value Methods.t;
+  id : int;
 }
 
 (** Type construction *)
@@ -83,7 +84,7 @@ let ref_t a = Type.reference a
 
 (** Value construction *)
 
-let mk ?pos value = { pos; value; methods = Methods.empty }
+let mk ?pos value = { pos; value; methods = Methods.empty; id = id () }
 let unit = mk unit
 let int i = mk (Ground (Int i))
 let bool i = mk (Ground (Bool i))
@@ -171,6 +172,7 @@ let add_builtin ~category ~descr ?(flags = []) ?(meth = []) ?(examples = [])
       pos = None;
       value = FFI (List.map (fun (lbl, _, opt, _) -> (lbl, lbl, opt)) proto, f);
       methods = Methods.empty;
+      id = id ();
     }
   in
   let doc () =
@@ -258,7 +260,7 @@ let add_builtin_value ~category ~descr ?(flags = []) ?base name value t =
 
 let add_builtin_base ~category ~descr ?flags ?base name value t =
   add_builtin_value ~category ~descr ?flags ?base name
-    { pos = t.Type.pos; value; methods = Methods.empty }
+    { pos = t.Type.pos; value; methods = Methods.empty; id = id () }
     t
 
 let add_module ?base name =

src/lang/term.ml

@@ -191,7 +191,7 @@ module Methods = struct
   type 'a t = 'a typ
 end
 
-type t = { mutable t : Type.t; term : in_term; methods : t Methods.t }
+type t = { mutable t : Type.t; term : in_term; methods : t Methods.t; id : int }
 
 (** Documentation for declarations: general documentation, parameters, methods. *)
 and doc = Doc.Value.t
@@ -337,22 +337,29 @@ let rec to_string v =
 module ActiveTerm = Active_value.Make (struct
   type typ = t
   type t = typ
+
+  let id { id } = id
 end)
 
 let active_terms = ActiveTerm.create 1024
 
 let trim_runtime_types () =
   ActiveTerm.iter (fun term -> term.t <- Type.deep_demeth term.t) active_terms
 
+let id =
+  let counter = Atomic.make 0 in
+  fun () -> Atomic.fetch_and_add counter 1
+
 (** Create a new value. *)
 let make ?pos ?t ?(methods = Methods.empty) e =
+  let id = id () in
   let t = match t with Some t -> t | None -> Type.var ?pos () in
   if Lazy.force debug then
     Printf.eprintf "%s (%s): assigned type var %s\n"
       (Pos.Option.to_string t.Type.pos)
-      (try to_string { t; term = e; methods } with _ -> "<?>")
+      (try to_string { t; term = e; methods; id } with _ -> "<?>")
       (Repr.string_of_type t);
-  let term = { t; term = e; methods } in
+  let term = { t; term = e; methods; id } in
   ActiveTerm.add active_terms term;
   term
 
@@ -596,7 +603,12 @@ module MkAbstract (Def : AbstractDef) = struct
   let of_term t = match t.term with Ground (Value c) -> c | _ -> assert false
 
   let to_term c =
-    { t = Type.make T.descr; term = Ground (Value c); methods = Methods.empty }
+    {
+      t = Type.make T.descr;
+      term = Ground (Value c);
+      methods = Methods.empty;
+      id = id ();
+    }
 
   let is_term t = match t.term with Ground (Value _) -> true | _ -> false
 end

src/lang/term.mli

@@ -123,7 +123,13 @@ module Methods : sig
   type 'a t = 'a typ
 end
 
-type t = private { mutable t : Type.t; term : in_term; methods : t Methods.t }
+type t = private {
+  mutable t : Type.t;
+  term : in_term;
+  methods : t Methods.t;
+  id : int;
+}
+
 and doc = Doc.Value.t
 
 and let_t = {

src/lang/value.ml

@@ -27,7 +27,13 @@ module Ground = Term.Ground
 
 module Methods = Term.Methods
 
-type t = { pos : Pos.Option.t; value : in_value; methods : t Methods.t }
+type t = {
+  pos : Pos.Option.t;
+  value : in_value;
+  methods : t Methods.t;
+  id : int;
+}
+
 and env = (string * t) list
 
 (* Some values have to be lazy in the environment because of recursive functions. *)
@@ -45,6 +51,10 @@ and in_value =
      doesn't capture anything in the environment. *)
   | FFI of (string * string * t option) list * (env -> t)
 
+let id =
+  let counter = Atomic.make 0 in
+  fun () -> Atomic.fetch_and_add counter 1
+
 let unit : in_value = Tuple []
 
 let string_of_float f =
@@ -150,10 +160,12 @@ let compare a b =
                          pos = None;
                          value = Ground (Ground.String lbl);
                          methods = Methods.empty;
+                         id = id ();
                        };
                        v;
                      ];
                  methods = Methods.empty;
+                 id = id ();
                })
              a)
       in
@@ -170,10 +182,12 @@ let compare a b =
                          pos = None;
                          value = Ground (Ground.String lbl);
                          methods = Methods.empty;
+                         id = id ();
                        };
                        v;
                      ];
                  methods = Methods.empty;
+                 id = id ();
                })
              b)
       in
@@ -198,7 +212,7 @@ module MkAbstractFromTerm (Term : Term.Abstract) = struct
   include Term
 
   let to_value ?pos c =
-    { pos; value = Ground (to_ground c); methods = Methods.empty }
+    { pos; value = Ground (to_ground c); methods = Methods.empty; id = id () }
 
   let of_value t =
     match t.value with