Fix DCE attribution for functors sharing a named module type

examples/regression/compilation_context/First.ml

@@ -0,0 +1 @@
+let g ?(opened = 0) () = opened

examples/regression/compilation_context/Native_provider.ml

@@ -0,0 +1,11 @@
+module type S = sig
+  val g : ?native:int -> unit -> int
+end
+
+module Arg : S = struct
+  let g ?(native = 0) () = native
+end
+
+module Make (M : S) = struct
+  let run () = M.g ~native:1 ()
+end

examples/regression/compilation_context/Native_use.ml

@@ -0,0 +1,3 @@
+module A = Native_provider.Make (Native_provider.Arg)
+
+let () = ignore (A.run ())

examples/regression/compilation_context/Nested_alias.ml

@@ -0,0 +1,10 @@
+module type S = sig
+  module N : sig
+    val f : unit -> int
+  end
+end
+
+module rec A : S = B
+and B : S = A
+
+module C = A.N

examples/regression/compilation_context/Opened.ml

@@ -0,0 +1,2 @@
+let run () = ignore (g ~opened:1 ())
+let () = run ()

examples/regression/compilation_context/Provider.mli

@@ -0,0 +1,7 @@
+module type S = sig
+  val g : ?context:int -> unit -> int
+end
+
+module Op (M : S) : sig
+  val run : unit -> int
+end

examples/regression/compilation_context/Relay.ml

@@ -0,0 +1 @@
+module Apply (M : Shared.S) = Shared.Apply (M)

examples/regression/compilation_context/Safe_alias.ml

@@ -0,0 +1,6 @@
+module type S = sig
+  val f : unit -> int
+end
+
+module rec A : S = B
+and B : S = A

examples/regression/compilation_context/Second.ml

@@ -0,0 +1 @@
+let g ?(opened = 0) () = opened + 1

examples/regression/compilation_context/Shared.ml

@@ -0,0 +1,19 @@
+module type S = sig
+  val g : ?context:int -> unit -> int
+end
+
+module Apply (M : S) = Provider.Op (M)
+module Curried (Ignored : S) (M : S) = Provider.Op (M)
+
+module Seed = struct
+  let g ?(context = 0) () = context
+end
+
+module Half = Curried (Seed)
+module Alias = Half
+
+module type FT = functor (M : S) -> sig
+  val run : unit -> int
+end
+
+let packed = (module Alias : FT)

examples/regression/compilation_context/Split.ml

@@ -0,0 +1,11 @@
+module type S = sig
+  val g : ?split:int -> unit -> int
+end
+
+module Used (_ : sig end) : S = struct
+  let g ?(split = 0) () = split
+end
+
+module Unused (_ : sig end) : S = struct
+  let g ?(split = 0) () = split + 1
+end

examples/regression/compilation_context/Split.mli

@@ -0,0 +1,6 @@
+module type S = sig
+  val g : ?split:int -> unit -> int
+end
+
+module Used (_ : sig end) : S
+module Unused (_ : sig end) : S

examples/regression/compilation_context/Split_use.ml

@@ -0,0 +1,4 @@
+module Chosen = Split.Used (struct end)
+module Unchosen = Split.Unused (struct end)
+
+let () = ignore (Chosen.g ~split:1 ())

examples/regression/compilation_context/a/Provider.ml

@@ -0,0 +1,7 @@
+module type S = sig
+  val g : ?context:int -> unit -> int
+end
+
+module Op (M : S) = struct
+  let run () = M.g ~context:1 ()
+end

examples/regression/compilation_context/a/Use_a.ml

@@ -0,0 +1,31 @@
+module Arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Applied = Shared.Apply (Arg)
+
+module Relayed_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Relayed = Relay.Apply (Relayed_arg)
+
+let () = ignore (Relayed.run ())
+let () = ignore (Applied.run ())
+
+module Partial_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Partial = Shared.Alias (Partial_arg)
+
+module Packed_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Unpacked = (val Shared.packed : Shared.FT)
+module Packed = Unpacked (Packed_arg)
+
+let () =
+  ignore (Partial.run ());
+  ignore (Packed.run ())

examples/regression/compilation_context/b/Provider.ml

@@ -0,0 +1,7 @@
+module type S = sig
+  val g : ?context:int -> unit -> int
+end
+
+module Op (M : S) = struct
+  let run () = M.g ()
+end

examples/regression/compilation_context/b/Use_b.ml

@@ -0,0 +1,31 @@
+module Arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Applied = Shared.Apply (Arg)
+
+module Relayed_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Relayed = Relay.Apply (Relayed_arg)
+
+let () = ignore (Relayed.run ())
+let () = ignore (Applied.run ())
+
+module Partial_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Partial = Shared.Alias (Partial_arg)
+
+module Packed_arg : Shared.S = struct
+  let g ?(context = 0) () = context
+end
+
+module Unpacked = (val Shared.packed : Shared.FT)
+module Packed = Unpacked (Packed_arg)
+
+let () =
+  ignore (Partial.run ());
+  ignore (Packed.run ())

