[src][state][file_infos] update to more precise fields

fantazio · fantazio · commit 7a15e62f41c7 · 2025-12-22T20:12:51.000+01:00
Only keep useful information from the cm*_infos rather than the whole
structure. This makes clearer what is actually used from those and
reduces the error surface.
diff --git a/src/deadCode.ml b/src/deadCode.ml
@@ -448,33 +448,33 @@ let rec load_file state fn =
     last_loc := Lexing.dummy_pos;
     if !DeadFlag.verbose then Printf.eprintf "Scanning interface from %s\n%!" fn;
     init_and_continue state fn (fun state ->
-    match state.file_infos.cmi_infos with
+    match state.file_infos.cmi_sign with
     | None -> bad_files := fn :: !bad_files
-    | Some {cmi_sign; _} ->
+    | Some cmi_sign ->
         read_interface fn cmi_sign state
     )
   in
   let process_implementation fn =
     last_loc := Lexing.dummy_pos;
     if !DeadFlag.verbose then Printf.eprintf "Scanning implementation from %s\n%!" fn;
     init_and_continue state fn (fun state ->
-    match state.file_infos.cmt_infos with
+    match state.file_infos.cmt_struct with
     | None -> bad_files := fn :: !bad_files
-    | Some {cmt_annots = Implementation x; _} ->
+    | Some structure ->
         regabs state;
         let prepare (loc1, loc2) =
           DeadObj.add_equal loc1 loc2;
           VdNode.merge_locs ~force:true loc2 loc1
         in
         List.iter prepare state.file_infos.location_dependencies;
-        ignore (collect_references.Tast_mapper.structure collect_references x);
+        collect_references.Tast_mapper.structure collect_references structure
+        |> ignore;
         let loc_dep =
           if !DeadFlag.exported.DeadFlag.print then
               state.file_infos.location_dependencies
           else []
         in
         eof loc_dep
-    | _ -> () (* todo: support partial_implementation? *)
     )
   in
   match kind fn with
