diff --git a/changes/defer-dependency-signature-copy.polish.md b/changes/defer-dependency-signature-copy.polish.md
new file mode 100644
index 0000000000..13e9812825
--- /dev/null
+++ b/changes/defer-dependency-signature-copy.polish.md
@@ -0,0 +1 @@
+- Build: copy a dependency's interface only when it is read, after the first copy of the same interface in a build, instead of every time a module checks whether the dependency is an alias.
diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml
index 9944627a53..89904517c7 100644
--- a/compiler/ext/ident.ml
+++ b/compiler/ext/ident.ml
@@ -82,6 +82,19 @@ let set_current_time t =
   let state = counter () in
   state.currentstamp <- max state.currentstamp t
 
+let with_current_time t f =
+  let state = counter () in
+  let saved = state.currentstamp in
+  state.currentstamp <- t;
+  match f () with
+  | result ->
+    let final = state.currentstamp in
+    state.currentstamp <- saved;
+    (result, final)
+  | exception exn ->
+    state.currentstamp <- saved;
+    raise exn
+
 let reinit () =
   let state = counter () in
   if state.reinit_level < 0 then state.reinit_level <- state.currentstamp
diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli
index f374f7a232..38c4a01ea2 100644
--- a/compiler/ext/ident.mli
+++ b/compiler/ext/ident.mli
@@ -50,6 +50,14 @@ val is_predef_exn : t -> bool
 val binding_time : t -> int
 val current_time : unit -> int
 val set_current_time : int -> unit
+
+val with_current_time : int -> (unit -> 'a) -> 'a * int
+
+(* [with_current_time t f] runs [f] with the stamp counter set to [t], so the
+   identifiers it creates get the stamps after [t], and returns [f]'s result
+   with the counter value it ended at. The counter is then put back to its
+   value before the call, also if [f] raises. Used to create identifiers whose
+   stamps were reserved earlier. *)
 val reinit : unit -> unit
 
 val capture_request_baseline : unit -> unit
diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml
index 0659044773..0b39f41d91 100644
--- a/compiler/ml/env.ml
+++ b/compiler/ml/env.ml
@@ -541,9 +541,119 @@ let current_unit () = Domain.DLS.get current_unit_key
 
 (* Persistent structure descriptions *)
 
+(* 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]). 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. *)
+
+type pers_sig_state =
+  | Sig_pending
+  | Sig_reserved of {stamp_base: int; type_base: int; stamps: int; types: int}
+  | Sig_copied of signature
+
+type pers_sig = {
+  pers_sig_raw: signature;
+  pers_sig_key: Digest.t option;
+  mutable pers_sig_state: pers_sig_state;
+}
+
+let copy_counts : (Digest.t, int * int) Hashtbl.t = Hashtbl.create 64
+let copy_counts_lock = Mutex.create ()
+
+(* [Mutex.protect] needs OCaml 5.1. *)
+let with_copy_counts_lock action =
+  Mutex.lock copy_counts_lock;
+  Fun.protect ~finally:(fun () -> Mutex.unlock copy_counts_lock) action
+
+let find_copy_counts key =
+  with_copy_counts_lock (fun () -> Hashtbl.find_opt copy_counts key)
+
+let record_copy_counts key counts =
+  with_copy_counts_lock (fun () ->
+      if Hashtbl.length copy_counts >= 65536 then Hashtbl.reset copy_counts;
+      Hashtbl.replace copy_counts key counts)
+
+let reserved_copies = Atomic.make 0
+let reserved_copy_fallbacks = Atomic.make 0
+
+let pers_sig ?key raw =
+  {pers_sig_raw = raw; pers_sig_key = key; pers_sig_state = Sig_pending}
+
+let copy_pers_sig raw = Subst.signature Subst.identity raw
+
+let force_pers_sig ps =
+  match ps.pers_sig_state with
+  | Sig_copied sg -> sg
+  | Sig_pending ->
+    let state = Compiler_request_state.current () in
+    let stamp0 = Ident.current_time () and type0 = state.type_node_id in
+    let sg = copy_pers_sig ps.pers_sig_raw in
+    (match ps.pers_sig_key with
+    | Some key ->
+      record_copy_counts key
+        (Ident.current_time () - stamp0, state.type_node_id - type0)
+    | None -> ());
+    ps.pers_sig_state <- Sig_copied sg;
+    sg
+  | Sig_reserved {stamp_base; type_base; stamps; types} ->
+    let state = Compiler_request_state.current () in
+    let saved_type_id = state.type_node_id in
+    state.type_node_id <- type_base;
+    let (sg, stamp_end), type_end =
+      match
+        Ident.with_current_time stamp_base (fun () ->
+            copy_pers_sig ps.pers_sig_raw)
+      with
+      | result ->
+        let type_end = state.type_node_id in
+        state.type_node_id <- saved_type_id;
+        (result, type_end)
+      | exception exn ->
+        state.type_node_id <- saved_type_id;
+        raise exn
+    in
+    let sg =
+      if stamp_end = stamp_base + stamps && type_end = type_base + types then sg
+      else (
+        (* Some of the stamps or ids may also belong to later identifiers and
+           type nodes: copy again with fresh ones. *)
+        Atomic.incr reserved_copy_fallbacks;
+        copy_pers_sig ps.pers_sig_raw)
+    in
+    ps.pers_sig_state <- Sig_copied sg;
+    sg
+
+(* Take the stamps and type ids [force_pers_sig] would take now, without
+   copying yet. *)
+let reserve_pers_sig ps =
+  match ps.pers_sig_state with
+  | Sig_copied _ | Sig_reserved _ -> ()
+  | Sig_pending -> (
+    match Option.bind ps.pers_sig_key find_copy_counts with
+    | None -> ignore (force_pers_sig ps)
+    | Some (stamps, types) ->
+      let state = Compiler_request_state.current () in
+      let stamp_base = Ident.current_time () in
+      let type_base = state.type_node_id in
+      Atomic.incr reserved_copies;
+      Ident.set_current_time (stamp_base + stamps);
+      state.type_node_id <- type_base + types;
+      ps.pers_sig_state <- Sig_reserved {stamp_base; type_base; stamps; types})
+
 type pers_struct = {
   ps_name: string;
-  ps_sig: signature Lazy.t;
+  ps_sig: pers_sig;
   ps_comps: module_components;
   ps_crcs: (string * Digest.t option) list;
   ps_filename: string;
@@ -607,6 +717,13 @@ module Persistent_signature = struct
         | exception Not_found -> None)
 end
 
