Allow to capture the library a backend is attached to

src/inline_tests.ml

@@ -54,7 +54,7 @@ module Backend = struct
 
     type t =
       { info             : Info.t
-      ; id               : Lib.Id.t
+      ; lib              : Lib.t
       ; runner_libraries : (Lib.t list, exn) result
       ; extends          : (    t list, exn) result option
       }
@@ -62,12 +62,12 @@ module Backend = struct
     let desc ~plural = "inline tests backend" ^ if plural then "s" else ""
     let desc_article = "an"
 
-    let id t = t.id
+    let lib  t = t.lib
     let deps t = t.extends
 
-    let instantiate ~resolve ~get id (info : Info.t) =
+    let instantiate ~resolve ~get lib (info : Info.t) =
       { info
-      ; id
+      ; lib
       ; runner_libraries = Result.all (List.map info.runner_libraries ~f:resolve)
       ; extends =
           let open Result.O in
@@ -87,7 +87,7 @@ module Backend = struct
     let to_sexp t =
       let open Sexp.To_sexp in
       let lib x = string (Lib.name x) in
-      let f x = string x.id.name in
+      let f x = string (Lib.name x.lib) in
       ((1, 0),
        record
          [ "runner_libraries", list lib (Result.ok_exn t.runner_libraries)

src/lib.ml

@@ -194,7 +194,7 @@ module Sub_system0 = struct
   type 'a s = (module S with type t = 'a)
 
   module Instance = struct
-    type t = T : 'a s * 'a Lazy.t -> t
+    type t = T : 'a s * 'a -> t
   end
 end
 
@@ -226,7 +226,13 @@ type t =
   ; resolved_selects  : Resolved_select.t list
   ; optional          : bool
   ; user_written_deps : Jbuild.Lib_deps.t
-  ; sub_systems       : Sub_system0.Instance.t Sub_system_name.Map.t
+  ; (* This is mutable to avoid this error:
+
+       {[
+         This kind of expression is not allowed as right-hand side of `let rec'
+       }]
+       *)
+    mutable sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
   }
 
 and db =
@@ -298,6 +304,7 @@ let synopsis     t = t.synopsis
 let archives     t = t.archives
 let plugins      t = t.plugins
 let jsoo_runtime t = t.jsoo_runtime
+let unique_id    t = t.unique_id
 
 let src_dir t = t.src_dir
 let obj_dir t = t.obj_dir
@@ -377,7 +384,7 @@ module Sub_system = struct
     val instantiate
       :  resolve:(Loc.t * string -> (lib, exn) result)
       -> get:(lib -> t option)
-      -> Id.t
+      -> lib
       -> Info.t
       -> t
     val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
@@ -394,7 +401,7 @@ module Sub_system = struct
   module Register(M : S) = struct
     let get lib =
       Option.map (Sub_system_name.Map.find lib.sub_systems M.Info.name)
-        ~f:(fun (Sub_system0.Instance.T ((module X), lazy t)) ->
+        ~f:(fun (lazy (Sub_system0.Instance.T ((module X), t))) ->
           match X.T t with
           | M.T t -> t
           | _   -> assert false)
@@ -409,19 +416,18 @@ module Sub_system = struct
         ~data:(Some (module M : S'))
   end
 
-  let instantiate_many sub_systems id ~resolve =
-    Sub_system_name.Map.mapi sub_systems ~f:(fun name info ->
-      let impl = Option.value_exn (Sub_system_name.Table.get all name) in
-      let (module M : S') = impl in
-      match info with
-      | M.Info.T info ->
-        Sub_system0.Instance.T
-          (M.for_instance, lazy (M.instantiate ~resolve ~get:M.get id info))
-      | _ -> assert false)
+  let instantiate name info lib ~resolve =
+    let impl = Option.value_exn (Sub_system_name.Table.get all name) in
+    let (module M : S') = impl in
+    match info with
+    | M.Info.T info ->
+      Sub_system0.Instance.T
+        (M.for_instance, M.instantiate ~resolve ~get:M.get lib info)
+    | _ -> assert false
 
   let dump_config lib =
-    Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun inst ->
-      let (Sub_system0.Instance.T ((module M), lazy t)) = inst in
+    Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) ->
+      let (Sub_system0.Instance.T ((module M), t)) = inst in
       match M.to_sexp with
       | None -> None
       | Some f -> Some (f t))
@@ -567,10 +573,12 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden =
     ; resolved_selects  = resolved_selects
     ; optional          = info.optional
     ; user_written_deps = Info.user_written_deps info
-    ; sub_systems       = Sub_system.instantiate_many info.sub_systems id
-                            ~resolve
+    ; sub_systems       = Sub_system_name.Map.empty
     }
   in
+  t.sub_systems <-
+    Sub_system_name.Map.mapi info.sub_systems ~f:(fun name info ->
+      lazy (Sub_system.instantiate name info t ~resolve));
 
   let res =
     let hidden =
@@ -797,7 +805,7 @@ module Compile = struct
     ; resolved_selects  : Resolved_select.t list
     ; optional          : bool
     ; user_written_deps : Jbuild.Lib_deps.t
-    ; sub_systems       : Sub_system0.Instance.t Sub_system_name.Map.t
+    ; sub_systems       : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
     }
 
   let make libs =
@@ -828,7 +836,8 @@ module Compile = struct
   let user_written_deps t = t.user_written_deps
   let sub_systems t =
     Sub_system_name.Map.values t.sub_systems
-    |> List.map ~f:(fun (Sub_system0.Instance.T ((module M), lazy t)) -> M.T t)
+    |> List.map ~f:(fun (lazy (Sub_system0.Instance.T ((module M), t))) ->
+      M.T t)
 end
 
 (* +-----------------------------------------------------------------+

src/lib.mli

@@ -26,6 +26,10 @@ val archives     : t -> Path.t list Mode.Dict.t
 val plugins      : t -> Path.t list Mode.Dict.t
 val jsoo_runtime : t -> Path.t list
 
+(** A unique integer identifier. It is only unique for the duration of
+    the process *)
+val unique_id : t -> int
+
 module Status : sig
   type t =
     | Installed
@@ -91,14 +95,6 @@ module Info : sig
   val of_findlib_package : Findlib.Package.t -> t
 end
 
-module Id : sig
-  type t =
-    { unique_id : int
-    ; path      : Path.t
-    ; name      : string
-    }
-end
-
 (** {1 Errors} *)
 
 module Error : sig
@@ -290,7 +286,7 @@ module Sub_system : sig
     val instantiate
       :  resolve:(Loc.t * string -> (lib, exn) result)
       -> get:(lib -> t option)
-      -> Id.t
+      -> lib
       -> Info.t
       -> t
     val to_sexp : (t -> Syntax.Version.t * Sexp.t) option

src/sub_system.ml

@@ -15,7 +15,7 @@ module Register_backend(M : Backend) = struct
       (struct
         type t = M.t
         type graph = unit
-        let key t = (M.id t).unique_id
+        let key t = Lib.unique_id (M.lib t)
         let deps t () =
           match M.deps t with
           | Some (Ok l) -> l
@@ -25,7 +25,10 @@ module Register_backend(M : Backend) = struct
   module Set =
     Set.Make(struct
       type t = M.t
-      let compare a b = compare (M.id a).unique_id (M.id b).unique_id
+      let compare a b =
+        compare
+          (Lib.unique_id (M.lib a))
+          (Lib.unique_id (M.lib b))
     end)
 
   let select_backends ~loc ~scope ~written_by_user to_scan =
@@ -70,9 +73,10 @@ module Register_backend(M : Backend) = struct
              (M.desc ~plural:true)
              (String.concat ~sep:"\n"
                 (List.map (Set.to_list roots) ~f:(fun t ->
+                   let lib = M.lib t in
                    sprintf "- %S in %s"
-                     (M.id t).name
-                     (Path.to_string_maybe_quoted (M.id t).path)))))
+                     (Lib.name lib)
+                     (Path.to_string_maybe_quoted (Lib.src_dir lib))))))
 end
 
 type Lib.Sub_system.t +=

src/sub_system_intf.ml

@@ -13,7 +13,7 @@ module type S = sig
   val instantiate
     :  resolve:(Loc.t * string -> (Lib.t, exn) result)
     -> get:(Lib.t -> t option)
-    -> Lib.Id.t
+    -> Lib.t
     -> Info.t
     -> t
 end
@@ -30,7 +30,7 @@ module type Backend = sig
   val desc_article : string
 
   (** Library the backend is attached to *)
-  val id : t -> Lib.Id.t
+  val lib : t -> Lib.t
 
   (** Dependencies on other backends *)
   val deps : t -> (t list, exn) result option