diff --git a/src/state/file_infos.ml b/src/state/file_infos.ml
@@ -1,9 +1,9 @@
 type t = {
   builddir : string;
   cm_file : string;
-  cmi_infos : Cmi_format.cmi_infos option;
-  cmt_infos : Cmt_format.cmt_infos option;
-  cmti_infos : Cmt_format.cmt_infos option;
+  cmi_sign : Types.signature option;
+  cmt_struct : Typedtree.structure option;
+  cmti_uid_to_decl : Location_dependencies.uid_to_decl option;
   location_dependencies : Location_dependencies.t;
   modname : string;
   sourcepath : string option;
@@ -12,119 +12,125 @@ type t = {
 let empty = {
   builddir = "!!UNKNOWN_BUILDDIR!!";
   cm_file = "";
-  cmi_infos = None;
-  cmt_infos = None;
-  cmti_infos = None;
+  cmi_sign = None;
+  cmt_struct = None;
+  cmti_uid_to_decl = None;
   location_dependencies = Location_dependencies.empty;
   modname = "!!UNKNOWN_MODNAME!!";
   sourcepath = None;
 }
 
-(** [init_from_all_cm_infos ~orig ~cm_file cmi_infos cmt_infos] creates a [t] with:
-    - information from [cmt_infos];
+(** [init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos] creates a [t] with:
+    - information from [cmt_infos] : [builddir], [modname], [sourcepath];
     - [cm_file];
-    - [cmi_infos];
-    - [cmt_infos = Some cmt_infos] if [orig = `Cmt];
-    - [cmti_infos = Some cmt_infos] if [orig = `Cmti]. *)
-  let init_from_all_cm_infos ~orig ~cm_file cmi_infos cmt_infos =
+    - [cmi_sign = Some cm_infos.cmi_sign] if [cmi_infos = Some _]; *)
+  let init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos =
   let builddir = cmt_infos.Cmt_format.cmt_builddir in
   let sourcepath =
     Option.map (Filename.concat builddir) cmt_infos.cmt_sourcefile
   in
   let modname = cmt_infos.cmt_modname in
-  let cmt_infos, cmti_infos =
-    match orig with
-    | `Cmt -> Some cmt_infos, None
-    | `Cmti -> None, Some cmt_infos
-  in
+  let cmi_sign = Option.map (fun Cmi_format.{cmi_sign; _} -> cmi_sign) cmi_infos in
   {empty with builddir;
               cm_file;
-              cmi_infos;
-              cmt_infos;
-              cmti_infos;
+              cmi_sign;
               modname;
               sourcepath}
 
-(** [init_from_cm_file ~orig cm_file] returns an [Ok t] with [t] filled using
-    the [cm_file] (see [init_from_cmt_infos]).
+(** [init_from_cm_file cm_file] returns an [Ok t] with [t] filled with general
+    info expected for both cmt and cmti files, using the [cm_file] (see
+    [init_from_all_cm_infos]).
     In case the file does not exist or it cannot be read (see
     [Cmt_format.read_cmt]) then it returns an [Err msg] with msg a string
     describing the issue. *)
-let init_from_cm_file ~orig cm_file =
+let init_from_cm_file cm_file =
   if not (Sys.file_exists cm_file) then Result.error (cm_file ^ ": file not found")
   else
     match Cmt_format.read cm_file with
     | exception _ -> Result.error (cm_file ^ ": error reading file")
     | _, None -> Result.error (cm_file ^ ": cmt_infos not found")
     | cmi_infos, Some cmt_infos ->
-        init_from_all_cm_infos ~orig ~cm_file cmi_infos cmt_infos
-        |> Result.ok
+        let file_infos =
+          init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos
+        in
+        Result.ok (file_infos, cmt_infos)
 
 let ( let* ) x f = Result.bind x f
+let ( let+ ) x f = Result.map f x
 
-let init cm_file =
-  let* orig =
-    match Filename.extension cm_file with
-    | ".cmt" -> Result.ok `Cmt
-    | ".cmti" -> Result.ok `Cmti
-    | _ -> Result.error (cm_file ^ ": not a .cmti or .cmt file")
+let init_from_cmti_file cmti_file =
+  let+ file_infos, cmt_infos = init_from_cm_file cmti_file in
+  let cmti_uid_to_decl = Some cmt_infos.cmt_uid_to_decl in
+  {file_infos with cmti_uid_to_decl}
+
+let init_from_cmt_file cmt_file =
+  let* file_infos, cmt_infos = init_from_cm_file cmt_file in
+  let* cmt_struct =
+    match cmt_infos.cmt_annots with
+    | Implementation structure -> Result.ok structure
+    | _ -> Result.error (cmt_file ^ ": does not contain an implementation")
   in
-  let* file_infos = init_from_cm_file ~orig cm_file in
-  let cmi_infos, cmt_infos, cmti_infos =
-    let no_ext = Filename.remove_extension cm_file in
-    match orig with
-    | `Cmt ->
-        let cmi_infos, cmti_infos =
-          init_from_cm_file ~orig:`Cmti (no_ext ^ ".cmti")
-          |> Result.map (fun {cmi_infos; cmti_infos; _} -> cmi_infos, cmti_infos)
-          |> Result.value ~default:(file_infos.cmi_infos, file_infos.cmti_infos)
-        in
-        cmi_infos, file_infos.cmt_infos, cmti_infos
-    | `Cmti ->
-        let cmt_infos =
-          init_from_cm_file ~orig:`Cmt (no_ext ^ ".cmt")
-          |> Result.map (fun {cmt_infos; _} -> cmt_infos)
-          |> Result.value ~default:file_infos.cmt_infos
-        in
-        file_infos.cmi_infos, cmt_infos, file_infos.cmti_infos
+  let cmt_struct = Some cmt_struct in
+  (* Read the cmti if it exists. We always want to do it in case a user
+     specified the cmt before the cmti to ensure the location_dependencies
+     are idempotent. *)
+  let cmti_uid_to_decl =
+    let cmti_file = Filename.remove_extension cmt_file ^ ".cmti" in
+    match init_from_cmti_file cmti_file with
+    | Error _ -> None
+    | Ok file_infos -> file_infos.cmti_uid_to_decl
+  in
+  let+ location_dependencies =
+    Location_dependencies.init cmt_infos cmti_uid_to_decl
   in
-  let* location_dependencies =
-    match orig with
-    | `Cmt -> Location_dependencies.init cmt_infos cmti_infos
-    | `Cmti -> Result.ok Location_dependencies.empty
+  let file_infos =
+    {file_infos with cmt_struct; cmti_uid_to_decl; location_dependencies}
   in
-  Result.ok {file_infos with cmi_infos;
-                             cmt_infos;
-                             cmti_infos;
-                             location_dependencies}
+  file_infos, cmt_infos
+
+let init cm_file =
+  match Filename.extension cm_file with
+  | ".cmt" ->
+      let+ file_infos, _ = init_from_cmt_file cm_file in
+      file_infos
+  | ".cmti" -> (
+      (* Using cmt_infos is not critical. The intent is to mirror the behavior
+         on cmt files, where both cmt and cmti are read. *)
+      let filled_with_cmt_infos =
+        let cmt_file = Filename.remove_extension cm_file ^ ".cmt" in
+        let* file_infos, cmt_infos = init_from_cmt_file cmt_file in
+        let+ location_dependencies =
+          Location_dependencies.init cmt_infos file_infos.cmti_uid_to_decl
+        in
+        {file_infos with location_dependencies}
+      in
+      match filled_with_cmt_infos with
+      | Ok {cmt_struct; cmti_uid_to_decl; location_dependencies; _} ->
+          let+ res, _ = init_from_cm_file cm_file in
+          {res with cmt_struct; cmti_uid_to_decl; location_dependencies}
+      | Error _ -> init_from_cmti_file cm_file
+  )
+  | _ -> Result.error (cm_file ^ ": not a .cmti or .cmt file")
 
 let change_file file_infos cm_file =
   let no_ext = Filename.remove_extension cm_file in
   assert(no_ext = Filename.remove_extension file_infos.cm_file);
   match Filename.extension cm_file, file_infos with
-  | ".cmt", {cmt_infos=Some cmt_infos; cmi_infos; cmti_infos; _} ->
-      let res =
-        init_from_all_cm_infos ~orig:`Cmt ~cm_file cmi_infos cmt_infos
-      in
-      let res = {res with cmi_infos; cmti_infos} in
-      let* location_dependencies =
-        Location_dependencies.init res.cmt_infos res.cmti_infos
-      in
-      Result.ok {res with location_dependencies}
-  | ".cmti", {cmti_infos=Some cmti_infos; cmi_infos; cmt_infos; _} ->
-      let res =
-        init_from_all_cm_infos ~orig:`Cmti ~cm_file cmi_infos cmti_infos
-      in
-      Result.ok {res with cmt_infos}
-  | _, {cmi_infos; cmt_infos; cmti_infos; _} -> (* corresponding info is None or invalid extension *)
-      let* res = init cm_file in
-      let choose opt1 opt2 =
-        if Option.is_some opt1 then opt1 else opt2
+  | ".cmt", {cmt_struct = (Some _ as cs); cmi_sign; cmti_uid_to_decl; _} ->
+      let* res, cmt_infos = init_from_cm_file cm_file in
+      let+ location_dependencies =
+        match file_infos.location_dependencies with
+        | [] -> Location_dependencies.init cmt_infos cmti_uid_to_decl
+        | loc_dep -> (* They have already been computed *)
+            Result.ok loc_dep
       in
-      let cmi_infos = choose res.cmi_infos cmi_infos in
-      let cmt_infos = choose res.cmt_infos cmt_infos in
-      let cmti_infos = choose res.cmti_infos cmti_infos in
-      Result.ok {res with cmi_infos; cmt_infos; cmti_infos}
+      {res with cmt_struct = cs; cmi_sign; cmti_uid_to_decl; location_dependencies}
+  | ".cmti", {cmti_uid_to_decl = (Some _ as cutd); cmt_struct; location_dependencies; _} ->
+      let+ res, _ = init_from_cm_file cm_file in
+      {res with cmti_uid_to_decl = cutd; cmt_struct; location_dependencies}
+  | _ ->
+      (* invalid extension or the corresponding info is None *)
+      init cm_file
 
 let has_sourcepath file_infos = Option.is_some file_infos.sourcepath
 
diff --git a/src/state/file_infos.mli b/src/state/file_infos.mli
@@ -3,9 +3,11 @@
 type t = {
   builddir : string; (** The [cmt_builddir] *)
   cm_file : string; (** The filepath currently analyzed *)
-  cmi_infos : Cmi_format.cmi_infos option;
-  cmt_infos : Cmt_format.cmt_infos option;
-  cmti_infos : Cmt_format.cmt_infos option;
+  cmi_sign : Types.signature option; (** Extracted from [cmi_infos] *)
+  cmt_struct : Typedtree.structure option;
+    (** Extracted from a cmt's [cmt_infos.cmt_annots] *)
+  cmti_uid_to_decl : Location_dependencies.uid_to_decl option;
+    (** Extracted from a cmti's [cmt_infos] *)
   location_dependencies : Location_dependencies.t;
     (** Dependencies similar to [cmt_infos.cmt_value_dependencies] in OCaml 5.2 *)
   modname : string; (** Either [cmti_name] or [cmt_modname] *)
diff --git a/src/state/location_dependencies.ml b/src/state/location_dependencies.ml
@@ -4,6 +4,8 @@ let empty = []
 
 module UidTbl = Shape.Uid.Tbl
 
+type uid_to_decl = Typedtree.item_declaration UidTbl.t
+
 let fill_from_structure (structure : Typedtree.structure) res_uid_to_loc =
   let open Types in
   let rec fill_from_signature_item = function
@@ -32,7 +34,7 @@ let fill_from_structure (structure : Typedtree.structure) res_uid_to_loc =
   iterator.structure iterator structure;
   res_uid_to_loc
 
-let fill_from_cmt_infos cmt_infos res_uid_to_loc =
+let fill_from_cmt_tbl uid_to_decl res_uid_to_loc =
   let open Typedtree in
   let loc_of_item_decl = function
     | Value {val_loc = loc; _}
@@ -44,7 +46,7 @@ let fill_from_cmt_infos cmt_infos res_uid_to_loc =
     let loc = loc_of_item_decl item_decl in
     Option.iter (UidTbl.replace res_uid_to_loc uid) loc
   in
-  UidTbl.iter add_uid_loc cmt_infos.Cmt_format.cmt_uid_to_decl;
+  UidTbl.iter add_uid_loc uid_to_decl;
   res_uid_to_loc
 
 let cmt_decl_dep_to_loc_dep cmt_decl_dep uid_to_loc =
@@ -59,21 +61,20 @@ let cmt_decl_dep_to_loc_dep cmt_decl_dep uid_to_loc =
   in
   List.filter_map convert_pair cmt_decl_dep
 
-let init cmt_infos cmti_infos =
-  match cmt_infos with
-  | None -> Result.error "No cmt_infos available"
-  | Some (Cmt_format.{cmt_annots = Implementation structure; _} as cmt_infos) -> (
-      let fill_from_cmti_infos tbl =
-        match cmti_infos with
-        | None -> tbl
-        | Some cmti_infos -> fill_from_cmt_infos cmti_infos tbl
-      in
-      (* TODO: Evaluate a generally good size for the tbl ? *)
-      UidTbl.create 512
-      |> fill_from_structure structure
-      |> fill_from_cmt_infos cmt_infos
-      |> fill_from_cmti_infos
-      |> cmt_decl_dep_to_loc_dep cmt_infos.cmt_declaration_dependencies
-      |> Result.ok
-  )
-  | Some _ -> Result.error "No implementation found in cmt_infos"
+let init cmt_infos cmti_uid_to_decl =
+  match cmt_infos.Cmt_format.cmt_annots with
+  | Implementation structure ->
+    let fill_from_cmti_tbl tbl =
+      match cmti_uid_to_decl with
+      | None -> tbl
+      | Some cmti_uid_to_decl ->
+          fill_from_cmt_tbl cmti_uid_to_decl tbl
+    in
+    (* TODO: Evaluate a generally good size for the tbl ? *)
+    UidTbl.create 512
+    |> fill_from_structure structure
+    |> fill_from_cmt_tbl cmt_infos.cmt_uid_to_decl
+    |> fill_from_cmti_tbl
+    |> cmt_decl_dep_to_loc_dep cmt_infos.cmt_declaration_dependencies
+    |> Result.ok
+  | _ -> Result.error "No implementation found in cmt_infos"
diff --git a/src/state/location_dependencies.mli b/src/state/location_dependencies.mli
@@ -3,10 +3,13 @@ type t = (Lexing.position * Lexing.position) list
 
 val empty : t (** No signature read *)
 
-val init : Cmt_format.cmt_infos option -> Cmt_format.cmt_infos option -> (t, string) result
-(** [init cmt_infos cmti_infos] expects [cmt_infos = Some _].
-    It reads the [cmt_infos] and the |cmti_infos] to retrieve their
-    [cmt_declaration_dependencies] and convert them into a single [t].
+type uid_to_decl = Typedtree.item_declaration Shape.Uid.Tbl.t
+
+val init : Cmt_format.cmt_infos -> uid_to_decl option -> (t, string) result
+(** [init cmt_infos cmti_infos cmti_uid_to_decl] expects
+    [cmt_infos.cmt_annots = Implementation _].
+    It reads the [cmt_infos] and the [cmti_uid_to_decl] to retrieve their
+    and converts [cmt_infos.cmt_declaration_dependencies] into a single [t].
     It returns an [Ok t] with [t] on success.
-    In case the [cmt_infos] is missing or does not contain an implementation,
-    it returns an [Err msg] with msg a string describing the issue. *)
+    In case the [cmt_infos] does not contain an implementation, it returns an
+    [Err msg] with msg a string describing the issue. *)