+(* The CRC create_cmi wrote for the contents of the .cmi (its name and
+   signature). *)
+let own_crc (cmi : Cmi_format.cmi_infos) =
+  match cmi.cmi_crcs with
+  | (name, Some crc) :: _ when name = cmi.cmi_name -> Some crc
+  | _ -> None
+
 let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} =
   let name = cmi.cmi_name in
   let sign = cmi.cmi_sign in
@@ -626,7 +743,7 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} =
   let ps =
     {
       ps_name = name;
-      ps_sig = lazy (Subst.signature Subst.identity sign);
+      ps_sig = pers_sig ?key:(own_crc cmi) sign;
       ps_comps = comps;
       ps_crcs = crcs;
       ps_filename = filename;
@@ -822,7 +939,7 @@ let find_module ~alias path env =
     with Not_found ->
       if Ident.persistent id && not (Ident.name id = !(current_unit ())) then
         let ps = find_pers_struct (Ident.name id) in
-        md (Mty_signature (Lazy.force ps.ps_sig))
+        md (Mty_signature (force_pers_sig ps.ps_sig))
       else raise Not_found)
   | Pdot (p, s, _pos) -> (
     match get_components (find_module_descr p env) with
@@ -851,6 +968,26 @@ let find_module ~alias path env =
               mty))
     | Structure_comps _ -> raise Not_found)
 
+(* The path a module is an alias of, as [find_module ~alias:true] gives it. A
+   compilation unit is never an alias, so its signature is not copied. *)
+let module_alias_target path env =
+  let alias_target = function
+    | {md_type = Mty_alias (_, path1)} -> Some path1
+    | _ -> None
+  in
+  match path with
+  | Pident id -> (
+    try
+      let data = Id_tbl.find_same id env.modules in
+      alias_target (Env_lazy.force subst_modtype_maker data)
+    with Not_found ->
+      if Ident.persistent id && not (Ident.name id = !(current_unit ())) then (
+        let ps = find_pers_struct (Ident.name id) in
+        reserve_pers_sig ps.ps_sig;
+        None)
+      else raise Not_found)
+  | Pdot _ | Papply _ -> alias_target (find_module ~alias:true path env)
+
 let rec normalize_path lax env path =
   let path =
     match path with