examples/regression/digest_a/Collision.ml

@@ -0,0 +1,4 @@
+module type S = sig val g : ?x:int -> unit -> int end
+module Chosen_impl = struct let g ?(x = 0) () = x end
+module Target : S = Chosen_impl
+let marker_a = ()

examples/regression/digest_a/dune

@@ -0,0 +1,6 @@
+(library
+ (name digest_a)
+ (wrapped false)
+ (modes byte)
+ (modules Collision)
+ (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/digest_b/Collision.ml

@@ -0,0 +1,4 @@
+module type S = sig val g : ?x:int -> unit -> int end
+module Unrelated_impl = struct let g ?(x = 0) () = x end
+module Target : S = Unrelated_impl
+let marker_b = ()

examples/regression/digest_b/dune

@@ -0,0 +1,6 @@
+(library
+ (name digest_b)
+ (wrapped false)
+ (modes byte)
+ (modules Collision)
+ (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/digest_use/Use_collision.ml

@@ -0,0 +1 @@
+let () = ignore (Collision.Target.g ~x:1 ())

examples/regression/digest_use/dune

@@ -0,0 +1,7 @@
+(library
+ (name digest_use)
+ (wrapped false)
+ (modes byte)
+ (libraries digest_a)
+ (modules Use_collision)
+ (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/dup_a/Dup_shape.ml

@@ -0,0 +1,11 @@
+module A_chosen : Dup_sig.S with type t = int = struct
+  type t = int
+  let f x = x
+  let g x = x
+end
+
+module A_unused : Dup_sig.S with type t = int = struct
+  type t = int
+  let f x = x
+  let g x = x
+end

examples/regression/dup_a/Dup_shape.mli

@@ -0,0 +1,2 @@
+module A_chosen : Dup_sig.S with type t = int
+module A_unused : Dup_sig.S with type t = int

examples/regression/dup_a/dune

@@ -2,5 +2,5 @@
  (name dup_a)
  (wrapped false)
  (modes byte)
- (modules Dup_sig Dup_a_impl Dup_a_use)
+ (modules Dup_sig Dup_shape Dup_a_impl Dup_a_use)
  (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/dup_b/Dup_shape.ml

@@ -0,0 +1,6 @@
+module B_unused : Dup_sig.S with type t = int = struct
+  type t = int
+  let f x = x
+  let g x = x
+  let h x = x
+end

examples/regression/dup_b/Dup_shape.mli

@@ -0,0 +1 @@
+module B_unused : Dup_sig.S with type t = int

examples/regression/dup_b/dune

@@ -2,5 +2,5 @@
  (name dup_b)
  (wrapped false)
  (modes byte)
- (modules Dup_sig Dup_b_impl Dup_b_use)
+ (modules Dup_sig Dup_shape Dup_b_impl Dup_b_use)
  (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/dup_shape_use/Dup_shape_use.ml

@@ -0,0 +1,3 @@
+(* The consumer has no sibling Dup_shape: the importer digest must choose
+   dup_a and retain its implementation shape as well as its interface. *)
+let () = ignore (Dup_shape.A_chosen.f 1)

examples/regression/dup_shape_use/dune

@@ -0,0 +1,7 @@
+(library
+ (name dup_shape_use)
+ (wrapped false)
+ (modes byte)
+ (libraries dup_a)
+ (modules Dup_shape_use)
+ (flags :standard -w -27-32-34-37-39 -bin-annot))

examples/regression/duplicate_context/Shared.ml

@@ -0,0 +1,4 @@
+(* Both builds have the same source and inferred interface, but resolve
+   Provider.g against different imported interfaces. *)
+let run () = ignore (Provider.g ~x:1 ())
+let () = run ()

examples/regression/duplicate_context/a/Provider.ml

@@ -0,0 +1 @@
+let g ?(x = 0) () = x

examples/regression/duplicate_context/b/Provider.ml

@@ -0,0 +1 @@
+let g ?(x = 0) () = string_of_int x

examples/regression/duplicate_native/Duplicate_native.ml

@@ -0,0 +1,2 @@
+let g ?(x = 0) () = x
+let () = ignore (g ~x:1 ())

examples/regression/src/Attribution_sweep.ml

@@ -0,0 +1,106 @@
+module Repacked = struct
+  module type S = sig val g : ?repacked:int -> unit -> int end
+  module type FT = functor (M : S) -> sig val run : unit -> int end
+  module Make (M : S) = struct let run () = M.g ~repacked:1 () end
+  let first = (module Make : FT)
+  module First = (val first : FT)
+  let second = (module First : FT)
+  module Second = (val second : FT)
+  let third = (module Second : FT)
+  module Third = (val third : FT)
+  module Repacked_arg : S = struct let g ?(repacked = 0) () = repacked end
+  module Repacked_unused : S = struct let g ?(repacked = 0) () = repacked end
+  module Applied = Third (Repacked_arg)
+  let run () = ignore (Applied.run ()); ignore (Repacked_unused.g ())
+end
+
+module Projected = struct
+  module type S = sig val g : ?projected:int -> unit -> int end
+  module type FT = functor (M : S) -> sig val run : unit -> int end
+  module type Holder_t = sig module Inner : FT end
+  module Use (H : Holder_t) (M : S) = struct
+    module Applied = H.Inner (M)
+    let run = Applied.run
+  end
+  module Forward (H : Holder_t) (M : S) = Use (H) (M)
+  module Holder = struct
+    module Inner (M : S) = struct let run () = M.g ~projected:1 () end
+  end
+  module Projected_arg : S = struct let g ?(projected = 0) () = projected end
+  module Projected_unused : S = struct let g ?(projected = 0) () = projected end
+  module Applied = Forward (Holder) (Projected_arg)
+  let run () = ignore (Applied.run ()); ignore (Projected_unused.g ())
+end
+
+module Opaque_holder = struct
+  module type S = sig val g : ?opaque:int -> unit -> int end
+  module type FT = functor (M : S) -> sig val run : unit -> int end
+  module type Holder_t = sig module Inner : FT end
+  module Use (H : Holder_t) (M : S) = struct
+    module Applied = H.Inner (M)
+    let run = Applied.run
+  end
+  module Holder = struct
+    module Inner (M : S) = struct let run () = M.g ~opaque:1 () end
+  end
+  let packed = (module Holder : Holder_t)
+  module Opaque_arg : S = struct let g ?(opaque = 0) () = opaque end
+  module Applied = Use ((val packed : Holder_t)) (Opaque_arg)
+  module type Other = sig val h : ?untouched:int -> unit -> int end
+  module Never_applied (M : Other) = struct let run () = M.h ~untouched:1 () end
+  module Opaque_unrelated : Other = struct let h ?(untouched = 0) () = untouched end
+  let run () = ignore (Applied.run ()); ignore (Opaque_unrelated.h ())
+end
+
+module Partial_context = struct
+  module type S = sig val g : ?partial:int -> unit -> int end
+  module type FT = functor (M : S) -> sig val run : unit -> int end
+  module Supplied (M : S) = struct let run () = M.g ~partial:1 () end
+  module Omitted (M : S) = struct let run () = M.g () end
+  module Outer (F : FT) (M : S) = F (M)
+  module Partial_supplied_arg : S = struct let g ?(partial = 0) () = partial end
+  module Partial_omitted_arg : S = struct let g ?(partial = 0) () = partial end
+  module Supply = Outer (Supplied)
+  module Omit = Outer (Omitted)
+  module Applied_supply = Supply (Partial_supplied_arg)
+  module Applied_omit = Omit (Partial_omitted_arg)
+  module Invoke (F : FT) (M : S) = F (M)
+  module Passed_supplied_arg : S = struct let g ?(partial = 0) () = partial end
+  module Passed_omitted_arg : S = struct let g ?(partial = 0) () = partial end
+  module Passed_supply = Invoke (Supply) (Passed_supplied_arg)
+  module Passed_omit = Invoke (Omit) (Passed_omitted_arg)
+  let packed = (module Supply : FT)
+  module Repacked = (val packed : FT)
+  module Packed_partial_arg : S = struct let g ?(partial = 0) () = partial end
+  module Packed_supply = Repacked (Packed_partial_arg)
+  module With_unit (F : FT) () (M : S) = F (M)
+  module Unit_prefix = With_unit (Supplied)
+  module Unit_middle = Unit_prefix ()
+  module Unit_partial_arg : S = struct let g ?(partial = 0) () = partial end
+  module Unit_supply = Unit_middle (Unit_partial_arg)
+  module type Higher = functor (F : FT) -> FT
+  module Forward_partial (F : Higher) (G : FT) (M : S) = struct
+    module Half = F (G)
+    module Applied = Invoke (Half) (M)
+    let run = Applied.run
+  end
+  module Forwarded_supplied_arg : S = struct let g ?(partial = 0) () = partial end
+  module Forwarded_omitted_arg : S = struct let g ?(partial = 0) () = partial end
+  module Forwarded_supply = Forward_partial (Outer) (Supplied) (Forwarded_supplied_arg)
+  module Forwarded_omit = Forward_partial (Outer) (Omitted) (Forwarded_omitted_arg)
+  let run () =
+    ignore (Applied_supply.run ());
+    ignore (Applied_omit.run ());
+    ignore (Passed_supply.run ());
+    ignore (Passed_omit.run ());
+    ignore (Packed_supply.run ());
+    ignore (Unit_supply.run ());
+    ignore (Forwarded_supply.run ());
+    ignore (Forwarded_omit.run ())
+end
+
+let run () =
+  Repacked.run ();
+  Projected.run ();
+  Opaque_holder.run ();
+  Partial_context.run ()