Test the counter restore and the fallback of deferred signature copies

The independent review found the env.mli comment for read_signature
attached to the new stats function, and the comment and changelog
overstating when copies are deferred: only after an earlier copy of the
same interface in the process, never for the first one or a one-shot bsc.
New unit tests check that Ident.with_current_time puts the counter back
when its function raises, and that a deferred copy whose counts are wrong
(a forged .cmi CRC) is made again with fresh stamps.

Signed-off-by: Jono Prest <jjprest@gmail.com>

Author: JonoPrest

changes/defer-dependency-signature-copy.internal.md

@@ -1 +1 @@
-- Speed up type checking by copying a dependency's interface only when it is read, not when the compiler only checks whether it is a module alias.
+- Speed up type checking in builds: after the first copy of a dependency's interface, later requests only copy it when they read it, not when they only check whether it is a module alias.

compiler/ml/env.ml

@@ -544,14 +544,15 @@ let current_unit () = Domain.DLS.get current_unit_key
 (* The signature of a persistent structure is a copy of the one in its .cmi
    file whose bound identifiers are renamed ([Subst.signature Subst.identity]).
    The copy is often only asked for to learn that a compilation unit is not a
-   module alias ([normalize_path]), so it is not made then: the stamps and type
-   ids it would have taken are reserved, so every later stamp and id is the
-   same as if it had been made, and the copy is made with exactly those stamps
-   and ids when the signature is first read.
-
-   The number of stamps and ids a copy takes is learnt from the first copy of
-   the same .cmi contents (keyed by its CRC) and kept for the whole process.
-   It only depends on the signature graph, which the type checker does not
+   module alias ([normalize_path]). When this process has already copied the
+   same .cmi contents (same CRC), e.g. in an earlier request of the same
+   build, the copy is not made then: the stamps and type ids it would take are
+   reserved, so every later stamp and id is the same as if it had been made,
+   and the copy is made with exactly those stamps and ids when the signature
+   is first read. Otherwise (the first copy of an interface, or a one-shot
+   bsc) it is made at once, as before, and its counts are kept.
+
+   The number of stamps and ids a copy takes only depends on the signature graph, which the type checker does not
    change before copying it: only copies of it are given to the rest of the
    type checker. If a reserved copy ever takes a different number of stamps or
    ids, it is thrown away and made again with fresh ones. *)

compiler/ml/env.mli

@@ -166,13 +166,13 @@ val get_unit_name : unit -> string
 (* Read, save a signature to/from a file *)
 
 val read_signature : string -> string -> signature
+(* Arguments: module name, file name. Results: signature. *)
 
 val deferred_signature_copy_stats : unit -> int * int
 (* For tests: how many copies of compilation units' signatures were deferred,
    and how many of those did not take the stamps and type ids reserved for
    them and were made again with fresh ones (expected: none), in the process
    so far. *)
-(* Arguments: module name, file name. Results: signature. *)
 
 val save_signature :
   ?check_exists:unit ->

tests/ounit_tests/ounit_deferred_signature_tests.ml

@@ -101,9 +101,109 @@ let unread_copy_tests _ =
   let eager = ask_only ~eager:true in
   assert_equal eager (ask_only ~eager:false)
 
+(* [Ident.with_current_time] puts the counter back also when its function
+   raises. *)
+let with_current_time_restores_on_exception _ =
+  Ident.with_fresh (fun () ->
+      let before = Ident.current_time () in
+      let inside = ref 0 in
+      (match
+         Ident.with_current_time (before + 100) (fun () ->
+             inside := Ident.binding_time (Ident.create "inside");
+             failwith "raised inside")
+       with
+      | _ -> assert_failure "the function should have raised"
+      | exception Failure _ -> ());
+      assert_equal ~printer:string_of_int (before + 101) !inside;
+      assert_equal ~printer:string_of_int ~msg:"counter restored after raise"
+        before (Ident.current_time ());
+      let (), final =
+        Ident.with_current_time (before + 7) (fun () ->
+            ignore (Ident.create "a");
+            ignore (Ident.create "b"))
+      in
+      assert_equal ~printer:string_of_int (before + 9) final;
+      assert_equal ~printer:string_of_int ~msg:"counter restored after return"
+        before (Ident.current_time ()))
+
+(* A compilation unit [Forged] whose .cmi claims the CRC of different contents:
+   the counts learnt from the first contents are wrong for the second, so its
+   deferred copy takes more stamps and ids than were reserved, and is made
+   again with fresh ones. *)
+let value name =
+  Types.Sig_value
+    ( Ident.create name,
+      {
+        val_type = Predef.type_int ();
+        val_kind = Val_reg;
+        val_loc = Location.none;
+        val_attributes = [];
+      } )
+
+let forged_crc = Digest.string "ounit_deferred_signature_tests forged crc"
+
+let with_forged_unit sign action =
+  let cmi =
+    {
+      Cmi_format.cmi_name = "Forged";
+      cmi_sign = sign;
+      cmi_crcs = [("Forged", Some forged_crc)];
+      cmi_flags = [];
+    }
+  in
+  let saved_load = !Env.Persistent_signature.load in
+  (Env.Persistent_signature.load :=
+     fun ~unit_name ->
+       if unit_name = "Forged" then
+         Some {Env.Persistent_signature.filename = "Forged.cmi"; cmi}
+       else saved_load ~unit_name);
+  Fun.protect
+    ~finally:(fun () -> Env.Persistent_signature.load := saved_load)
+    (fun () ->
+      Compiler_request_state.with_fresh (fun () ->
+          Request_local.with_fresh (fun () -> Ident.with_fresh action)))
+
+let count_mismatch_fallback_tests _ =
+  let path = unit_path "Forged" in
+  (* Learn the counts of a one-value signature. *)
+  with_forged_unit
+    [value "x"]
+    (fun () -> ignore (Env.find_module path Env.empty));
+  let reserved_before, fallbacks_before =
+    Env.deferred_signature_copy_stats ()
+  in
+  let stamps, probe_stamp =
+    with_forged_unit
+      [value "x"; value "y"]
+      (fun () ->
+        ignore (Env.normalize_path None Env.empty path);
+        let probe_stamp = Ident.binding_time (Ident.create "probe") in
+        match (Env.find_module path Env.empty).md_type with
+        | Mty_signature items ->
+          ( List.map
+              (function
+                | Types.Sig_value (id, _) -> Ident.binding_time id
+                | _ -> assert_failure "expected values")
+              items,
+            probe_stamp )
+        | _ -> assert_failure "expected a signature")
+  in
+  let reserved_after, fallbacks_after = Env.deferred_signature_copy_stats () in
+  assert_equal ~printer:string_of_int ~msg:"the copy was deferred"
+    (reserved_before + 1) reserved_after;
+  assert_equal ~printer:string_of_int ~msg:"the copy fell back"
+    (fallbacks_before + 1) fallbacks_after;
+  assert_bool "the fallback copy has both values with fresh stamps"
+    (List.length stamps = 2
+    && List.for_all (fun stamp -> stamp > probe_stamp) stamps)
+
 let suites =
   __FILE__
   >::: [
          "deferred_copy_matches_eager_copy" >:: deferred_copy_tests;
          "unread_copy_reserves_stamps_and_ids" >:: unread_copy_tests;
+         "with_current_time_restores_on_exception"
+         >:: with_current_time_restores_on_exception;
+         "count_mismatch_falls_back_to_fresh_ids"
+         >:: count_mismatch_fallback_tests;
        ]