@@ -860,9 +997,9 @@ let rec normalize_path lax env path =
     | _ -> path
   in
   try
-    match find_module ~alias:true path env with
-    | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1
-    | _ -> path
+    match module_alias_target path env with
+    | Some path1 -> normalize_path lax env path1
+    | None -> path
   with
   | Not_found
   when lax
@@ -1791,9 +1928,12 @@ let open_signature ?(used_slot = ref false) ?(loc = Location.none) ovf root env
 
 (* Read a signature from a file *)
 
+let deferred_signature_copy_stats () =
+  (Atomic.get reserved_copies, Atomic.get reserved_copy_fallbacks)
+
 let read_signature modname filename =
   let ps = read_pers_struct modname filename in
-  Lazy.force ps.ps_sig
+  force_pers_sig ps.ps_sig
 
 (* Return the CRC of the interface of the given compilation unit *)
 
@@ -1839,7 +1979,7 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename
     let ps =
       {
         ps_name = modname;
-        ps_sig = lazy (Subst.signature Subst.identity sg);
+        ps_sig = pers_sig sg;
         ps_comps = comps;
         ps_crcs = (cmi.cmi_name, Some crc) :: imports;
         ps_filename = filename;
@@ -1908,7 +2048,7 @@ let fold_modules f lid env acc =
         | Some ps ->
           f name
             (Pident (Ident.create_persistent name))
-            (md (Mty_signature (Lazy.force ps.ps_sig)))
+            (md (Mty_signature (force_pers_sig ps.ps_sig)))
             acc)
       (persistent_structures ()) acc
   | Some l -> (
diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli
index a2ebfcaf66..895090bbad 100644
--- a/compiler/ml/env.mli
+++ b/compiler/ml/env.mli
@@ -168,6 +168,12 @@ val get_unit_name : unit -> string
 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. *)
+
 val save_signature :
   ?check_exists:unit ->
   deprecated:string option ->
diff --git a/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs b/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs
new file mode 100644
index 0000000000..64658a08c6
--- /dev/null
+++ b/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs
@@ -0,0 +1,142 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+import * as Mocha from "mocha";
+import * as Belt_Id from "@rescript/belt/src/Belt_Id.mjs";
+import * as Belt_Set from "@rescript/belt/src/Belt_Set.mjs";
+import * as Belt_List from "@rescript/belt/src/Belt_List.mjs";
+import * as Belt_Array from "@rescript/belt/src/Belt_Array.mjs";
+import * as Test_utils from "./test_utils.mjs";
+import * as Belt_Option from "@rescript/belt/src/Belt_Option.mjs";
+import * as Primitive_int from "@rescript/runtime/lib/es6/Primitive_int.mjs";
+
+let C = {
+  D: undefined
+};
+
+let mapped = [
+  1,
+  2,
+  3
+].map(x => x + 1 | 0);
+
+let viaBelt = Belt_Array.map([
+  1,
+  2
+], x => x * 10 | 0);
+
+let viaList = Belt_List.toArray(Belt_List.map({hd: 1, tl: {hd: 2, tl: /* [] */0}}, x => x - 1 | 0));
+
+let cmp = Primitive_int.compare;
+
+let IntCmp = Belt_Id.MakeComparable({
+  cmp: cmp
+});
+
+let set = Belt_Set.fromArray([
+  3,
+  1,
+  2
+], IntCmp);
+
+function orZero(x) {
+  return Belt_Option.getWithDefault(x, 0);
+}
+
+let Extended = {
+  keepU: Belt_Option.keepU,
+  keep: Belt_Option.keep,
+  forEachU: Belt_Option.forEachU,
+  forEach: Belt_Option.forEach,
+  getExn: Belt_Option.getExn,
+  getOrThrow: Belt_Option.getOrThrow,
+  mapWithDefaultU: Belt_Option.mapWithDefaultU,
+  mapWithDefault: Belt_Option.mapWithDefault,
+  mapU: Belt_Option.mapU,
+  map: Belt_Option.map,
+  flatMapU: Belt_Option.flatMapU,
+  flatMap: Belt_Option.flatMap,
+  getWithDefault: Belt_Option.getWithDefault,
+  orElse: Belt_Option.orElse,
+  isSome: Belt_Option.isSome,
+  isNone: Belt_Option.isNone,
+  eqU: Belt_Option.eqU,
+  eq: Belt_Option.eq,
+  cmpU: Belt_Option.cmpU,
+  cmp: Belt_Option.cmp,
+  orZero: orZero
+};
+
+function size(t) {
+  if (typeof t !== "object") {
+    return 1;
+  } else {
+    return Belt_Array.reduce(t._0, 1, (acc, c) => acc + Tree.size(c) | 0);
+  }
+}
+
+let Tree = {
+  size: size
+};
+
+Mocha.describe("Belt_deferred_signature_copy_test", () => {
+  Mocha.test("alias chains", () => {
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 53, characters 7-14", [
+      2,
+      3,
+      4
+    ], mapped);
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 54, characters 7-14", [
+      10,
+      20
+    ], viaBelt);
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 55, characters 7-14", [
+      0,
+      1
+    ], viaList);
+  });
+  Mocha.test("functors and module types of dependencies", () => {
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 58, characters 7-14", [
+      1,
+      2,
+      3
+    ], Belt_Set.toArray(set));
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 59, characters 7-14", 2, 2);
+  });
+  Mocha.test("include and recursive modules", () => {
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 62, characters 7-14", 0, Belt_Option.getWithDefault(undefined, 0));
+    Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 63, characters 7-14", 3, Tree.size({
+      TAG: "Node",
+      _0: [
+        "Leaf",
+        "Leaf"
+      ]
+    }));
+  });
+});
+
+let A;
+
+let B;
+
+let L;
+
+let MyArray = Belt_Array;
+
+let MyArray$make = Belt_Array.make;
+
+export {
+  A,
+  B,
+  C,
+  L,
+  mapped,
+  viaBelt,
+  viaList,
+  IntCmp,
+  set,
+  MyArray,
+  Extended,
+  Tree,
+  MyArray$make,
+}
+/* mapped Not a pure module */
diff --git a/tests/belt_tests/src/belt_deferred_signature_copy_test.res b/tests/belt_tests/src/belt_deferred_signature_copy_test.res
new file mode 100644
index 0000000000..6f668b4409
--- /dev/null
+++ b/tests/belt_tests/src/belt_deferred_signature_copy_test.res
@@ -0,0 +1,65 @@
+// Uses of compilation units whose signatures the compiler only copies when
+// they are read: module aliases and chains of them, values reached through an
+// alias, functors and module types of dependencies, nested and recursive
+// modules, and includes.
+
+module A = Stdlib.Array
+module B = A
+
+module C = {
+  module D = B
+}
+
+module L = Belt.List
+
+let mapped = C.D.map([1, 2, 3], x => x + 1)
+let viaBelt = Belt.Array.map([1, 2], x => x * 10)
+let viaList = L.toArray(L.map(list{1, 2}, x => x - 1))
+
+module IntCmp = Belt.Id.MakeComparable({
+  type t = int
+  let cmp = (a: int, b: int) => compare(a, b)
+})
+
+let set = Belt.Set.fromArray([3, 1, 2], ~id=module(IntCmp))
+
+module type ArrayLike = module type of Belt.Array
+
+module MyArray: ArrayLike = Belt.Array
+
+module Extended = {
+  include Belt.Option
+  let orZero = x => getWithDefault(x, 0)
+}
+
+module rec Tree: {
+  type t = Leaf | Node(Belt.Array.t<Tree.t>)
+  let size: t => int
+} = {
+  type t = Leaf | Node(Belt.Array.t<Tree.t>)
+
+  let size = t =>
+    switch t {
+    | Leaf => 1
+    | Node(children) => Belt.Array.reduce(children, 1, (acc, c) => acc + Tree.size(c))
+    }
+}
+
+open Mocha
+open Test_utils
+
+describe(__MODULE__, () => {
+  test("alias chains", () => {
+    eq(__LOC__, [2, 3, 4], mapped)
+    eq(__LOC__, [10, 20], viaBelt)
+    eq(__LOC__, [0, 1], viaList)
+  })
+  test("functors and module types of dependencies", () => {
+    eq(__LOC__, [1, 2, 3], Belt.Set.toArray(set))
+    eq(__LOC__, 2, MyArray.length([1, 2]))
+  })
+  test("include and recursive modules", () => {
+    eq(__LOC__, 0, Extended.orZero(None))
+    eq(__LOC__, 3, Tree.size(Node([Leaf, Leaf])))
+  })
+})
diff --git a/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected b/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected
new file mode 100644
index 0000000000..5d692f6400
--- /dev/null
+++ b/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected
@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/dependency_functor_type_through_alias.res:9:17-25
+
+   7 │ 
+   8 │ let s = M.fromArray([1], ~id=module(IntCmp))
+   9 │ let n: string = M.size(s)
+  10 │ 
+
+  This has type: int
+  But it's expected to have type: string
+  
+  You can convert int to string with Int.toString.
\ No newline at end of file
diff --git a/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected b/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected
new file mode 100644
index 0000000000..3b616dc6aa
--- /dev/null
+++ b/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected
@@ -0,0 +1,11 @@
+
+  We've found a bug for you!
+  /.../fixtures/dependency_type_through_alias_chain.res:4:19-25
+
+  2 │ module B = A
+  3 │ 
+  4 │ let x: B.t<int> = list{1}
+  5 │ 
+
+  This has type: list<'a>
+  But it's expected to have type: B.t<int> (defined as array<int>)
\ No newline at end of file
diff --git a/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected b/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected
new file mode 100644
index 0000000000..8e9d6f4ee4
--- /dev/null
+++ b/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected
@@ -0,0 +1,11 @@
+
+  Warning number 3
+  /.../fixtures/deprecated_dependency_value_through_alias.res:4:12-18
+
+  2 │ module P = O
+  3 │ 
+  4 │ let kept = P.keepU(Some(1), x => x > 0)
+  5 │ 
+
+  deprecated: P.keepU
+  Use `keep` instead
\ No newline at end of file
diff --git a/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res b/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res
new file mode 100644
index 0000000000..75cb36569d
--- /dev/null
+++ b/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res
@@ -0,0 +1,9 @@
+module M = Belt.Set
+
+module IntCmp = Belt.Id.MakeComparable({
+  type t = int
+  let cmp = (a: int, b: int) => compare(a, b)
+})
+
+let s = M.fromArray([1], ~id=module(IntCmp))
+let n: string = M.size(s)
diff --git a/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res b/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res
new file mode 100644
index 0000000000..33035beb1f
--- /dev/null
+++ b/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res
@@ -0,0 +1,4 @@
+module A = Belt.Array
+module B = A
+
+let x: B.t<int> = list{1}
diff --git a/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res b/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res
new file mode 100644
index 0000000000..9b167286f9
--- /dev/null
+++ b/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res
@@ -0,0 +1,4 @@
+module O = Belt.Option
+module P = O
+
+let kept = P.keepU(Some(1), x => x > 0)
diff --git a/tests/ounit_tests/ounit_deferred_signature_tests.ml b/tests/ounit_tests/ounit_deferred_signature_tests.ml
new file mode 100644
index 0000000000..1033f56576
--- /dev/null
+++ b/tests/ounit_tests/ounit_deferred_signature_tests.ml
@@ -0,0 +1,211 @@
+(* The copy of a compilation unit's signature that [Env] makes when it is
+   first read is deferred when only [Env.normalize_path] asks for it: the
+   stamps and type ids it takes are reserved then and used when the copy is
+   made later. These tests check that a deferred copy, and everything created
+   between the reservation and the copy, gets exactly the stamps and type ids
+   it gets when the copy is made at once, for every interface of the runtime
+   and Belt (nested modules, functors, module types, aliases). *)
+
+open OUnit
+
+let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: ))
+
+let interface_dirs () =
+  let runtime = Runtime_package.get_path () in
+  let belt = Filename.concat (Filename.dirname runtime) "belt" in
+  List.filter Sys.file_exists
+    [
+      Filename.concat runtime "lib/rescript"; Filename.concat belt "lib/rescript";
+    ]
+
+let unit_names dirs =
+  List.concat_map
+    (fun dir ->
+      Sys.readdir dir |> Array.to_list
+      |> List.filter (fun file -> Filename.check_suffix file ".cmi")
+      |> List.map (fun file ->
+          (Cmi_format.read_cmi (Filename.concat dir file)).cmi_name))
+    dirs
+  |> List.sort_uniq compare
+
+let unit_path name = Path.Pident (Ident.create_persistent name)
+
+let probe () =
+  (Ident.binding_time (Ident.create "probe"), (Btype.newgenvar ()).Types.id)
+
+(* Ask whether every unit is an alias, creating an identifier and a type node
+   after each question, then read every signature in reverse order. With
+   [~eager], each signature is read before the question, so its copy is made
+   then, as before the copies were deferred. The result is marshalled: equal
+   strings mean equal stamps, type ids and sharing. *)
+let run ~eager dirs names =
+  Compiler_request_state.with_fresh (fun () ->
+      Request_local.with_fresh (fun () ->
+          Ident.with_fresh (fun () ->
+              Config.set_load_path dirs;
+              let env = Env.empty in
+              let asked =
+                List.map
+                  (fun name ->
+                    let path = unit_path name in
+                    if eager then ignore (Env.find_module path env);
+                    let normalized = Env.normalize_path None env path in
+                    (normalized, probe ()))
+                  names
+              in
+              let read =
+                (* [List.map] applies its function from the head: read the
+                   last unit's signature first. *)
+                List.map
+                  (fun name -> (Env.find_module (unit_path name) env).md_type)
+                  (List.rev names)
+              in
+              Marshal.to_string (asked, read, probe ()) [])))
+
+let deferred_copy_tests _ =
+  let dirs = interface_dirs () in
+  let names = unit_names dirs in
+  assert_bool "runtime interfaces found" (List.length names > 50);
+  (* The eager run also records how many stamps and ids each copy takes. *)
+  let eager = run ~eager:true dirs names in
+  let reserved_before, fallbacks_before =
+    Env.deferred_signature_copy_stats ()
+  in
+  let deferred = run ~eager:false dirs names in
+  let reserved_after, fallbacks_after = Env.deferred_signature_copy_stats () in
+  assert_equal ~printer:string_of_int ~msg:"every copy was deferred"
+    (List.length names)
+    (reserved_after - reserved_before);
+  assert_equal ~printer:string_of_int
+    ~msg:"every deferred copy took exactly its reserved stamps and type ids"
+    fallbacks_before fallbacks_after;
+  assert_bool
+    "deferred copies give the same stamps, type ids and graphs as eager ones"
+    (String.equal eager deferred)
+
+(* A copy that is never read still takes its stamps and ids. *)
+let unread_copy_tests _ =
+  let dirs = interface_dirs () in
+  let names = ["Stdlib_Array"; "Stdlib_List"; "Stdlib_Option"; "Stdlib"] in
+  let ask_only ~eager =
+    Compiler_request_state.with_fresh (fun () ->
+        Request_local.with_fresh (fun () ->
+            Ident.with_fresh (fun () ->
+                Config.set_load_path dirs;
+                List.map
+                  (fun name ->
+                    let path = unit_path name in
+                    if eager then ignore (Env.find_module path Env.empty);
+                    ignore (Env.normalize_path None Env.empty path);
+                    probe ())
+                  names)))
+  in
+  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;
+       ]
diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml
index d53bffff6c..3348a045e8 100644
--- a/tests/ounit_tests/ounit_tests_main.ml
+++ b/tests/ounit_tests/ounit_tests_main.ml
@@ -38,6 +38,7 @@ let suites =
       Ounit_compiler_request_tests.suites;
       Ounit_find_in_path_tests.suites;
       Ounit_build_file_store_tests.suites;
+      Ounit_deferred_signature_tests.suites;
     ]
 
 let _ = OUnit.run_test_tt_main suites