diff --git a/examples/regression/compilation_context/First.ml b/examples/regression/compilation_context/First.ml new file mode 100644 index 00000000..4264a20c --- /dev/null +++ b/examples/regression/compilation_context/First.ml @@ -0,0 +1 @@ +let g ?(opened = 0) () = opened diff --git a/examples/regression/compilation_context/Native_provider.ml b/examples/regression/compilation_context/Native_provider.ml new file mode 100644 index 00000000..2b5f8461 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Native_use.ml b/examples/regression/compilation_context/Native_use.ml new file mode 100644 index 00000000..f9893c06 --- /dev/null +++ b/examples/regression/compilation_context/Native_use.ml @@ -0,0 +1,3 @@ +module A = Native_provider.Make (Native_provider.Arg) + +let () = ignore (A.run ()) diff --git a/examples/regression/compilation_context/Nested_alias.ml b/examples/regression/compilation_context/Nested_alias.ml new file mode 100644 index 00000000..56aa7dd9 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Opened.ml b/examples/regression/compilation_context/Opened.ml new file mode 100644 index 00000000..bfb3b594 --- /dev/null +++ b/examples/regression/compilation_context/Opened.ml @@ -0,0 +1,2 @@ +let run () = ignore (g ~opened:1 ()) +let () = run () diff --git a/examples/regression/compilation_context/Provider.mli b/examples/regression/compilation_context/Provider.mli new file mode 100644 index 00000000..18b630c4 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Relay.ml b/examples/regression/compilation_context/Relay.ml new file mode 100644 index 00000000..2b8221b3 --- /dev/null +++ b/examples/regression/compilation_context/Relay.ml @@ -0,0 +1 @@ +module Apply (M : Shared.S) = Shared.Apply (M) diff --git a/examples/regression/compilation_context/Safe_alias.ml b/examples/regression/compilation_context/Safe_alias.ml new file mode 100644 index 00000000..6fd99ab3 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Second.ml b/examples/regression/compilation_context/Second.ml new file mode 100644 index 00000000..a6ca4cd2 --- /dev/null +++ b/examples/regression/compilation_context/Second.ml @@ -0,0 +1 @@ +let g ?(opened = 0) () = opened + 1 diff --git a/examples/regression/compilation_context/Shared.ml b/examples/regression/compilation_context/Shared.ml new file mode 100644 index 00000000..5a6d0a80 --- /dev/null +++ b/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) diff --git a/examples/regression/compilation_context/Split.ml b/examples/regression/compilation_context/Split.ml new file mode 100644 index 00000000..077b5bbe --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Split.mli b/examples/regression/compilation_context/Split.mli new file mode 100644 index 00000000..2403b472 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/Split_use.ml b/examples/regression/compilation_context/Split_use.ml new file mode 100644 index 00000000..1cce0b75 --- /dev/null +++ b/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 ()) diff --git a/examples/regression/compilation_context/a/Provider.ml b/examples/regression/compilation_context/a/Provider.ml new file mode 100644 index 00000000..2027b359 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/a/Use_a.ml b/examples/regression/compilation_context/a/Use_a.ml new file mode 100644 index 00000000..09d04906 --- /dev/null +++ b/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 ()) diff --git a/examples/regression/compilation_context/b/Provider.ml b/examples/regression/compilation_context/b/Provider.ml new file mode 100644 index 00000000..3e1fc2a4 --- /dev/null +++ b/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 diff --git a/examples/regression/compilation_context/b/Use_b.ml b/examples/regression/compilation_context/b/Use_b.ml new file mode 100644 index 00000000..09d04906 --- /dev/null +++ b/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 ()) diff --git a/examples/regression/digest_a/Collision.ml b/examples/regression/digest_a/Collision.ml new file mode 100644 index 00000000..aa152b90 --- /dev/null +++ b/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 = () diff --git a/examples/regression/digest_a/dune b/examples/regression/digest_a/dune new file mode 100644 index 00000000..75b2e2dc --- /dev/null +++ b/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)) diff --git a/examples/regression/digest_b/Collision.ml b/examples/regression/digest_b/Collision.ml new file mode 100644 index 00000000..a4833ff0 --- /dev/null +++ b/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 = () diff --git a/examples/regression/digest_b/dune b/examples/regression/digest_b/dune new file mode 100644 index 00000000..d668f8a9 --- /dev/null +++ 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)) diff --git a/examples/regression/digest_use/Use_collision.ml b/examples/regression/digest_use/Use_collision.ml new file mode 100644 index 00000000..e756773e --- /dev/null +++ b/examples/regression/digest_use/Use_collision.ml @@ -0,0 +1 @@ +let () = ignore (Collision.Target.g ~x:1 ()) diff --git a/examples/regression/digest_use/dune b/examples/regression/digest_use/dune new file mode 100644 index 00000000..e8b4f7ee --- /dev/null +++ b/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)) diff --git a/examples/regression/dup_a/Dup_shape.ml b/examples/regression/dup_a/Dup_shape.ml new file mode 100644 index 00000000..4086961b --- /dev/null +++ b/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 diff --git a/examples/regression/dup_a/Dup_shape.mli b/examples/regression/dup_a/Dup_shape.mli new file mode 100644 index 00000000..ceb2c381 --- /dev/null +++ b/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 diff --git a/examples/regression/dup_a/dune b/examples/regression/dup_a/dune index 5b28eb9d..0ec61fd5 100644 --- a/examples/regression/dup_a/dune +++ b/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)) diff --git a/examples/regression/dup_b/Dup_shape.ml b/examples/regression/dup_b/Dup_shape.ml new file mode 100644 index 00000000..44a67a91 --- /dev/null +++ b/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 diff --git a/examples/regression/dup_b/Dup_shape.mli b/examples/regression/dup_b/Dup_shape.mli new file mode 100644 index 00000000..419bfecd --- /dev/null +++ b/examples/regression/dup_b/Dup_shape.mli @@ -0,0 +1 @@ +module B_unused : Dup_sig.S with type t = int diff --git a/examples/regression/dup_b/dune b/examples/regression/dup_b/dune index fe436bc6..6a3869a9 100644 --- a/examples/regression/dup_b/dune +++ b/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)) diff --git a/examples/regression/dup_shape_use/Dup_shape_use.ml b/examples/regression/dup_shape_use/Dup_shape_use.ml new file mode 100644 index 00000000..75f9fa60 --- /dev/null +++ b/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) diff --git a/examples/regression/dup_shape_use/dune b/examples/regression/dup_shape_use/dune new file mode 100644 index 00000000..b0b4557b --- /dev/null +++ b/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)) diff --git a/examples/regression/duplicate_context/Shared.ml b/examples/regression/duplicate_context/Shared.ml new file mode 100644 index 00000000..7ad40d1e --- /dev/null +++ b/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 () diff --git a/examples/regression/duplicate_context/a/Provider.ml b/examples/regression/duplicate_context/a/Provider.ml new file mode 100644 index 00000000..8ce17cfd --- /dev/null +++ b/examples/regression/duplicate_context/a/Provider.ml @@ -0,0 +1 @@ +let g ?(x = 0) () = x diff --git a/examples/regression/duplicate_context/b/Provider.ml b/examples/regression/duplicate_context/b/Provider.ml new file mode 100644 index 00000000..d3f72e42 --- /dev/null +++ b/examples/regression/duplicate_context/b/Provider.ml @@ -0,0 +1 @@ +let g ?(x = 0) () = string_of_int x diff --git a/examples/regression/duplicate_native/Duplicate_native.ml b/examples/regression/duplicate_native/Duplicate_native.ml new file mode 100644 index 00000000..210e3077 --- /dev/null +++ b/examples/regression/duplicate_native/Duplicate_native.ml @@ -0,0 +1,2 @@ +let g ?(x = 0) () = x +let () = ignore (g ~x:1 ()) diff --git a/examples/regression/src/Attribution_sweep.ml b/examples/regression/src/Attribution_sweep.ml new file mode 100644 index 00000000..fc4d9950 --- /dev/null +++ b/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 () diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml new file mode 100644 index 00000000..b570aaf8 --- /dev/null +++ b/examples/regression/src/Cross_alias.ml @@ -0,0 +1,57 @@ +(* An alias of a functor defined in another file, applied from a third. *) +module G = Shared_signature_arg.Apply_opt + +(* A partial application bound in this file, completed from another. *) +module GP = Shared_signature_arg.Apply2 (Shared_signature_arg.Chosen) + +module Outer_y (X : Shared_signature.S) = struct + let _ = X.f + include Cross_include.Helpers2 +end + +(* A unit application bound in this file, completed from another. *) +module GU = Shared_signature_arg.F_unit () + +(* A functor applied in another file, as an argument of a further functor. *) +module Mk_cross (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_cross_alias = Mk_cross + +(* A functor packed as a first-class module, unpacked and applied from + another file. *) +module Impl_cross_fc (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +let packed_cross = (module Impl_cross_fc : Higher_order.Opt_functor) + +module Outer_cross_ho (F : Higher_order.Opt_functor) (M : Shared_signature.O) = +struct + module A = F (M) + + let run () = A.run () +end + +(* Packed by a consumer in another compilation unit: chasing the alias's + local path requires this unit's resolver. *) +module type Escaped_arg = sig + val k : ?cross:int -> unit -> int +end + +module type Escaped_holder_type = sig + module Inner : functor (M : Escaped_arg) -> sig + val run : unit -> int + end +end + +module Escaped_inner (M : Escaped_arg) = struct + let run () = M.k ~cross:1 () +end + +module Escaped_holder = struct + module Inner = Escaped_inner +end + +module Escaped_alias = Escaped_holder diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml new file mode 100644 index 00000000..c7fb046b --- /dev/null +++ b/examples/regression/src/Cross_alias_use.ml @@ -0,0 +1,68 @@ +module Opt_cross : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross = Cross_alias.G (Opt_cross) + +let run () = ignore (Applied_cross.run ()) + +module Opt_cross_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_partial = Cross_alias.GP (Opt_cross_partial) + +let run_partial () = ignore (Applied_cross_partial.run ()) + +module Opt_cross_incl : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_x = Cross_include.Outer_x (Shared_signature_arg.Chosen) +module Applied_cross_incl = Applied_outer_x.Inner (Opt_cross_incl) + +let run_incl () = ignore (Applied_cross_incl.run ()) + +module Opt_y : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_y = Cross_alias.Outer_y (Shared_signature_arg.Chosen) +module Applied_y = Applied_outer_y.Inner2 (Opt_y) + +let run_y () = ignore (Applied_y.run ()) + +module Opt_cross_unit : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_cross_unit2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_unit = Cross_alias.GU (Opt_cross_unit) +module Applied_cross_unit2 = Shared_signature_arg.F_unit () (Opt_cross_unit2) + +module Applied_app_cross = + Shared_signature_arg.Use_o (Cross_alias.Mk_cross (Shared_signature_arg.Chosen)) + +let run_unit () = + ignore + (Applied_cross_unit.run () + Applied_cross_unit2.run () + + Applied_app_cross.run ()) + +(* An applied functor aliased in another file. *) +module Applied_app_cross_alias = + Shared_signature_arg.Use_o + (Cross_alias.Mk_cross_alias (Shared_signature_arg.Chosen)) + +let run_alias_app () = ignore (Applied_app_cross_alias.run ()) + +module Opt_cross_fc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_fc = + (val Cross_alias.packed_cross : Higher_order.Opt_functor) (Opt_cross_fc) + +let run_fc () = ignore (Applied_cross_fc.run ()) diff --git a/examples/regression/src/Cross_c.ml b/examples/regression/src/Cross_c.ml new file mode 100644 index 00000000..3ac16bc1 --- /dev/null +++ b/examples/regression/src/Cross_c.ml @@ -0,0 +1,5 @@ +(* A functor defined in a third unit, reached through an alias in a second + unit's included module, from a first unit's functor result. *) +module F (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end diff --git a/examples/regression/src/Cross_include.ml b/examples/regression/src/Cross_include.ml new file mode 100644 index 00000000..08386c9b --- /dev/null +++ b/examples/regression/src/Cross_include.ml @@ -0,0 +1,18 @@ +(* A functor whose result obtains a nested functor through an include of a + module local to this file; applied from another file. *) +module Helpers = struct + module Inner (B : Shared_signature.O) = struct + let run () = B.g ~x:1 () + end +end + +module Outer_x (A : Shared_signature.S) = struct + let _ = A.f + include Helpers +end + +module Local_f = Cross_c.F + +module Helpers2 = struct + module Inner2 = Local_f +end diff --git a/examples/regression/src/Escape_exports.ml b/examples/regression/src/Escape_exports.ml new file mode 100644 index 00000000..617a1c84 --- /dev/null +++ b/examples/regression/src/Escape_exports.ml @@ -0,0 +1,61 @@ +(* The escaping holder's lexical range does not contain the functor it + exports. Both aliases and includes must carry that definition with it. *) +module type Alias_arg = sig + val g : ?alias:int -> unit -> int +end + +module type Alias_holder = sig + module Inner : functor (M : Alias_arg) -> sig + val run : unit -> int + end +end + +module Alias_inner (M : Alias_arg) = struct + let run () = M.g ~alias:1 () +end + +module Holder_alias = struct + module Inner = Alias_inner +end + +module Escaped_alias_arg : Alias_arg = struct + let g ?(alias = 0) () = alias +end + +let packed_alias = (module Holder_alias : Alias_holder) + +let apply_alias (module H : Alias_holder) = + let module A = H.Inner (Escaped_alias_arg) in + A.run () + +module type Include_arg = sig + val g : ?included:int -> unit -> int +end + +module type Include_holder = sig + module Inner : functor (M : Include_arg) -> sig + val run : unit -> int + end +end + +module Included = struct + module Inner (M : Include_arg) = struct + let run () = M.g ~included:1 () + end +end + +module Holder_include = struct + include Included +end + +module Escaped_include_arg : Include_arg = struct + let g ?(included = 0) () = included +end + +let packed_include = (module Holder_include : Include_holder) + +let apply_include (module H : Include_holder) = + let module A = H.Inner (Escaped_include_arg) in + A.run () + +let run () = ignore (apply_alias packed_alias + apply_include packed_include) diff --git a/examples/regression/src/Escaped_coercion.ml b/examples/regression/src/Escaped_coercion.ml new file mode 100644 index 00000000..64c08acf --- /dev/null +++ b/examples/regression/src/Escaped_coercion.ml @@ -0,0 +1,79 @@ +module Escaped_only = struct + module type Arg = sig + val needed : unit -> int + val unused : unit -> int + end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Possible_arg : Arg = struct + let needed () = 1 + let unused () = 2 + end + let registry = [(module Outer : FT)] + let run () = ignore (List.length registry) +end + +module Known_and_escaped = struct + module type Arg = sig + val needed : unit -> int + val unused : unit -> int + end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Known_arg : Arg = struct + let needed () = 1 + let unused () = 2 + end + module Possible_arg : Arg = struct + let needed () = 3 + let unused () = 4 + end + module Applied = Outer (Known_arg) + let registry = [(module Outer : FT)] + let run () = ignore (Applied.run ()); ignore (List.length registry) +end + +module Never_applied = struct + module type Arg = sig val needed : unit -> int end + module Inner (M : Arg) = struct let run () = M.needed () end + module Outer (M : Arg) = Inner (M) + module Unrelated_arg : Arg = struct let needed () = 1 end +end + +module Known_only = struct + module type Arg = sig val needed : unit -> int end + module Inner (M : Arg) = struct let run () = M.needed () end + module Outer (M : Arg) = Inner (M) + module Known_arg : Arg = struct let needed () = 1 end + module Unrelated_arg : Arg = struct let needed () = 2 end + module Applied = Outer (Known_arg) + let run () = ignore (Applied.run ()) +end + +module Nested_stored = struct + module type Item = sig val needed : unit -> int val unused : unit -> int end + module type Arg = sig module N : Item end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M.N) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Possible_arg : Arg = struct + module N = struct let needed () = 1 let unused () = 2 end + end + let packed = (module Outer : FT) + let registry = [packed] + let run () = ignore (List.length registry) +end + +let run () = + Escaped_only.run (); + Known_and_escaped.run (); + Known_only.run (); + Nested_stored.run () diff --git a/examples/regression/src/Higher_order.ml b/examples/regression/src/Higher_order.ml new file mode 100644 index 00000000..30c4f6c3 --- /dev/null +++ b/examples/regression/src/Higher_order.ml @@ -0,0 +1,258 @@ +(* Higher-order functors: a functor passed as an argument and applied inside + the body, to a parameter, to a fixed module, to a submodule of a + parameter, through an alias of the functor parameter, in an [include], + partially applied beforehand, through two levels, and first-class modules + as head and as argument. [Opt_none_ho] is called directly only and keeps + its never-used argument. *) +module type Opt_functor = functor (M : Shared_signature.O) -> sig + val run : unit -> int +end + +module Impl (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fixed (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_sub (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_alias (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_incl (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_partial (A : Shared_signature.S) (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + A.f () +end + +module Impl_2 (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fc (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fca (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_twice_a (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_twice_b (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Opt_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fixed : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sub_holder = struct + module Sub : Shared_signature.O = struct + let g ?(x = 0) () = x + end +end + +module Opt_alias_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_incl_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_partial_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fca : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_twice : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_none_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer (F : Opt_functor) (M : Shared_signature.O) = struct + module A = F (M) + + let run () = A.run () +end + +module Applied_ho = Outer (Impl) (Opt_ho) + +module Outer_fixed (F : Opt_functor) = struct + module A = F (Opt_fixed) + + let run () = A.run () +end + +module Applied_fixed = Outer_fixed (Impl_fixed) + +module Outer_sub (F : Opt_functor) (H : sig + module Sub : Shared_signature.O +end) = +struct + module A = F (H.Sub) + + let run () = A.run () +end + +module Applied_sub = Outer_sub (Impl_sub) (Opt_sub_holder) + +module Outer_alias (F : Opt_functor) (M : Shared_signature.O) = struct + module G = F + module A = G (M) + + let run () = A.run () +end + +module Applied_alias = Outer_alias (Impl_alias) (Opt_alias_ho) + +module Outer_incl (F : Opt_functor) (M : Shared_signature.O) = struct + include F (M) +end + +module Applied_incl = Outer_incl (Impl_incl) (Opt_incl_ho) +module Applied_partial = Outer (Impl_partial (Shared_signature_arg.Chosen)) (Opt_partial_ho) + +module Outer2 (F : Opt_functor) (M : Shared_signature.O) = struct + module A = Outer (F) (M) + + let run () = A.run () +end + +module Applied_2 = Outer2 (Impl_2) (Opt_2) + +let impl_fc = (module Impl_fc : Opt_functor) + +module Applied_fc = (val impl_fc : Opt_functor) (Opt_fc) + +let opt_fca = (module Opt_fca : Shared_signature.O) + +module Applied_fca = Impl_fca ((val opt_fca : Shared_signature.O)) +module Applied_twice_a = Outer (Impl_twice_a) (Opt_twice) +module Applied_twice_b = Outer (Impl_twice_b) (Opt_twice) + +let run () = + ignore + (Applied_ho.run () + Applied_fixed.run () + Applied_sub.run () + + Applied_alias.run () + Applied_incl.run () + Applied_partial.run () + + Applied_2.run () + Applied_fc.run () + Applied_fca.run () + + Applied_twice_a.run () + Applied_twice_b.run () + Opt_none_ho.g ()) + +(* Inline functors returning their parameter, a submodule of it, or a + functor applied to it: the actual argument is what flows on. [Id_unused] + is never passed and stays dead; [Opt_id]'s call is credited to it only. *) +module Id_used : Shared_signature.S = struct + let f () = 70 +end + +module Id_sub_holder = struct + module Sub : Shared_signature.S = struct + let f () = 71 + end +end + +module Id_app : Shared_signature.S = struct + let f () = 72 +end + +module Id_curried : Shared_signature.S = struct + let f () = 73 +end + +module Id_unused : Shared_signature.S = struct + let f () = 74 +end + +module Opt_id : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Use_s (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied_id = Use_s ((functor (A : Shared_signature.S) -> A) (Id_used)) + +module Applied_id_sub = + Use_s + ((functor (H : sig + module Sub : Shared_signature.S + end) -> H.Sub) + (Id_sub_holder)) + +module Applied_id_app = + Use_s + ((functor (A : Shared_signature.S) -> Shared_signature_arg.Mk_s (A)) + (Id_app)) + +module Applied_id_curried = + Use_s + ((functor (A : Shared_signature.S) (B : Shared_signature.S) -> B) + (Id_used) + (Id_curried)) + +module Applied_opt_id = + Shared_signature_arg.Use_o ((functor (A : Shared_signature.O) -> A) (Opt_id)) + +let run_id () = + ignore + (Applied_id.run () + Applied_id_sub.run () + Applied_id_app.run () + + Applied_id_curried.run () + Applied_opt_id.run ()) + +(* A functor escaping as a first-class module passed to a function: its + applications cannot be seen, so its calls are forwarded to every + implementation of the item, conservatively. [P_esc] must not be reported + as never supplying [y]. *) +module type P = sig + val h : ?y:int -> unit -> int +end + +module type P_functor = functor (M : P) -> sig + val run : unit -> int +end + +module Impl_esc (M : P) = struct + let run () = M.h ~y:1 () +end + +module P_esc : P = struct + let h ?(y = 0) () = y +end + +module P_other : P = struct + let h ?(y = 0) () = y +end + +let apply_packed (module F : P_functor) = + let module A = F (P_esc) in + A.run () + +let run_esc () = ignore (apply_packed (module Impl_esc) + P_other.h ()) diff --git a/examples/regression/src/Higher_order_fixpoint.ml b/examples/regression/src/Higher_order_fixpoint.ml new file mode 100644 index 00000000..6873163e --- /dev/null +++ b/examples/regression/src/Higher_order_fixpoint.ml @@ -0,0 +1,45 @@ +(* The indirect application of Outer becomes known after its body has + already been instantiated for the direct application. *) +module type Arg = sig + val g : ?y:int -> unit -> int +end + +module type FT = functor (M : Arg) -> sig + val run : unit -> int +end + +module type Higher = functor (F : FT) (M : Arg) -> sig + val run : unit -> int +end + +module Impl_a (M : Arg) = struct + let run () = M.g ~y:1 () +end + +module Impl_b (M : Arg) = struct + let run () = M.g ~y:2 () +end + +module Impl_c (M : Arg) = struct + let run () = M.g () +end + +module Fixpoint_a : Arg = struct + let g ?(y = 0) () = y +end + +module Fixpoint_b : Arg = struct + let g ?(y = 0) () = y +end + +module Fixpoint_c : Arg = struct + let g ?(y = 0) () = y +end + +module Outer (F : FT) (M : Arg) = F (M) +module Top (H : Higher) (F : FT) (M : Arg) = H (F) (M) +module Direct = Outer (Impl_a) (Fixpoint_a) +module Indirect = Top (Outer) (Impl_b) (Fixpoint_b) +module Indirect_c = Top (Outer) (Impl_c) (Fixpoint_c) + +let run () = ignore (Direct.run () + Indirect.run () + Indirect_c.run ()) diff --git a/examples/regression/src/Higher_order_more.ml b/examples/regression/src/Higher_order_more.ml new file mode 100644 index 00000000..c11b8554 --- /dev/null +++ b/examples/regression/src/Higher_order_more.ml @@ -0,0 +1,171 @@ +(* A functor whose body is directly the application of its functor + parameter, and a higher-order functor from another file applied here to a + functor from a third file. *) +module Opt_direct_body : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_cross_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Impl_direct_body (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Outer_direct (F : Higher_order.Opt_functor) (M : Shared_signature.O) = + F (M) + +module Applied_direct_body = Outer_direct (Impl_direct_body) (Opt_direct_body) + +module Applied_cross_ho = + Cross_alias.Outer_cross_ho (Shared_signature_arg.Impl_third) (Opt_cross_ho) + +let run () = ignore (Applied_direct_body.run () + Applied_cross_ho.run ()) + +(* The functor parameter's type written inline rather than named: the + passed functor's values, used through the parameter, stay live. *) +module Opt_anon : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Impl_anon (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + let helper () = 1 +end + +module Outer_anon + (F : functor (M : Shared_signature.O) -> sig + val run : unit -> int + end) + (M : Shared_signature.O) = +struct + module A = F (M) + + let run () = A.run () +end + +module Applied_anon = Outer_anon (Impl_anon) (Opt_anon) + +let run_anon () = ignore (Applied_anon.run ()) + +(* Functors reached through something whose applications cannot be seen: + nested in a module packed as a first-class value, and nested in the + result of a functor parameter applied in the body. Their calls are + forwarded conservatively: the arguments must not be reported as never + supplying the argument. *) +module type P2 = sig + val k : ?z:int -> unit -> int +end + +module type Holder_t = sig + module Inner : functor (M : P2) -> sig + val run : unit -> int + end +end + +module Holder = struct + module Inner (M : P2) = struct + let run () = M.k ~z:1 () + end +end + +module P2_esc : P2 = struct + let k ?(z = 0) () = z +end + +(* Escaping through a long, acyclic alias chain must still retain Inner's + calls. This exceeds the former fixed definition-lookup depth limit. *) +module Holder1 = Holder +module Holder2 = Holder1 +module Holder3 = Holder2 +module Holder4 = Holder3 +module Holder5 = Holder4 +module Holder6 = Holder5 +module Holder7 = Holder6 +module Holder8 = Holder7 +module Holder9 = Holder8 +module Holder10 = Holder9 + +let packed_holder = (module Holder10 : Holder_t) + +let apply_holder (module H : Holder_t) = + let module A = H.Inner (P2_esc) in + A.run () + +module Cross_esc : Cross_alias.Escaped_arg = struct + let k ?(cross = 0) () = cross +end + +let packed_cross_holder = + (module Cross_alias.Escaped_alias : Cross_alias.Escaped_holder_type) + +let apply_cross_holder (module H : Cross_alias.Escaped_holder_type) = + let module A = H.Inner (Cross_esc) in + A.run () + +module type P3 = sig + val q : ?w:int -> unit -> int +end + +module type Gi_t = functor (A : Shared_signature.S) -> sig + module Inner : functor (M : P3) -> sig + val run : unit -> int + end +end + +module Impl_gi (A : Shared_signature.S) = struct + module Inner (M : P3) = struct + let run () = M.q ~w:1 () + A.f () + end +end + +module P3_esc : P3 = struct + let q ?(w = 0) () = w +end + +module Outer_gi (F : Gi_t) (M : P3) = struct + module G = F (Shared_signature_arg.Chosen) + module A = G.Inner (M) + + let run () = A.run () +end + +module Applied_gi = Outer_gi (Impl_gi) (P3_esc) + +let run_nested () = + ignore + (apply_holder packed_holder + apply_cross_holder packed_cross_holder + + Applied_gi.run ()) + +(* A functor applied directly and also packed into a value that flows + through a function: the unseen application means its calls are forwarded, + so the second argument is not reported as never supplying [v]. *) +module type P4 = sig + val u : ?v:int -> unit -> int +end + +module type P4_functor = functor (M : P4) -> sig + val run : unit -> int +end + +module Impl_both (M : P4) = struct + let run () = M.u ~v:1 () +end + +module P4_a : P4 = struct + let u ?(v = 0) () = v +end + +module P4_b : P4 = struct + let u ?(v = 0) () = v +end + +module Applied_both_a = Impl_both (P4_a) + +let packed_both = (module Impl_both : P4_functor) +let through f = f + +module Applied_both_b = (val through packed_both : P4_functor) (P4_b) + +let run_both () = ignore (Applied_both_a.run () + Applied_both_b.run ()) diff --git a/examples/regression/src/Included_sig.ml b/examples/regression/src/Included_sig.ml new file mode 100644 index 00000000..0f47ae35 --- /dev/null +++ b/examples/regression/src/Included_sig.ml @@ -0,0 +1,39 @@ +module type S = sig + val f : unit -> int +end + +module M : S = struct + let f () = 5 +end + +module W = struct + type t = int + + module type S2 = sig + val f : unit -> int + end + + module X = struct + let f () = 7 + end +end + +module W2 = struct + module type S = sig + val f : unit -> int + end + + module X = struct + let f () = 8 + end +end + +module W3 = struct + module type S3 = sig + val f : unit -> int + end + + module X : S3 = struct + let f () = 9 + end +end diff --git a/examples/regression/src/Included_sig.mli b/examples/regression/src/Included_sig.mli new file mode 100644 index 00000000..e1dd2e19 --- /dev/null +++ b/examples/regression/src/Included_sig.mli @@ -0,0 +1,37 @@ +include sig + module type S = sig + val f : unit -> int + end + + module M : S +end + +module W : sig + type t + + module type S2 = sig + val f : unit -> int + end + + module X : S2 +end +with type t = int + +module W2 : sig + module type S + + module X : S +end +with module type S = sig + val f : unit -> int +end + +module W3 : module type of struct + module type S3 = sig + val f : unit -> int + end + + module X : S3 = struct + let f () = 9 + end +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 41f2ad56..475f3ab9 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -1,8 +1,69 @@ let definitely_dead () = () let () = + Review_round.run (); + Nested_arguments.run (); + Attribution_sweep.run (); + Escaped_coercion.run (); + Partial_context_use.run (); Live_ancestors.use_child (); Functor_argument.use_set (); Functor_argument.use_anonymous_set (); Local_side_effects.start (); - Ocaml_compiler_compat.run () + Ocaml_compiler_compat.run (); + Shared_signature_use.run (); + Shared_signature_arg.run (); + Shared_signature_arg.run_more (); + Shared_signature_arg.run_even_more (); + Shared_signature_arg.run_sig (); + Shared_signature_arg.run_partial (); + Shared_signature_arg.run_alias (); + Shared_signature_arg.run_forwarded (); + Nested_module_type.run (); + Shared_signature_arg.run_shadow (); + Shared_signature_arg.run_nested (); + Shared_signature_arg.run_chain (); + Cross_alias_use.run (); + Cross_alias_use.run_partial (); + Cross_alias_use.run_incl (); + Cross_alias_use.run_y (); + Shared_signature_arg.run_local_partial (); + ignore (Included_sig.M.f ()); + ignore (Included_sig.W.X.f ()); + Shared_signature_arg.run_alias9 (); + Shared_signature_arg.run_ext (); + Shared_signature_arg.run_shadow_rec (); + ignore (Included_sig.W2.X.f ()); + ignore (Included_sig.W3.X.f ()); + Shared_signature_arg.run_incl_f (); + Shared_signature_arg.run_rec_chain (); + Shared_signature_arg.run_mt (); + Shared_signature_arg.run_param_mt (); + Shared_signature_arg.run_param_mt2 (); + Shared_signature_arg.run_u (); + Shared_signature_arg.run_recfwd (); + Shared_signature_arg.run_sweep (); + Shared_signature_arg.run_ord (); + Shared_signature_arg.run_ord2 (); + Shared_signature_arg.run_ranges (); + Shared_signature_arg.run_constrained (); + Shared_signature_arg.run_unit (); + Shared_signature_arg.run_app (); + Cross_alias_use.run_unit (); + Shared_signature_arg.run_app2 (); + Cross_alias_use.run_alias_app (); + Higher_order.run (); + Higher_order.run_id (); + Higher_order.run_esc (); + Cross_alias_use.run_fc (); + Higher_order_more.run (); + Higher_order_more.run_anon (); + Higher_order_more.run_nested (); + Higher_order_more.run_both (); + Reference_order.run (); + Higher_order_fixpoint.run (); + Packed_interface_use.run (); + Escape_exports.run (); + Unpacked_functor_use.run (); + Unpacked_include.run (); + Unpacked_open.run () diff --git a/examples/regression/src/Nested_arguments.ml b/examples/regression/src/Nested_arguments.ml new file mode 100644 index 00000000..247787de --- /dev/null +++ b/examples/regression/src/Nested_arguments.ml @@ -0,0 +1,74 @@ +module type N = sig + val g : ?nested_arg:int -> unit -> int +end + +module type S = sig + module N : N +end + +module F (M : S) = struct + let run () = M.N.g ~nested_arg:1 () +end + +module Known : S = struct + module N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +module A = F (Known) + +module B = F (struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end) + +module C = F (struct + module Actual : N = struct + let g ?(nested_arg = 0) () = nested_arg + end + + module N = Actual +end) + +module D = F (struct + include struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end + end +end) + +module Packed_arg = struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +let packed = (module Packed_arg : S) + +module E = F ((val packed : S)) + +module Unrelated : S = struct + module N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +module Foreign (M : Nested_arguments_packed.S) = struct + let run () = M.N.g ~foreign_nested:1 () +end + +module Imported = + Foreign ((val Nested_arguments_packed.packed : Nested_arguments_packed.S)) + +let run () = + ignore (Imported.run ()); + Nested_arguments_packed.run (); + ignore (A.run ()); + ignore (B.run ()); + ignore (C.run ()); + ignore (D.run ()); + ignore (E.run ()); + ignore (Unrelated.N.g ()) diff --git a/examples/regression/src/Nested_arguments_packed.ml b/examples/regression/src/Nested_arguments_packed.ml new file mode 100644 index 00000000..6c9ac58f --- /dev/null +++ b/examples/regression/src/Nested_arguments_packed.ml @@ -0,0 +1,23 @@ +module type N = sig + val g : ?foreign_nested:int -> unit -> int +end + +module type S = sig + module N : N +end + +module Actual : S = struct + module N : N = struct + let g ?(foreign_nested = 0) () = foreign_nested + end +end + +let packed = (module Actual : S) + +module Unrelated : S = struct + module N = struct + let g ?(foreign_nested = 0) () = foreign_nested + end +end + +let run () = ignore (Unrelated.N.g ()) diff --git a/examples/regression/src/Nested_module_type.ml b/examples/regression/src/Nested_module_type.ml new file mode 100644 index 00000000..49b51d0f --- /dev/null +++ b/examples/regression/src/Nested_module_type.ml @@ -0,0 +1,17 @@ +(* A named module type declared inside a module: its items must not count as + declarations, so [Unused.f] is reported dead and [Used.f] live. *) +module Outer = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 1 + end + + module Unused : S = struct + let f () = 2 + end +end + +let run () = ignore (Outer.Used.f ()) diff --git a/examples/regression/src/Packed_interface.ml b/examples/regression/src/Packed_interface.ml new file mode 100644 index 00000000..6e759179 --- /dev/null +++ b/examples/regression/src/Packed_interface.ml @@ -0,0 +1,5 @@ +module Impl (M : Packed_types.Arg) = struct + let run () = M.g ~x:1 () +end + +let packed = (module Impl : Packed_types.FT) diff --git a/examples/regression/src/Packed_interface.mli b/examples/regression/src/Packed_interface.mli new file mode 100644 index 00000000..0bbc79e9 --- /dev/null +++ b/examples/regression/src/Packed_interface.mli @@ -0,0 +1 @@ +val packed : (module Packed_types.FT) diff --git a/examples/regression/src/Packed_interface_use.ml b/examples/regression/src/Packed_interface_use.ml new file mode 100644 index 00000000..fd0a21f6 --- /dev/null +++ b/examples/regression/src/Packed_interface_use.ml @@ -0,0 +1,8 @@ +module Packed_arg : Packed_types.Arg = struct + let g ?(x = 0) () = x +end + +module Outer (F : Packed_types.FT) (M : Packed_types.Arg) = F (M) +module A = Outer ((val Packed_interface.packed : Packed_types.FT)) (Packed_arg) + +let run () = ignore (A.run ()) diff --git a/examples/regression/src/Packed_types.ml b/examples/regression/src/Packed_types.ml new file mode 100644 index 00000000..bb958165 --- /dev/null +++ b/examples/regression/src/Packed_types.ml @@ -0,0 +1,7 @@ +module type Arg = sig + val g : ?x:int -> unit -> int +end + +module type FT = functor (M : Arg) -> sig + val run : unit -> int +end diff --git a/examples/regression/src/Partial_context_use.ml b/examples/regression/src/Partial_context_use.ml new file mode 100644 index 00000000..dd79b114 --- /dev/null +++ b/examples/regression/src/Partial_context_use.ml @@ -0,0 +1,6 @@ +module P = Attribution_sweep.Partial_context +module Foreign_supplied_arg : P.S = struct let g ?(partial = 0) () = partial end +module Foreign_omitted_arg : P.S = struct let g ?(partial = 0) () = partial end +module Supplied = P.Supply (Foreign_supplied_arg) +module Omitted = P.Omit (Foreign_omitted_arg) +let run () = ignore (Supplied.run ()); ignore (Omitted.run ()) diff --git a/examples/regression/src/Reference_order.ml b/examples/regression/src/Reference_order.ml new file mode 100644 index 00000000..d068a8ae --- /dev/null +++ b/examples/regression/src/Reference_order.ml @@ -0,0 +1,55 @@ +(* An ordinary unresolved reference must remain forwardable even when a + parameter reference to the same item is visited later in the binding. *) +module Parameter_first = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 11 + end + + module Param : S = struct + let f () = 12 + end + + let packed = (module Used : S) + let through x = x + + module F (M : S) = struct + let run () = + let module N = (val through packed : S) in + ignore (M.f ()); + N.f () + end + + module A = F (Param) +end + +module Ordinary_first = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 21 + end + + module Param : S = struct + let f () = 22 + end + + let packed = (module Used : S) + let through x = x + + module F (M : S) = struct + let run () = + let module N = (val through packed : S) in + ignore (N.f ()); + M.f () + end + + module A = F (Param) +end + +let run () = ignore (Parameter_first.A.run () + Ordinary_first.A.run ()) diff --git a/examples/regression/src/Review_round.ml b/examples/regression/src/Review_round.ml new file mode 100644 index 00000000..d91f6318 --- /dev/null +++ b/examples/regression/src/Review_round.ml @@ -0,0 +1,189 @@ +module Mixed_holders = struct + module type S = sig + val g : ?mixed:int -> unit -> int + end + + module type Holder = sig + module Inner (M : S) : sig + val run : unit -> int + end + end + + module Apply (H : Holder) (M : S) = struct + module A = H.Inner (M) + + let run = A.run + end + + module Known = struct + module Inner (M : S) = struct + let run () = M.g ~mixed:1 () + end + end + + module Known_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Anonymous_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Included_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Omitted_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Unrelated_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module A = Apply (Known) (Known_arg) + + module B = + Apply + (struct + module Inner (M : S) = struct + let run () = M.g ~mixed:1 () + end + end) + (Anonymous_arg) + + module C = + Apply + (struct + module Nested = struct + module F (M : S) = struct + let run () = M.g ~mixed:1 () + end + end + + include struct + module Inner = Nested.F + end + end) + (Included_arg) + + module D = + Apply + (struct + module Inner (M : S) = struct + let run () = M.g () + end + end) + (Omitted_arg) + + let run () = + ignore (A.run ()); + ignore (B.run ()); + ignore (C.run ()); + ignore (D.run ()); + ignore (Unrelated_arg.g ()) +end + +module Partial_result = struct + module type S = sig end + + module type FT = functor (M : S) (N : S) -> sig + val run : ?result:int -> unit -> int + val unused : unit -> int + end + + module type Half = functor (N : S) -> sig + val run : ?result:int -> unit -> int + val unused : unit -> int + end + + module F (M : S) (N : S) = struct + let run ?(result = 0) () = result + let unused () = 0 + end + + let packed = (module F : FT) + + module G = (val packed : FT) + module H = G (struct end) + + let repacked = (module H : Half) + + module I = (val repacked : Half) + module J = I (struct end) + module K = H (struct end) + + (* Two paths reach the same implementation; neither may duplicate calls. *) + let run () = + ignore (J.run ~result:1 ()); + ignore (K.run ~result:2 ()) +end + +module Local_alias = struct + module type S = sig + val g : ?local_alias:int -> unit -> int + end + + module type Holder_t = sig + module Inner (M : S) : sig + val run : unit -> int + end + end + + module Holder = struct + module Inner (M : S) = struct + let run () = M.g ~local_alias:1 () + end + end + + let packed = (module Holder : Holder_t) + + module Arg : S = struct + let g ?(local_alias = 0) () = local_alias + end + + let run () = + let open (val packed : Holder_t) in + let module Alias = Inner in + let module A = Alias (Arg) in + ignore (A.run ()) +end + +module Recursive_alias = struct + module type S = sig + val g : ?recursive_alias: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 Holder = struct + module Inner (M : S) = struct + let run () = M.g ~recursive_alias:1 () + end + end + + let packed = (module Holder : Holder_t) + + open (val packed : Holder_t) + module rec Alias : FT = Inner + + module Arg : S = struct + let g ?(recursive_alias = 0) () = recursive_alias + end + + module Applied = Alias (Arg) + + let run () = ignore (Applied.run ()) +end + +let run () = + Mixed_holders.run (); + Partial_result.run (); + Local_alias.run (); + Recursive_alias.run () diff --git a/examples/regression/src/Shared_signature.ml b/examples/regression/src/Shared_signature.ml new file mode 100644 index 00000000..2afce9cd --- /dev/null +++ b/examples/regression/src/Shared_signature.ml @@ -0,0 +1,10 @@ +(* A named module type shared by two functors. Only [Used] is instantiated, so + [Unused.Make.f] must be reported dead: a call through [Used]'s instance must + not keep [Unused]'s implementation alive. *) +module type S = sig + val f : unit -> int +end + +module type O = sig + val g : ?x:int -> unit -> int +end diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml new file mode 100644 index 00000000..64a160cc --- /dev/null +++ b/examples/regression/src/Shared_signature_arg.ml @@ -0,0 +1,1041 @@ +(* Two modules implement the shared named signature; only [Chosen] is passed + to a functor. [Ignored.f] must be reported dead. *) +module Chosen : Shared_signature.S = struct + let f () = 3 +end + +module Ignored : Shared_signature.S = struct + let f () = 4 +end + +module Apply (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied = Apply (Chosen) + +(* Same, but the module is used directly from the same file. *) +module Local_used : Shared_signature.S = struct + let f () = 5 +end + +module Local_unused : Shared_signature.S = struct + let f () = 6 +end + +let run () = ignore (Applied.run () + Local_used.f ()) + +(* A binding calling both through the parameter and a resolved module: the + parameter call must still not be forwarded to [Ignored]. *) +module Apply_mixed (M : Shared_signature.S) = struct + let run () = M.f () + Chosen.f () +end + +module Applied_mixed = Apply_mixed (Chosen) + +(* Optional argument supplied only through a functor parameter call: must be + credited to [Opt_chosen] only, so [Opt_direct]'s [x] stays never used. *) +module Opt_chosen : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_direct : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_opt (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_opt = Apply_opt (Opt_chosen) + +let run_more () = + ignore (Applied_mixed.run () + Applied_opt.run () + Opt_direct.g ()) + +(* Argument wrapped in a constraint: [(Opt_constrained : O)]. *) +module Opt_constrained : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_constrained = Apply_opt ((Opt_constrained : Shared_signature.O)) + +(* Inline functor applied directly. *) +module Opt_inline : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_inline = + (functor (M : Shared_signature.O) -> struct + let run () = M.g ~x:1 () + end) + (Opt_inline) + +(* Constrained argument for liveness: [Ignored2] must stay dead. *) +module Chosen2 : Shared_signature.S = struct + let f () = 7 +end + +module Ignored2 : Shared_signature.S = struct + let f () = 8 +end + +module Applied_constrained_value = Apply ((Chosen2 : Shared_signature.S)) + +let run_even_more () = + ignore + (Applied_constrained.run () + Applied_inline.run () + + Applied_constrained_value.run ()) + +(* Named functor with a whole-functor signature: the binding expression is a + constraint around the functor. *) +module Opt_sigfun : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_sig : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = +functor + (M : Shared_signature.O) + -> + struct + let run () = M.g ~x:1 () + end + +module Applied_sig = Apply_sig (Opt_sigfun) + +let run_sig () = ignore (Applied_sig.run ()) + +(* Curried functor, partially applied and named before the second argument. *) +module Opt_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply2 (A : Shared_signature.S) (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () +end + +module Apply2_partial = Apply2 (Chosen) +module Applied_partial = Apply2_partial (Opt_partial) + +(* Functor bound with [let module]. *) +module Opt_letmodule : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_local () = + let module Apply_local (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + end in + let module Applied_local = Apply_local (Opt_letmodule) in + Applied_local.run () + +let run_partial () = ignore (Applied_partial.run () + run_local ()) + +(* Alias of the parameter inside the body: [N.g] is a parameter call. *) +module Opt_alias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_alias_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_alias (M : Shared_signature.O) = struct + module N = M + + let run () = N.g ~x:1 () +end + +module Applied_alias = Apply_alias (Opt_alias) + +(* Recursive functor. *) +module Opt_rec : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec Apply_rec : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = +functor + (M : Shared_signature.O) + -> + struct + let run () = M.g ~x:1 () + end + +module Applied_rec = Apply_rec (Opt_rec) + +let run_alias () = + ignore (Applied_alias.run () + Applied_rec.run () + Opt_alias_other.g ()) + +(* An identifier through a functor application, [F(X).t]: must not crash the + occurrence resolver. *) +module Set_of_ints = Set.Make (Int) + +let _apply_ident : Set.Make(Int).t = Set_of_ints.empty + +(* Argument constrained by an alias of the named module type. *) +module type S_alias = Shared_signature.S + +module Chosen3 : Shared_signature.S = struct + let f () = 9 +end + +module Ignored3 : Shared_signature.S = struct + let f () = 10 +end + +module Applied_alias_mt = Apply ((Chosen3 : S_alias)) + +(* A functor forwarding its parameter to another functor. *) +module Outer (M : Shared_signature.S) = Apply (M) + +module Chosen4 : Shared_signature.S = struct + let f () = 11 +end + +module Ignored4 : Shared_signature.S = struct + let f () = 12 +end + +module Applied_outer = Outer (Chosen4) + +module Outer_opt (M : Shared_signature.O) = Apply_opt (M) + +module Opt_outer : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_opt = Outer_opt (Opt_outer) + +(* [include M] then an unqualified call to an included member. *) +module Apply_incl (M : Shared_signature.O) = struct + include M + + let run () = g ~x:1 () +end + +module Opt_incl : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_incl_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_incl = Apply_incl (Opt_incl) + +let run_forwarded () = + ignore + (Applied_alias_mt.run () + Applied_outer.run () + Applied_outer_opt.run () + + Applied_incl.run () + Opt_incl_other.g ()) + +(* [let module G = F in G (A)]: the alias stands for the functor. *) +module Opt_letalias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_letalias () = + let module G = Apply_opt in + let module Applied = G (Opt_letalias) in + Applied.run () + +(* Module type alias rooted at a module of this file, and a module type + shadowing a same-named one: resolution must follow identity, not names. *) +module type T = sig + val f : unit -> int +end + +module Inner = struct + module type T = sig + val h : unit -> int + end +end + +module type T_alias = Inner.T + +module Use_t : Inner.T = struct + let h () = 3 +end + +module Apply_h (M : Inner.T) = struct + let run () = M.h () +end + +module Applied_h = Apply_h ((Use_t : T_alias)) + +module Shadow = struct + module type T = sig + val k : unit -> int + end + + module type T_alias3 = T + + module Use3 : T = struct + let k () = 4 + end + + module Apply_k (M : T) = struct + let run () = M.k () + end + + module Applied3 = Apply_k ((Use3 : T_alias3)) +end + +let run_shadow () = + ignore (run_letalias () + Applied_h.run () + Shadow.Applied3.run ()) + +(* A nested module in the parameter's signature, constrained by a named + module type: [M.N.g] must be credited to the argument's [N.g]. *) +module type With_nested = sig + module N : Shared_signature.O +end + +module Nested_arg : With_nested = struct + module N = struct + let g ?(x = 0) () = x + end +end + +module Nested_other : With_nested = struct + module N = struct + let g ?(x = 0) () = x + end +end + +module Apply_nested (M : With_nested) = struct + let run () = M.N.g ~x:1 () +end + +module Applied_nested = Apply_nested (Nested_arg) + +let run_nested () = ignore (Applied_nested.run () + Nested_other.N.g ()) + + +(* A parameter forwarded through ten functors. *) +module Opt_chain : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Chain0 (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Chain1 (M : Shared_signature.O) = Chain0 (M) +module Chain2 (M : Shared_signature.O) = Chain1 (M) +module Chain3 (M : Shared_signature.O) = Chain2 (M) +module Chain4 (M : Shared_signature.O) = Chain3 (M) +module Chain5 (M : Shared_signature.O) = Chain4 (M) +module Chain6 (M : Shared_signature.O) = Chain5 (M) +module Chain7 (M : Shared_signature.O) = Chain6 (M) +module Chain8 (M : Shared_signature.O) = Chain7 (M) +module Chain9 (M : Shared_signature.O) = Chain8 (M) +module Chain10 (M : Shared_signature.O) = Chain9 (M) + +module Applied_chain = Chain10 (Opt_chain) + +(* Modules defined inside a functor body, one applied, one not. *) +module Apply_in_body (X : sig end) = struct + module Chosen_in : Shared_signature.S = struct + let f () = 20 + end + + module Ignored_in : Shared_signature.S = struct + let f () = 21 + end + + module Applied_in = Apply (Chosen_in) + + let run () = Applied_in.run () +end + +module Applied_body = Apply_in_body (struct end) + +let run_chain () = ignore (Applied_chain.run () + Applied_body.run ()) + +(* [let module G = F (A) in G (B)]: a local partial application. *) +module Opt_letpartial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_letpartial () = + let module G = Apply2 (Chosen) in + let module Applied = G (Opt_letpartial) in + Applied.run () + +let run_local_partial () = ignore (run_letpartial ()) + + +(* A functor reached through nine aliases. *) +module Opt_alias9 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Alias1 = Apply_opt +module Alias2 = Alias1 +module Alias3 = Alias2 +module Alias4 = Alias3 +module Alias5 = Alias4 +module Alias6 = Alias5 +module Alias7 = Alias6 +module Alias8 = Alias7 +module Alias9 = Alias8 + +module Applied_alias9 = Alias9 (Opt_alias9) + +let run_alias9 () = ignore (Applied_alias9.run ()) + +(* A nested functor applied through an extended path: [Outer_f (A).Inner (B)]. *) +module Opt_ext : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer_f (A : Shared_signature.S) = struct + module Inner (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () + end +end + +module Applied_outer_f = Outer_f (Chosen) +module Applied_ext = Applied_outer_f.Inner (Opt_ext) + +(* A recursive module binding aliasing a functor. *) +module Opt_rec_alias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec Rec_alias : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = + Apply_opt + +module Applied_rec_alias = Rec_alias (Opt_rec_alias) + +let run_ext () = ignore (Applied_ext.run () + Applied_rec_alias.run ()) + +(* A recursive alias of the parameter inside the body. *) +module Opt_recalias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_recalias_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_recalias (M : Shared_signature.O) = struct + module rec N : Shared_signature.O = M + + let run () = N.g ~x:1 () +end + +module Applied_recalias = Apply_recalias (Opt_recalias) + +let run_shadow_rec () = + ignore (Applied_recalias.run () + Opt_recalias_other.g ()) + +(* A nested functor obtained through [include] in the functor's body. *) +module Opt_incl_f : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer_i (A : Shared_signature.S) = struct + include (struct + module Inner (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () + end + end) +end + +module Applied_outer_i = Outer_i (Chosen) +module Applied_incl_f = Applied_outer_i.Inner (Opt_incl_f) + +let run_incl_f () = ignore (Applied_incl_f.run ()) + +(* A forward alias inside a recursive group. *) +module Opt_rec_chain : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module type Opt_functor = functor (M : Shared_signature.O) -> sig + val run : unit -> int +end + +module rec Rec_g : Opt_functor = Rec_h +and Rec_h : Opt_functor = Apply_opt + +module Applied_rec_chain = Rec_g (Opt_rec_chain) + +let run_rec_chain () = ignore (Applied_rec_chain.run ()) + +(* A module type rooted at a functor application: [Outer_mt (Chosen).SM]. *) +module Outer_mt (A : Shared_signature.S) = struct + let _ = A.f + + module type SM = sig + val f : unit -> int + end +end + +module type S_app = Outer_mt(Chosen).SM + +module Apply_mt (M : S_app) = struct + let run () = M.f () +end + +module Used_mt : S_app = struct + let f () = 30 +end + +module Unused_mt : S_app = struct + let f () = 31 +end + +module Applied_mt = Apply_mt ((Used_mt : S_app)) + +let run_mt () = ignore (Applied_mt.run ()) + +(* Module types rooted at a functor parameter: [M.T], [M.Sub.T], and + [Outer_mt (M).SM] with [M] the parameter. *) +module type Has_t = sig + module type T = sig + val f : unit -> int + end + + module Sub : sig + module type T2 = sig + val h : unit -> int + end + end +end + +module Apply_pt (M : Has_t) = struct + module type T_alias = M.T + module type T2_alias = M.Sub.T2 + + module Use_p : T_alias = struct + let f () = 40 + end + + module Unused_p : T_alias = struct + let f () = 41 + end + + module Use_p2 : T2_alias = struct + let h () = 42 + end + + module Apply_t (X : T_alias) = struct + let run () = X.f () + end + + module Apply_t2 (X : T2_alias) = struct + let run () = X.h () + end + + module Applied_t = Apply_t ((Use_p : T_alias)) + module Applied_t2 = Apply_t2 ((Use_p2 : T2_alias)) + + let run () = Applied_t.run () + Applied_t2.run () +end + +module Applied_pt = Apply_pt (struct + module type T = sig + val f : unit -> int + end + + module Sub = struct + module type T2 = sig + val h : unit -> int + end + end +end) + +module Apply_app (M : Shared_signature.S) = struct + module type T_app = Outer_mt(M).SM + + module Use_a : T_app = struct + let f () = 43 + end + + module Unused_a : T_app = struct + let f () = 44 + end + + module Apply_a (X : T_app) = struct + let run () = X.f () + end + + module Applied_a = Apply_a ((Use_a : T_app)) + + let run () = Applied_a.run () +end + +module Applied_app = Apply_app (Chosen) + +let run_param_mt () = ignore (Applied_pt.run () + Applied_app.run ()) + +(* Module types through a parameter alias and through [include] of the + parameter. *) +module Apply_pt2 (M : Has_t) = struct + module N = M + module type T_via_alias = N.T + + include M + module type T_via_include = T + + module Use_alias_mt : T_via_alias = struct + let f () = 45 + end + + module Use_include_mt : T_via_include = struct + let f () = 46 + end + + module Apply_ta (X : T_via_alias) = struct + let run () = X.f () + end + + module Apply_ti (X : T_via_include) = struct + let run () = X.f () + end + + module Applied_ta = Apply_ta ((Use_alias_mt : T_via_alias)) + module Applied_ti = Apply_ti ((Use_include_mt : T_via_include)) + + let run () = Applied_ta.run () + Applied_ti.run () +end + +module Applied_pt2 = Apply_pt2 (struct + module type T = sig + val f : unit -> int + end + + module Sub = struct + module type T2 = sig + val h : unit -> int + end + end +end) + +let run_param_mt2 () = ignore (Applied_pt2.run ()) + +(* Module types through an aliased or applied member of an applied functor's + result: [Outer_h (Chosen).Alias.T] and [Outer_h (Chosen).Applied_inner.T]. *) +module Outer_h (A : Shared_signature.S) = struct + let _ = A.f + + module Holder = struct + module type T = sig + val f : unit -> int + end + end + + module Alias = Holder + + module Inner_f (X : Shared_signature.S) = struct + module type T = sig + val k : unit -> int + end + end + + module Applied_inner = Inner_f (A) +end + +module type U_alias = Outer_h(Chosen).Alias.T +module type U_applied = Outer_h(Chosen).Applied_inner.T + +module Use_u : U_alias = struct + let f () = 47 +end + +module Use_u2 : U_applied = struct + let k () = 48 +end + +module Apply_u (X : U_alias) = struct + let run () = X.f () +end + +module Apply_u2 (X : U_applied) = struct + let run () = X.k () +end + +module Applied_u = Apply_u ((Use_u : U_alias)) +module Applied_u2 = Apply_u2 ((Use_u2 : U_applied)) + +let run_u () = ignore (Applied_u.run () + Applied_u2.run ()) + +(* A forward alias of the parameter inside a recursive group. *) +module Opt_recfwd : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_recfwd_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_recfwd (M : Shared_signature.O) = struct + module rec G : Shared_signature.O = H + and H : Shared_signature.O = M + + let run () = G.g ~x:1 () +end + +module Applied_recfwd = Apply_recfwd (Opt_recfwd) + +let run_recfwd () = ignore (Applied_recfwd.run () + Opt_recfwd_other.g ()) + +(* Sweep of parameter-alias forms: a recursive alias of a parameter's + submodule, a let-module alias chain, a recursive alias of an outer alias, + and an alias passed as a functor argument. *) +module Opt_sw1 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw3 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw4 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Nested_sw1 : With_nested = struct + module N = Opt_sw1 +end + +module Apply_sw1 (M : With_nested) = struct + module rec G : Shared_signature.O = H + and H : Shared_signature.O = M.N + + let run () = G.g ~x:1 () +end + +module Apply_sw2 (M : Shared_signature.O) = struct + let run () = + let module G = M in + let module H = G in + H.g ~x:1 () +end + +module Apply_sw3 (M : Shared_signature.O) = struct + module N = M + module rec G : Shared_signature.O = N + + let run () = G.g ~x:1 () +end + +module Apply_sw4 (M : Shared_signature.O) = struct + module N = M + module App = Apply_opt (N) + + let run () = App.run () +end + +module Applied_sw1 = Apply_sw1 (Nested_sw1) +module Applied_sw2 = Apply_sw2 (Opt_sw2) +module Applied_sw3 = Apply_sw3 (Opt_sw3) +module Applied_sw4 = Apply_sw4 (Opt_sw4) + +let run_sweep () = + ignore + (Applied_sw1.run () + Applied_sw2.run () + Applied_sw3.run () + + Applied_sw4.run () + Opt_sw_other.g ()) + +(* An inline argument constrained by a module type whose unit is outside + the analysis root (Set.OrderedType lives in the stdlib): the concrete + structure's type is the fallback. *) +module Apply_ord (M : Set.OrderedType) = struct + let run () = + ignore M.compare; + 0 +end + +module Applied_ord = + Apply_ord ((struct + type t = int + + let compare (a : int) b = Stdlib.compare a b + end : Set.OrderedType)) + +let run_ord () = ignore (Applied_ord.run ()) + +module Ord_named = struct + type t = int + + let compare (a : int) b = Stdlib.compare a b +end + +module Applied_ord2 = Apply_ord ((Ord_named : Set.OrderedType)) + +let run_ord2 () = ignore (Applied_ord2.run ()) + +(* Module types declared inside an inline applied functor's body, and inside + a functor parameter's module type whose result exposes the parameter. *) +module M_app = + (functor (A : Shared_signature.S) -> struct + let _ = A.f + + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 50 + end + end) + (Chosen) + +module F_param (M : sig + module type T = sig + val f : unit -> int + end + + module X : T +end) = +struct + include M +end + +module Arg_p = struct + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 51 + end +end + +module Applied_fp = F_param (Arg_p) + +let run_ranges () = ignore (M_app.X.f () + Applied_fp.X.f ()) + +(* An unused application of F_param: nothing may be reported at the + parameter's module type items. *) +module Arg_p2 = struct + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 52 + end +end + +module Applied_fp2 = F_param (Arg_p2) + +(* Constraint-wrapped right-hand sides where a functor key is derived: a + recursive binding of a constrained partial application, and a let-module + binding of a constrained functor. *) +module Opt_recc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_letc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec G_c : Opt_functor = (Apply2 (Chosen) : Opt_functor) + +module Applied_recc = G_c (Opt_recc) + +let run_letc () = + let module F : Opt_functor = + (functor (M : Shared_signature.O) -> struct + let run () = M.g ~x:1 () + end : Opt_functor) + in + let module A = F (Opt_letc) in + A.run () + +let run_constrained () = ignore (Applied_recc.run () + run_letc ()) + +(* Generative functors: a unit application in an application chain, first, + in the middle, last, partially applied, in a recursive binding and in a + let-module. [Opt_unit_none] is never applied and keeps its never-used + argument. *) +module Opt_unit_first : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_mid : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_last : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_end : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_rec : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_let : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_none : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module F_unit () (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_unit = F_unit () (Opt_unit_first) + +module F_unit_mid (M : Shared_signature.O) () (N : Shared_signature.O) = struct + let run () = M.g ~x:1 () + N.g ~x:1 () +end + +module Applied_unit_mid = F_unit_mid (Opt_unit_mid) () (Opt_unit_last) +module F_unit_partial = F_unit () +module Applied_unit_partial = F_unit_partial (Opt_unit_partial) + +module F_unit_end (M : Shared_signature.O) () = struct + let run () = M.g ~x:1 () +end + +module Applied_unit_end = F_unit_end (Opt_unit_end) () +module rec G_u : Opt_functor = F_unit () +module Applied_unit_rec = G_u (Opt_unit_rec) + +let run_unit_let () = + let module A = F_unit () (Opt_unit_let) in + A.run () + +let run_unit () = + ignore + (Applied_unit.run () + Applied_unit_mid.run () + + Applied_unit_partial.run () + Applied_unit_end.run () + + Applied_unit_rec.run () + run_unit_let () + Opt_unit_none.g ()) + +(* Arguments that are themselves applications: the result shape of the inner + application locates the values in the applied functor's body. Directly, + under a constraint, curried, nested, generative, through an alias of the + functor, and with a parameter as the inner argument. [Mk_o_none] is + applied but its result is never passed on. *) +module Mk_s (A : Shared_signature.S) : Shared_signature.S = struct + let f () = A.f () + 1 +end + +module Mk_o (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_c (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o2 (A : Shared_signature.S) (B : Shared_signature.S) : + Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () + B.f () +end + +module Mk_o_n (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_unit () : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Mk_o_a (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_p (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_none (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_alias = Mk_o_a + +module Use_o (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_appl = Use_o (Mk_o (Chosen)) +module Applied_app_c = Use_o ((Mk_o_c (Chosen) : Shared_signature.O)) +module Applied_app2 = Use_o (Mk_o2 (Chosen) (Chosen)) +module Applied_app_n = Use_o (Mk_o_n (Mk_s (Chosen))) +module Applied_app_unit = Use_o (Mk_o_unit ()) +module Applied_app_alias = Use_o (Mk_alias (Chosen)) + +module Via_param (P : Shared_signature.S) = struct + module A = Use_o (Mk_o_p (P)) + + let run () = A.run () +end + +module Applied_via_param = Via_param (Chosen) +module Applied_none = Mk_o_none (Chosen) + +module Applied_app_inline = + Use_o + ((functor (A : Shared_signature.S) -> + (struct + let g ?(x = 0) () = x + A.f () + end : Shared_signature.O)) + (Chosen)) + +let run_app () = + ignore + (Applied_appl.run () + Applied_app_c.run () + Applied_app2.run () + + Applied_app_n.run () + Applied_app_unit.run () + + Applied_app_alias.run () + Applied_via_param.run () + + Applied_none.g () + Applied_app_inline.run ()) + +(* A constrained inline structure as argument, and an applied functor that + re-exports its argument. [Fwd_unused] is never passed and stays dead. *) +module Fwd_used : Shared_signature.S = struct + let f () = 60 +end + +module Fwd_unused : Shared_signature.S = struct + let f () = 61 +end + +module Mk_fwd (A : Shared_signature.S) : Shared_signature.S = struct + include A +end + +module Use_s (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied_fwd = Use_s (Mk_fwd (Fwd_used)) + +module Applied_struct = + Use_o + ((struct + let g ?(x = 0) () = x + end : Shared_signature.O)) + +let run_app2 () = ignore (Applied_fwd.run () + Applied_struct.run ()) + +(* Passed to a higher-order functor of another file, from a third. *) +module Impl_third (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end diff --git a/examples/regression/src/Shared_signature_unused.ml b/examples/regression/src/Shared_signature_unused.ml new file mode 100644 index 00000000..27c4788d --- /dev/null +++ b/examples/regression/src/Shared_signature_unused.ml @@ -0,0 +1,5 @@ +module Make (K : sig + type t +end) : Shared_signature.S = struct + let f () = 2 +end diff --git a/examples/regression/src/Shared_signature_use.ml b/examples/regression/src/Shared_signature_use.ml new file mode 100644 index 00000000..94ce2551 --- /dev/null +++ b/examples/regression/src/Shared_signature_use.ml @@ -0,0 +1,5 @@ +module H = Shared_signature_used.Make (struct + type t = int +end) + +let run () = ignore (H.f ()) diff --git a/examples/regression/src/Shared_signature_used.ml b/examples/regression/src/Shared_signature_used.ml new file mode 100644 index 00000000..e538392e --- /dev/null +++ b/examples/regression/src/Shared_signature_used.ml @@ -0,0 +1,5 @@ +module Make (K : sig + type t +end) : Shared_signature.S = struct + let f () = 1 +end diff --git a/examples/regression/src/Unpacked_functor.ml b/examples/regression/src/Unpacked_functor.ml new file mode 100644 index 00000000..8f3e88f5 --- /dev/null +++ b/examples/regression/src/Unpacked_functor.ml @@ -0,0 +1,17 @@ +module type Arg = sig val g : ?x:int -> unit -> int end +module type FT = functor (M : Arg) -> sig val run : unit -> int end + +module Impl (M : Arg) = struct let run () = M.g ~x:1 () end +let packed = (module Impl : FT) +module G = (val packed : FT) +module Alias = G + +module type Nested_arg = sig val g : ?nested:int -> unit -> int end +module type Holder_t = sig + module Inner (M : Nested_arg) : sig val run : unit -> int end +end +module Holder_impl = struct + module Inner (M : Nested_arg) = struct let run () = M.g ~nested:1 () end +end +let holder = (module Holder_impl : Holder_t) +module Holder = (val holder : Holder_t) diff --git a/examples/regression/src/Unpacked_functor_use.ml b/examples/regression/src/Unpacked_functor_use.ml new file mode 100644 index 00000000..153c21aa --- /dev/null +++ b/examples/regression/src/Unpacked_functor_use.ml @@ -0,0 +1,11 @@ +module Unpacked_arg : Unpacked_functor.Arg = struct let g ?(x = 0) () = x end +module Unpacked_unused : Unpacked_functor.Arg = struct let g ?(x = 0) () = x end +module Applied = Unpacked_functor.Alias (Unpacked_arg) +module Unpacked_nested_arg : Unpacked_functor.Nested_arg = struct + let g ?(nested = 0) () = nested +end +module Applied_nested = Unpacked_functor.Holder.Inner (Unpacked_nested_arg) +let run () = + ignore (Applied.run ()); + ignore (Applied_nested.run ()); + ignore (Unpacked_unused.g ()) diff --git a/examples/regression/src/Unpacked_include.ml b/examples/regression/src/Unpacked_include.ml new file mode 100644 index 00000000..261062ec --- /dev/null +++ b/examples/regression/src/Unpacked_include.ml @@ -0,0 +1,12 @@ +module type Arg = sig val g : ?included:int -> unit -> int end +module type Holder_t = sig + module Inner (M : Arg) : sig val run : unit -> int end +end +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~included:1 () end +end +let packed = (module Holder : Holder_t) +include (val packed : Holder_t) +module Unpacked_include_arg : Arg = struct let g ?(included = 0) () = included end +module Applied = Inner (Unpacked_include_arg) +let run () = ignore (Applied.run ()) diff --git a/examples/regression/src/Unpacked_open.ml b/examples/regression/src/Unpacked_open.ml new file mode 100644 index 00000000..04d96337 --- /dev/null +++ b/examples/regression/src/Unpacked_open.ml @@ -0,0 +1,129 @@ +module type Arg = Unpacked_open_provider.Arg +module type Holder_t = Unpacked_open_provider.Holder_t + +(* Separate signatures and holders keep one case's escape from satisfying + another case's assertions. *) +module Direct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + open (val packed : Holder_t) + module Open_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = Inner (Open_arg) + let run () = ignore (Applied.run ()) +end + +module Local = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + module Local_open_arg : Arg = struct let g ?(opened = 0) () = opened end + let run () = + let open (val packed : Holder_t) in + let module Applied = Inner (Local_open_arg) in + ignore (Applied.run ()) +end + +module Open_struct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + open struct module H = (val packed : Holder_t) end + module Open_struct_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = H.Inner (Open_struct_arg) + let run () = ignore (Applied.run ()) +end + +module Include_struct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + include struct module H = (val packed : Holder_t) end + module Include_struct_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = H.Inner (Include_struct_arg) + let run () = ignore (Applied.run ()) +end + +module Cross_unit = struct + open (val Unpacked_open_provider.packed : Holder_t) + module Cross_open_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = Inner (Cross_open_arg) + let run () = ignore (Applied.run ()) +end + +module Unrelated = struct + module type Arg = sig val g : ?unrelated:int -> unit -> int end + module Never_applied (M : Arg) = struct let run () = M.g ~unrelated:1 () end + module Unrelated_arg : Arg = struct let g ?(unrelated = 0) () = unrelated end + let run () = ignore (Unrelated_arg.g ()) +end + +module Unused_import = struct + open Unpacked_unused + module Victim : Arg = struct let g ?(unused_open = 0) () = unused_open end + module Called_victim : Arg = struct let g ?(unused_open = 0) () = unused_open end + let fns = [Victim.g] + let run () = ignore (List.length fns); ignore (Called_victim.g ()); ignore (helper ()) +end + +module Mixed_open = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + open struct + module Used = (val packed : Holder_t) + module Ignored = (val Unpacked_unused.packed : Unpacked_unused.Holder_t) + end + module Used_arg : Arg = struct let g ?(opened = 0) () = opened end + module Victim : Unpacked_unused.Arg = struct let g ?(unused_open = 0) () = unused_open end + module Applied = Used.Inner (Used_arg) + let run () = ignore (Applied.run ()); ignore (Victim.g ()) +end + +module Aliases = struct + module type Arg = sig val g : ?aliased:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~aliased:1 () end + end + let packed = (module Holder : Holder_t) + open (val packed : Holder_t) + module Alias = Inner + module Local_alias_arg : Arg = struct let g ?(aliased = 0) () = aliased end + module Foreign_alias_arg : Unpacked_unused.Exported_alias.Arg = struct + let g ?(foreign_alias = 0) () = foreign_alias + end + module Foreign_include_arg : Unpacked_unused.Exported_include.Arg = struct + let g ?(foreign_include = 0) () = foreign_include + end + module Local = Alias (Local_alias_arg) + module Foreign = Unpacked_unused.Exported_alias.Alias (Foreign_alias_arg) + module Included = Unpacked_unused.Exported_include.Inner (Foreign_include_arg) + let run () = ignore (Local.run ()); ignore (Foreign.run ()); ignore (Included.run ()) +end + +let run () = + Direct.run (); + Local.run (); + Open_struct.run (); + Include_struct.run (); + Cross_unit.run (); + Unrelated.run (); + Unused_import.run (); + Mixed_open.run (); + Aliases.run () diff --git a/examples/regression/src/Unpacked_open_provider.ml b/examples/regression/src/Unpacked_open_provider.ml new file mode 100644 index 00000000..21008e26 --- /dev/null +++ b/examples/regression/src/Unpacked_open_provider.ml @@ -0,0 +1,6 @@ +module type Arg = Unpacked_open_types.Arg +module type Holder_t = Unpacked_open_types.Holder_t +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end +end +let packed = (module Holder : Holder_t) diff --git a/examples/regression/src/Unpacked_open_provider.mli b/examples/regression/src/Unpacked_open_provider.mli new file mode 100644 index 00000000..595e753c --- /dev/null +++ b/examples/regression/src/Unpacked_open_provider.mli @@ -0,0 +1,4 @@ +module type Arg = Unpacked_open_types.Arg +module type Holder_t = Unpacked_open_types.Holder_t +module Holder : Holder_t +val packed : (module Holder_t) diff --git a/examples/regression/src/Unpacked_open_types.ml b/examples/regression/src/Unpacked_open_types.ml new file mode 100644 index 00000000..3979f2d2 --- /dev/null +++ b/examples/regression/src/Unpacked_open_types.ml @@ -0,0 +1,2 @@ +module type Arg = sig val g : ?opened:int -> unit -> int end +module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end diff --git a/examples/regression/src/Unpacked_unused.ml b/examples/regression/src/Unpacked_unused.ml new file mode 100644 index 00000000..d40cc6c6 --- /dev/null +++ b/examples/regression/src/Unpacked_unused.ml @@ -0,0 +1,29 @@ +module type Arg = sig val g : ?unused_open:int -> unit -> int end +module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~unused_open:1 () end +end +let packed = (module Holder : Holder_t) +module Unused_holder = (val packed : Holder_t) +let helper () = 42 + +module Exported_include = struct + module type Arg = sig val g : ?foreign_include:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~foreign_include:1 () end + end + let packed = (module Holder : Holder_t) + include (val packed : Holder_t) +end + +module Exported_alias = struct + module type Arg = sig val g : ?foreign_alias:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~foreign_alias:1 () end + end + let packed = (module Holder : Holder_t) + include (val packed : Holder_t) + module Alias = Inner +end diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 097f5580..84b0488d 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -1,10 +1,42 @@ (library (name regression_fixture) (modules + Attribution_sweep + Cross_alias + Cross_alias_use + Cross_c + Cross_include + Escape_exports + Escaped_coercion Functor_argument Generated_source + Higher_order + Higher_order_fixpoint + Higher_order_more + Included_sig Live_ancestors Local_side_effects Main - Ocaml_compiler_compat) + Nested_module_type + Nested_arguments + Nested_arguments_packed + Ocaml_compiler_compat + Packed_interface + Packed_interface_use + Packed_types + Partial_context_use + Reference_order + Review_round + Shared_signature + Shared_signature_arg + Shared_signature_unused + Shared_signature_use + Shared_signature_used + Unpacked_functor + Unpacked_functor_use + Unpacked_include + Unpacked_open + Unpacked_open_provider + Unpacked_open_types + Unpacked_unused) (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index eba51cfe..844efa48 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -70,6 +70,16 @@ function assertNotIncludes(output, unexpected) { } } +function ocamlVersionAtLeast(major, minor) { + const version = child_process + .execFileSync("ocamlc", ["-version"], { encoding: "utf8" }) + .trim(); + const [actualMajor, actualMinor] = version.split(".").map(Number); + return ( + actualMajor > major || (actualMajor === major && actualMinor >= minor) + ); +} + function runRegressionTests() { const cwd = path.join(__dirname, "..", "examples", "regression"); const cmtDir = "_build/default/src/.regression_fixture.objs/byte"; @@ -91,6 +101,9 @@ function runRegressionTests() { { cwd, encoding: "utf8", + // The debug output lists every reference; before OCaml 5.3 references + // through module type items fan out to every implementation. + maxBuffer: 256 * 1024 * 1024, } ); @@ -104,6 +117,584 @@ function runRegressionTests() { assertIncludes(output, "Live Value +Local_side_effects.+process"); assertIncludes(output, "Live Value +Local_side_effects.+register"); + // A call through one functor instance must never mark the used + // implementation dead. + assertIncludes(output, "Live Value +Shared_signature_used.Make.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_used.Make.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Local_used.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Local_used.+f"); + // A parameter access must not suppress an ordinary access from the same + // binding, regardless of which occurrence the mapper visits first. + for (const order of ["Parameter_first", "Ordinary_first"]) { + assertIncludes(output, `Live Value +Reference_order.${order}.Used.+f`); + assertNotIncludes(output, `Dead Value +Reference_order.${order}.Used.+f`); + } + // A call through a functor parameter is credited to the actual argument + // (conservatively, to every implementation of the item, before OCaml 5.3): + // x must never be reported unused. + assertNotIncludes( + output, + "optional argument x of function Opt_chosen.+g is never used" + ); + // Arguments wrapped in a constraint by a named module type are still used. + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen2.+f"); + // Arguments of generative functors and applied arguments are used. + assertIncludes(output, "Live Value +Shared_signature_arg.Opt_unit_first.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Opt_unit_last.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Mk_o.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Applied_struct.+g"); + assertIncludes(output, "Live Value +Higher_order.Opt_ho.+g"); + assertIncludes(output, "Live Value +Higher_order.Opt_fc.+g"); + assertIncludes(output, "Live Value +Higher_order.P_esc.+h"); + assertIncludes(output, "Live Value +Higher_order.Id_used.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen2.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Opt_constrained.+g"); + // Precise attribution through a shared named module type relies on shape + // reduction of identifier occurrences, available from OCaml 5.3. Earlier + // versions conservatively keep every implementation of the item live. + if (ocamlVersionAtLeast(5, 3)) { + assertIncludes(output, "Dead Value +Shared_signature_unused.Make.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_unused.Make.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_arg.Ignored.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Local_unused.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_arg.Local_unused.+f"); + // A call through a functor parameter supplying ?x must not be attributed + // to other implementations of the module type item. + assertIncludes( + output, + "optional argument x of function Opt_direct.+g is never used" + ); + // ... and is credited precisely, including through a constraint, for an + // inline functor, and for a functor with a whole-functor signature. + assertIncludes( + output, + "optional argument x of function Opt_chosen.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_sigfun.+g is always supplied" + ); + // ... through a named partial application, and for a let-module functor. + assertIncludes( + output, + "optional argument x of function Opt_partial.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_letmodule.+g is always supplied" + ); + // ... through an alias of the parameter, and for a recursive functor. The + // aliased call must not leak to another implementation. + assertIncludes( + output, + "optional argument x of function Opt_alias.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_alias_other.+g is never used" + ); + assertIncludes( + output, + "optional argument x of function Opt_rec.+g is always supplied" + ); + // Argument constrained by an alias of the module type; a functor + // forwarding its parameter to another functor; include of the parameter. + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen3.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored3.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen4.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored4.+f"); + assertIncludes( + output, + "optional argument x of function Opt_outer.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_incl.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_incl_other.+g is never used" + ); + // A module type declared inside a module. + assertIncludes(output, "Live Value +Nested_module_type.Outer.Used.+f"); + assertIncludes(output, "Dead Value +Nested_module_type.Outer.Unused.+f"); + // let-module alias of a functor; module type aliases rooted at a local + // module and shadowing a same-named module type. + assertIncludes( + output, + "optional argument x of function Opt_letalias.+g is always supplied" + ); + assertIncludes(output, "Live Value +Shared_signature_arg.Use_t.+h"); + assertIncludes(output, "Live Value +Shared_signature_arg.Shadow.Use3.+k"); + // A nested module of the parameter constrained by a named module type. + assertIncludes(output, "Live Value +Shared_signature_arg.Nested_arg.N.+g"); + assertIncludes( + output, + "optional argument x of function Nested_arg.N.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Nested_other.N.+g is never used" + ); + // Ten forwarding functors; modules inside a functor body; an alias of a + // functor defined in another file; a module type in an included signature. + assertIncludes( + output, + "optional argument x of function Opt_chain.+g is always supplied" + ); + assertIncludes( + output, + "Dead Value +Shared_signature_arg.Apply_in_body.Ignored_in.+f" + ); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_in_body.Chosen_in.+f" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross.+g is always supplied" + ); + assertIncludes(output, "Live Value +Included_sig.M.+f"); + // A module type nested in a with-constrained signature; nine aliases. + assertIncludes(output, "Live Value +Included_sig.W.X.+f"); + assertIncludes( + output, + "optional argument x of function Opt_alias9.+g is always supplied" + ); + // A nested functor applied through Outer (A).Inner; a recursive alias. + assertIncludes( + output, + "optional argument x of function Opt_ext.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_rec_alias.+g is always supplied" + ); + // A recursive alias of the parameter; a module type introduced by a + // with-constraint. + assertIncludes( + output, + "optional argument x of function Opt_recalias.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_recalias_other.+g is never used" + ); + assertIncludes(output, "Live Value +Included_sig.W2.X.+f"); + // module type of; a nested functor obtained through include. + assertIncludes(output, "Live Value +Included_sig.W3.X.+f"); + assertIncludes( + output, + "optional argument x of function Opt_incl_f.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross_incl.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_rec_chain.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_y.+g is always supplied" + ); + // A module type rooted at a functor application. + assertIncludes(output, "Live Value +Shared_signature_arg.Used_mt.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Unused_mt.+f"); + // Module types rooted at a functor parameter: M.T, M.Sub.T2, + // Outer (M).SM, through a parameter alias, and through include. + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_pt.Use_p.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Apply_pt.Unused_p.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_pt.Use_p2.+h"); + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_app.Use_a.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Apply_app.Unused_a.+f"); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_pt2.Use_alias_mt.+f" + ); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_pt2.Use_include_mt.+f" + ); + // Module types through an aliased or applied member of an applied + // functor's result. + assertIncludes(output, "Live Value +Shared_signature_arg.Use_u.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Use_u2.+k"); + // A forward alias of the parameter in a recursive group. + assertIncludes( + output, + "optional argument x of function Opt_recfwd.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_recfwd_other.+g is never used" + ); + // Sweep of parameter-alias forms: recursive alias of a parameter's + // submodule, let-module alias chain, recursive alias of an outer alias, + // alias passed as a functor argument. Each credited exactly once and + // never leaked to an unrelated implementation. + for (const m of ["Opt_sw1", "Opt_sw2", "Opt_sw3", "Opt_sw4"]) { + assertIncludes( + output, + `optional argument x of function ${m}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_sw_other.+g is never used" + ); + // Arguments constrained by a module type from outside the analysis root + // (Set.OrderedType): inline and named. + assertIncludes(output, "Live Value +Shared_signature_arg.Applied_ord.+compare"); + assertIncludes(output, "Live Value +Shared_signature_arg.Ord_named.+compare"); + // Module types inside an applied inline functor and inside a functor + // parameter's type: their items are never declarations. + assertIncludes(output, "Live Value +Shared_signature_arg.M_app.X.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Arg_p.X.+f"); + // (Arg_p2.X.f is live: an argument's coerced items count as used.) + assertNotIncludes(output, "Value +Shared_signature_arg.Applied_fp2.X.+f"); + assertNotIncludes(output, "Value +Shared_signature_arg.F_param.X.+f"); + // Constraint-wrapped right-hand sides: a recursive constrained partial + // application, and a let-module constrained functor. + assertIncludes( + output, + "optional argument x of function Opt_recc.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Opt_letc.+g is always supplied (1 calls)" + ); + // Partial applications: held by a let module, and bound in another file. + assertIncludes( + output, + "optional argument x of function Opt_letpartial.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross_partial.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_constrained.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_inline.+g is always supplied" + ); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored2.+f"); + // Generative functors: a unit application first, in the middle, last, in + // a partial application, a recursive binding, a let module, and bound in + // another file. An implementation never applied keeps its unused argument. + for (const name of [ + "Opt_unit_first", + "Opt_unit_mid", + "Opt_unit_last", + "Opt_unit_partial", + "Opt_unit_end", + "Opt_unit_rec", + "Opt_unit_let", + "Opt_cross_unit", + "Opt_cross_unit2", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_unit_none.+g is never used" + ); + // Arguments that are themselves applications: directly, constrained, + // curried, nested, generative, through an alias of the functor, with a + // parameter as the inner argument, of an inline functor, bound in another + // file, and a constrained inline structure. The calls are credited to the + // applied functor's body only. + for (const name of [ + "Mk_o", + "Mk_o_c", + "Mk_o2", + "Mk_o_n", + "Mk_o_unit", + "Mk_o_a", + "Mk_o_p", + "Applied_app_inline", + "Applied_struct", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Mk_cross.+g is always supplied (2 calls)" + ); + assertIncludes( + output, + "optional argument x of function Mk_o_none.+g is never used" + ); + // An applied functor re-exporting its argument: the argument's value is + // used, another implementation of the module type stays dead. + assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Fwd_unused.+f"); + // Higher-order functors: a functor passed as an argument and applied in + // the body, to a parameter, a fixed module, a submodule of a parameter, + // through an alias of the functor parameter, in an include, partially + // applied beforehand, through two levels; and first-class modules as + // head and as argument, in the same file and from another file. Each + // call is credited to the argument of the same application only. + for (const name of [ + "Opt_ho", + "Opt_fixed", + "Opt_sub_holder.Sub", + "Opt_alias_ho", + "Opt_incl_ho", + "Opt_partial_ho", + "Opt_2", + "Opt_fc", + "Opt_fca", + "Opt_cross_fc", + "Opt_id", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_twice.+g is always supplied (2 calls)" + ); + // ... a functor whose body is directly the parameter's application, and a + // higher-order functor from another file applied to a functor from a + // third file. + assertIncludes( + output, + "optional argument x of function Opt_direct_body.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross_ho.+g is always supplied (1 calls)" + ); + // ... and with the functor parameter's type written inline: the passed + // functor's values used through it stay live, its unused helper dead. + assertIncludes( + output, + "optional argument x of function Opt_anon.+g is always supplied (1 calls)" + ); + assertIncludes(output, "Live Value +Higher_order_more.Impl_anon.+run"); + assertIncludes(output, "Dead Value +Higher_order_more.Impl_anon.+helper"); + assertIncludes( + output, + "optional argument x of function Opt_none_ho.+g is never used" + ); + // Inline functors returning (a submodule of) their parameter, or a + // functor applied to it: the argument flows on; an unrelated + // implementation stays dead. + assertIncludes(output, "Live Value +Higher_order.Id_used.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_sub_holder.Sub.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_app.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_curried.+f"); + assertIncludes(output, "Dead Value +Higher_order.Id_unused.+f"); + // A functor escaping as a first-class module passed to a function: its + // calls are forwarded conservatively, never dropped. + assertIncludes( + output, + "optional argument y of function P_esc.+h is always supplied" + ); + assertNotIncludes(output, "P_esc.+h is never used"); + // ... including functors nested in a module that escapes, nested in + // the result of an applied functor parameter, and a functor applied + // directly whose packed value also flows through a function. + assertIncludes( + output, + "optional argument z of function P2_esc.+k is always supplied" + ); + assertNotIncludes(output, "P2_esc.+k is never used"); + assertIncludes( + output, + "optional argument cross of function Cross_esc.+k is always supplied" + ); + assertNotIncludes(output, "Cross_esc.+k is never used"); + assertIncludes( + output, + "optional argument w of function P3_esc.+q is always supplied" + ); + assertNotIncludes(output, "P3_esc.+q is never used"); + assertIncludes( + output, + "optional argument v of function P4_b.+u is always supplied" + ); + assertNotIncludes(output, "P4_b.+u is never used"); + assertNotIncludes(output, "P4_a.+u is never used"); + // New enclosing applications discovered on later fixed-point rounds + // still instantiate the original parameter-headed application. + for (const name of ["Fixpoint_a", "Fixpoint_b"]) { + assertIncludes( + output, + `optional argument y of function ${name}.+g is always supplied (1 calls)` + ); + } + // The two indirect applications share a source application ID but not + // an enclosing context: C's omitted argument must not mix with B's call. + assertIncludes( + output, + "optional argument y of function Fixpoint_c.+g is never used" + ); + // A packed higher-order argument exported through an .mli resolves to + // the implementation binding where its functor was registered. + assertIncludes( + output, + "optional argument x of function Packed_arg.+g is always supplied (1 calls)" + ); + // A foreign unpacked functor (and its alias) has no shape uid. Resolve + // its packed binding precisely; an unpacked include escapes instead. + assertIncludes( + output, + "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Unpacked_unused.+g is never used" + ); + assertIncludes( + output, + "optional argument included of function Unpacked_include_arg.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)" + ); + for (const name of [ + "Direct.Open_arg", "Local.Local_open_arg", "Open_struct.Open_struct_arg", + "Include_struct.Include_struct_arg", "Cross_unit.Cross_open_arg", + "Mixed_open.Used_arg", + ]) { + assertIncludes( + output, + `optional argument opened of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument unrelated of function Unrelated.Unrelated_arg.+g is never used" + ); + for (const name of [ + "Unused_import.Victim", "Unused_import.Called_victim", "Mixed_open.Victim", + ]) { + assertIncludes( + output, + `optional argument unused_open of function ${name}.+g is never used` + ); + } + for (const [name, argument] of [ + ["Local_alias_arg", "aliased"], + ["Foreign_alias_arg", "foreign_alias"], + ["Foreign_include_arg", "foreign_include"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function Aliases.${name}.+g is always supplied (1 calls)` + ); + } + for (const [name, argument] of [ + ["Repacked.Repacked_arg", "repacked"], + ["Projected.Projected_arg", "projected"], + ["Opaque_holder.Opaque_arg", "opaque"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is always supplied (1 calls)` + ); + } + for (const [name, argument] of [ + ["Repacked.Repacked_unused", "repacked"], + ["Projected.Projected_unused", "projected"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is never used` + ); + } + assertIncludes( + output, + "optional argument untouched of function Opaque_holder.Opaque_unrelated.+h is never used" + ); + for (const name of [ + "Partial_context.Partial_supplied_arg", + "Partial_context.Passed_supplied_arg", + "Partial_context.Packed_partial_arg", + "Partial_context.Unit_partial_arg", + "Partial_context.Forwarded_supplied_arg", + "Foreign_supplied_arg", + ]) { + assertIncludes( + output, + `optional argument partial of function ${name}.+g is always supplied (1 calls)` + ); + } + for (const name of [ + "Partial_context.Partial_omitted_arg", + "Partial_context.Passed_omitted_arg", + "Partial_context.Forwarded_omitted_arg", + "Foreign_omitted_arg", + ]) { + assertIncludes( + output, + `optional argument partial of function ${name}.+g is never used` + ); + } + // Escaping holders also expose functors defined outside their lexical + // range through module aliases and includes. + for (const [name, argument] of [ + ["Escaped_alias_arg", "alias"], + ["Escaped_include_arg", "included"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is always supplied` + ); + assertNotIncludes(output, `${name}.+g is never used`); + } + for (const name of ["Escaped_only", "Known_and_escaped"]) { + assertIncludes(output, `Live Value +Escaped_coercion.${name}.Possible_arg.+needed`); + assertNotIncludes(output, `Dead Value +Escaped_coercion.${name}.Possible_arg.+needed`); + assertIncludes(output, `Dead Value +Escaped_coercion.${name}.Possible_arg.+unused`); + } + assertIncludes( + output, + "Dead Value +Escaped_coercion.Never_applied.Unrelated_arg.+needed" + ); + assertIncludes(output, "Live Value +Escaped_coercion.Known_only.Known_arg.+needed"); + assertIncludes(output, "Dead Value +Escaped_coercion.Known_only.Unrelated_arg.+needed"); + assertIncludes(output, "Live Value +Escaped_coercion.Nested_stored.Possible_arg.N.+needed"); + assertIncludes(output, "Dead Value +Escaped_coercion.Nested_stored.Possible_arg.N.+unused"); + for (const name of ["Known_arg", "Anonymous_arg", "Included_arg"]) { + assertIncludes(output, `optional argument mixed of function Mixed_holders.${name}.+g is always supplied (1 calls)`); + } + for (const name of ["Omitted_arg", "Unrelated_arg"]) { + assertIncludes(output, `optional argument mixed of function Mixed_holders.${name}.+g is never used`); + } + assertIncludes(output, "Live Value +Review_round.Partial_result.F.+run"); + assertNotIncludes(output, "Dead Value +Review_round.Partial_result.F.+run"); + assertIncludes(output, "Dead Value +Review_round.Partial_result.F.+unused"); + assertIncludes(output, "optional argument result of function Partial_result.F.+run is always supplied (2 calls)"); + assertIncludes(output, "optional argument local_alias of function Local_alias.Arg.+g is always supplied (1 calls)"); + assertIncludes(output, "optional argument recursive_alias of function Recursive_alias.Arg.+g is always supplied (1 calls)"); + for (const name of ["Known.N", "B.N", "C.Actual", "D.N", "Packed_arg.N"]) { + assertIncludes(output, `optional argument nested_arg of function ${name}.+g is always supplied (1 calls)`); + } + assertIncludes(output, "optional argument nested_arg of function Unrelated.N.+g is never used"); + assertIncludes(output, "optional argument foreign_nested of function Actual.N.+g is always supplied (1 calls)"); + assertIncludes(output, "optional argument foreign_nested of function Unrelated.N.+g is never used"); + } + assertNotIncludes(output, "Parent is a dead module"); assertNotIncludes(output, "Dead Value +Functor_argument.Ordered.+compare"); assertNotIncludes(output, "Live Value +Functor_argument.Ordered.+unused"); @@ -123,6 +714,7 @@ function runRegressionTests() { { cwd, encoding: "utf8", + maxBuffer: 256 * 1024 * 1024, } ); @@ -134,6 +726,425 @@ function runRegressionTests() { assertNotIncludes(dupOutput, "Dead Value +Dup_a_impl.Make.+f"); assertNotIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+g"); + if (ocamlVersionAtLeast(5, 3)) { + // The matching .cmti supplies the digest, while the sibling .cmt + // supplies the shape needed to distinguish implementations of Dup_sig.S. + assertIncludes(dupOutput, "Live Value +Dup_shape.A_chosen.+f"); + assertNotIncludes(dupOutput, "Live Value +Dup_shape.A_unused.+f"); + assertIncludes(dupOutput, "Dead Value +Dup_shape.A_unused.+f"); + assertIncludes(dupOutput, "Dead Value +Dup_shape.B_unused.+f"); + } +} + +// A broad root may hold copies of the same compiled unit (a library's +// objects and its _build/install copy, byte and native objects). Scanning +// such a root must give exactly the single-directory result: copies are +// neither scanned twice nor mistaken for distinct units. +function runDuplicateLayoutTest() { + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const cmtDir = path.join( + cwd, + "_build/default/src/.regression_fixture.objs/byte" + ); + const root = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-dup-")); + for (const dir of ["a", "b", "c"]) fs.mkdirSync(path.join(root, dir)); + for (const file of fs.readdirSync(cmtDir)) { + if (!/\.cmti?$/.test(file)) continue; + // Dependencies duplicated in a and b, consumers in c. + const dirs = /Shared_signature|Cross_/.test(file) ? ["a", "b"] : ["c"]; + for (const dir of dirs) + fs.copyFileSync(path.join(cmtDir, file), path.join(root, dir, file)); + } + const filter = (output) => + output + .split("\n") + .filter((line) => /never used|always supplied|dead module/.test(line)) + .sort() + .join("\n"); + const run = (dir) => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-native-build-target", ".", "-dce-cmt", dir], + { cwd, encoding: "utf8" } + ); + console.log(`${cwd}: reanalyze duplicate-layout comparison`); + const single = filter(run(cmtDir)); + const duplicated = filter(run(root)); + fs.rmSync(root, { recursive: true, force: true }); + if (single !== duplicated) { + throw new Error( + "Scanning a root with duplicated compiled units changed the result:\n" + + duplicated + ); + } +} + +// Compile the same source as bytecode and native code, as Dune does: the +// native compilation reuses the bytecode .cmi and records no interface digest. +function runByteNativeDuplicateTest() { + const fs = require("fs"); + const os = require("os"); + const cwd = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-native-")); + const source = path.join( + __dirname, + "..", + "examples", + "regression", + "duplicate_native", + "Duplicate_native.ml" + ); + try { + for (const dir of ["byte", "native"]) fs.mkdirSync(path.join(cwd, dir)); + child_process.execFileSync( + "ocamlc", + ["-bin-annot", "-c", "-o", "byte/Duplicate_native.cmo", source], + { cwd } + ); + child_process.execFileSync( + "ocamlopt", + [ + "-bin-annot", "-intf-suffix", ".ml", "-I", "byte", "-c", + "-o", "native/Duplicate_native.cmx", source, + ], + { cwd } + ); + const run = (root) => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-dce-cmt", root], + { cwd, encoding: "utf8" } + ); + console.log(`${cwd}: reanalyze byte/native duplicate comparison`); + const single = run("byte"); + assertIncludes( + single, + "optional argument x of function +g is always supplied (1 calls)" + ); + if (single !== run(".")) { + throw new Error( + "Scanning byte and native artifacts changed optional-call counts" + ); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + +function runDuplicateContextTest() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-context-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "duplicate_context"); + try { + fs.copyFileSync(path.join(fixture, "Shared.ml"), path.join(cwd, "Shared.ml")); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir)); + fs.copyFileSync(path.join(fixture, dir, "Provider.ml"), path.join(cwd, dir, "Provider.ml")); + child_process.execFileSync("ocamlc", [ + "-bin-annot", "-bin-annot-occurrences", "-c", `${dir}/Provider.ml`, + ], { cwd }); + child_process.execFileSync("ocamlc", [ + "-bin-annot", "-bin-annot-occurrences", "-I", dir, "-c", + "-o", `${dir}/Shared.cmo`, "Shared.ml", + ], { cwd }); + } + const run = () => child_process.execFileSync( + reanalyzeFile, ["-ci", "-debug", "-dce-cmt", "."], + { cwd, encoding: "utf8" } + ); + const assertContexts = (output) => { + if ((output.match(/Scanning .*Shared\.cmt /g) || []).length !== 2) { + throw new Error("Both dependency contexts must be scanned exactly once"); + } + if ((output.match(/Live Value \+Provider\.\+g:/g) || []).length !== 2) { + throw new Error("Both dependency implementations must remain live"); + } + if ((output.match(/optional argument x of function \+g is always supplied \(1 calls\)/g) || []).length !== 2) { + throw new Error("Each dependency context must receive exactly one call"); + } + assertNotIncludes(output, "Dead Value +Provider.+g"); + }; + console.log(`${cwd}: reanalyze identical source with distinct dependency contexts`); + assertContexts(run()); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir, "install")); + for (const file of ["Provider.cmt", "Shared.cmt"]) { + fs.copyFileSync(path.join(cwd, dir, file), path.join(cwd, dir, "install", file)); + } + } + assertContexts(run()); + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + +function runCompilationContextTests(sharedInterface = false) { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const cwd = fs.mkdtempSync(path.join(require("os").tmpdir(), "reanalyze-typing-context-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "compilation_context"); + const copy = (name) => fs.copyFileSync(path.join(fixture, name), path.join(cwd, name)); + const compile = (args, compiler = "ocamlc") => child_process.execFileSync( + compiler, ["-bin-annot", "-bin-annot-occurrences", ...args], { cwd } + ); + const run = (root, debug = false) => child_process.execFileSync( + reanalyzeFile, ["-ci", ...(debug ? ["-debug"] : []), "-dce-cmt", root], + { cwd, encoding: "utf8", timeout: 10000 } + ); + try { + for (const dir of ["a", "b", "native_layout/byte", "native_layout/native"]) { + fs.mkdirSync(path.join(cwd, dir), { recursive: true }); + } + copy("Shared.ml"); + copy("Relay.ml"); + const apiArgs = sharedInterface ? ["-I", "api"] : []; + if (sharedInterface) { + fs.mkdirSync(path.join(cwd, "api")); + copy("Provider.mli"); + compile(["-c", "-o", "api/Provider.cmi", "Provider.mli"]); + } + for (const dir of ["a", "b"]) { + for (const file of ["Provider.ml", `Use_${dir}.ml`]) copy(`${dir}/${file}`); + compile([...(sharedInterface ? ["-intf-suffix", ".ml", ...apiArgs] : []), "-c", `${dir}/Provider.ml`]); + for (const name of ["Shared", "Relay"]) { + compile(["-I", dir, ...apiArgs, "-c", "-o", `${dir}/${name}.cmo`, `${name}.ml`]); + } + compile(["-I", dir, ...apiArgs, "-c", `${dir}/Use_${dir}.ml`]); + } + console.log(`${cwd}: reanalyze functor identity with ${sharedInterface ? "shared" : "distinct"} dependency interfaces`); + const supplied = "optional argument context of function Arg.+g is always supplied (1 calls)"; + const omitted = "optional argument context of function Arg.+g is never used"; + assertIncludes(run("a"), supplied); + assertIncludes(run("b"), omitted); + const assertContexts = (output) => { + assertIncludes(output, supplied); + assertIncludes(output, omitted); + for (const name of ["Partial_arg", "Packed_arg", "Relayed_arg"]) { + assertIncludes(output, `optional argument context of function ${name}.+g is always supplied (1 calls)`); + assertIncludes(output, `optional argument context of function ${name}.+g is never used`); + } + if ((output.match(/Scanning .*Shared\.cmt /g) || []).length !== 2) { + throw new Error("Both Shared functor contexts must be scanned exactly once"); + } + }; + assertContexts(run(".", true)); + + for (const name of ["First", "Second", "Opened"]) copy(`${name}.ml`); + compile(["-c", "First.ml"]); + compile(["-c", "Second.ml"]); + compile(["-open", "First", "-open", "Second", "-c", "-o", "a/Opened.cmo", "Opened.ml"]); + compile(["-open", "Second", "-open", "First", "-c", "-o", "b/Opened.cmo", "Opened.ml"]); + const assertOpens = (output) => { + for (const name of ["First", "Second"]) { + assertIncludes(output, `Live Value +${name}.+g`); + assertNotIncludes(output, `Dead Value +${name}.+g`); + } + if ((output.match(/Scanning .*Opened\.cmt /g) || []).length !== 2 || + (output.match(/optional argument opened of function \+g is always supplied \(1 calls\)/g) || []).length !== 2) { + throw new Error("Ordered -open contexts must each contribute one call"); + } + }; + console.log(`${cwd}: reanalyze ordered implicit opens`); + assertOpens(run(".", true)); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir, "install")); + for (const file of fs.readdirSync(path.join(cwd, dir)).filter((f) => f.endsWith(".cmt"))) { + fs.copyFileSync(path.join(cwd, dir, file), path.join(cwd, dir, "install", file)); + } + } + const copies = run(".", true); + assertContexts(copies); + assertOpens(copies); + + for (const name of ["Native_provider", "Native_use"]) { + copy(`${name}.ml`); + compile(["-I", "native_layout/byte", "-c", "-o", `native_layout/byte/${name}.cmo`, `${name}.ml`]); + } + for (const name of ["Native_provider", "Native_use"]) { + compile(["-intf-suffix", ".ml", "-I", "native_layout/byte", "-I", "native_layout/native", + "-c", "-o", `native_layout/native/${name}.cmx`, `${name}.ml`], "ocamlopt"); + } + console.log(`${cwd}: reanalyze native-only cross-unit functor imports`); + const byte = run("native_layout/byte"); + assertIncludes(byte, "optional argument native of function Arg.+g is always supplied (1 calls)"); + for (const root of ["native_layout/native", "native_layout"]) { + if (run(root) !== byte) throw new Error(`Cross-unit attribution changed for ${root}`); + } + for (const name of ["Safe_alias", "Nested_alias"]) { + copy(`${name}.ml`); + compile(["-o", `${name}.exe`, `${name}.ml`]); + child_process.execFileSync(path.join(cwd, `${name}.exe`), [], { cwd, timeout: 10000 }); + console.log(`${cwd}: bounded analysis of ${name}`); + assertIncludes(run(`${name}.cmt`), "Analysis reported 0 issues"); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + +function runSplitInterfaceTests() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const cwd = fs.mkdtempSync(path.join(require("os").tmpdir(), "reanalyze-split-interface-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "compilation_context"); + const compile = (args) => child_process.execFileSync( + "ocamlc", ["-bin-annot", "-bin-annot-occurrences", ...args], { cwd } + ); + try { + for (const dir of ["src", "api", "objects", "consumer"]) { + fs.mkdirSync(path.join(cwd, dir)); + } + for (const name of ["Split.mli", "Split.ml", "Split_use.ml"]) { + fs.copyFileSync(path.join(fixture, name), path.join(cwd, "src", name)); + } + compile(["-c", "-o", "api/Split.cmi", "src/Split.mli"]); + compile(["-intf-suffix", ".ml", "-I", "api", "-c", "-o", "objects/Split.cmo", "src/Split.ml"]); + compile(["-I", "api", "-I", "objects", "-c", "-o", "consumer/Split_use.cmo", "src/Split_use.ml"]); + const artifacts = ["api/Split.cmti", "objects/Split.cmt", "consumer/Split_use.cmt"]; + const run = (root) => child_process.execFileSync( + reanalyzeFile, ["-ci", "-debug", "-dce-cmt", root], + { cwd, encoding: "utf8", timeout: 10000 } + ); + const copyArtifacts = (root, dirs) => { + for (let i = 0; i < artifacts.length; i++) { + const dir = path.join(root, dirs[i]); + fs.mkdirSync(dir, { recursive: true }); + fs.copyFileSync(path.join(cwd, artifacts[i]), path.join(dir, path.basename(artifacts[i]))); + } + }; + for (const [name, dirs, copies] of [ + ["colocated", ["all", "all", "all"]], + ["separate", ["api", "objects", "consumer"]], + ["consumer-with-api", ["api", "objects", "api"]], + ["consumer-with-implementation", ["api", "objects", "objects"]], + ["separate-copies", ["api", "objects", "consumer"], true], + ]) { + const root = path.join(cwd, "layouts", name); + copyArtifacts(root, dirs); + if (copies) copyArtifacts(root, dirs.map((dir) => path.join("install", dir))); + console.log(`${cwd}: reanalyze split interface layout ${name}`); + const output = run(root); + assertIncludes(output, "Live Value +Split.Used.+g"); + assertIncludes(output, "Dead Value +Split.Unused.+g"); + assertIncludes(output, "optional argument split of function Used.+g is always supplied (1 calls)"); + assertNotIncludes(output, "Dead Value +Split.Used.+g"); + } + // A second distinct implementation of the same API is still ambiguous: + // do not arbitrarily pick one just because a split pair is now allowed. + fs.copyFileSync(path.join(fixture, "Split.ml"), path.join(cwd, "src", "Split_other.ml")); + const ambiguous = path.join(cwd, "layouts", "ambiguous"); + copyArtifacts(ambiguous, ["api", "objects", "consumer"]); + fs.mkdirSync(path.join(ambiguous, "other")); + compile(["-intf-suffix", ".ml", "-I", "api", "-c", "-o", + path.join(ambiguous, "other", "Split.cmo"), "src/Split_other.ml"]); + console.log(`${cwd}: reanalyze ambiguous split implementations`); + const conservative = run(ambiguous); + for (const unit of ["Split", "Split_other"]) { + assertIncludes(conservative, `Live Value +${unit}.Used.+g`); + assertIncludes(conservative, `Live Value +${unit}.Unused.+g`); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + +function runFunctorScanOrderTest(providerName, consumerName, assertions) { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const cmtDir = path.join(cwd, "_build/default/src/.regression_fixture.objs/byte"); + const root = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-unpack-order-")); + try { + for (const dir of ["first", "second"]) fs.mkdirSync(path.join(root, dir)); + const files = fs.readdirSync(cmtDir).filter((file) => /\.cmti?$/.test(file)); + const provider = `regression_fixture__${providerName}.cmt`; + const consumer = `regression_fixture__${consumerName}.cmt`; + const orders = []; + console.log(`${cwd}: reanalyze ${providerName} in both scan orders`); + for (const providerDir of ["first", "second"]) { + const otherDir = providerDir === "first" ? "second" : "first"; + for (const file of files) { + const dir = file === provider ? providerDir : otherDir; + fs.copyFileSync(path.join(cmtDir, file), path.join(root, dir, file)); + } + const output = child_process.execFileSync( + reanalyzeFile, + ["-ci", "-debug", "-native-build-target", ".", "-dce-cmt", root], + { cwd, encoding: "utf8", maxBuffer: 256 * 1024 * 1024 } + ); + assertIncludes(output, `Scanning ${provider} `); + assertIncludes(output, `Scanning ${consumer} `); + orders.push( + output.indexOf(`Scanning ${provider} `) < + output.indexOf(`Scanning ${consumer} `) + ); + for (const assertion of assertions) assertIncludes(output, assertion); + for (const file of files) { + const dir = file === provider ? providerDir : otherDir; + fs.unlinkSync(path.join(root, dir, file)); + } + } + if (orders[0] === orders[1]) { + throw new Error("Scan-order test did not reverse the unit order"); + } + } finally { + fs.rmSync(root, { recursive: true, force: true }); + } +} + +// The importer was compiled against digest_a. A mismatching Collision unit +// beside it must not hide that dependency or replace it when it is absent. +function runImportDigestSelectionTest() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const temp = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-digest-")); + const root = path.join(temp, "layout"); + try { + for (const dir of ["provider", "consumer"]) { + fs.mkdirSync(path.join(root, dir), { recursive: true }); + } + const copy = (library, unit, dir) => + fs.copyFileSync( + path.join(cwd, "_build/default", library, `.${library}.objs/byte`, unit), + path.join(root, dir, unit) + ); + copy("digest_a", "collision.cmt", "provider"); + copy("digest_b", "collision.cmt", "consumer"); + copy("digest_use", "use_collision.cmt", "consumer"); + const run = () => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-debug", "-native-build-target", ".", "-dce-cmt", root], + { cwd, encoding: "utf8", maxBuffer: 256 * 1024 * 1024 } + ); + console.log(`${cwd}: reanalyze import digest before sibling preference`); + const present = run(); + assertIncludes(present, "Live Value +Collision.Chosen_impl.+g"); + assertIncludes(present, "Dead Value +Collision.Unrelated_impl.+g"); + assertIncludes( + present, + "optional argument x of function Chosen_impl.+g is always supplied (1 calls)" + ); + assertNotIncludes(present, "Live Value +Collision.Unrelated_impl.+g"); + + fs.renameSync( + path.join(root, "provider/collision.cmt"), + path.join(temp, "collision.cmt") + ); + console.log(`${cwd}: reanalyze missing imported digest stays unresolved`); + const absent = run(); + assertIncludes(absent, "Dead Value +Collision.Unrelated_impl.+g"); + assertNotIncludes(absent, "Live Value +Collision.Unrelated_impl.+g"); + assertNotIncludes(absent, "function Unrelated_impl.+g is always supplied"); + } finally { + fs.rmSync(temp, { recursive: true, force: true }); + } } function checkSetup() { @@ -168,6 +1179,33 @@ function main() { checkSetup(); cleanBuildExamples(); runRegressionTests(); + runDuplicateLayoutTest(); + runByteNativeDuplicateTest(); + runDuplicateContextTest(); + runCompilationContextTests(); + runCompilationContextTests(true); + runSplitInterfaceTests(); + runFunctorScanOrderTest("Nested_arguments_packed", "Nested_arguments", [ + "optional argument foreign_nested of function Actual.N.+g is always supplied (1 calls)", + "optional argument foreign_nested of function Unrelated.N.+g is never used", + ]); + runFunctorScanOrderTest("Unpacked_functor", "Unpacked_functor_use", [ + "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)", + "optional argument x of function Unpacked_unused.+g is never used", + "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)", + ]); + runFunctorScanOrderTest("Attribution_sweep", "Partial_context_use", [ + "optional argument partial of function Foreign_supplied_arg.+g is always supplied (1 calls)", + "optional argument partial of function Foreign_omitted_arg.+g is never used", + ]); + runFunctorScanOrderTest("Unpacked_unused", "Unpacked_open", [ + "optional argument unused_open of function Unused_import.Victim.+g is never used", + "optional argument unused_open of function Unused_import.Called_victim.+g is never used", + "optional argument unused_open of function Mixed_open.Victim.+g is never used", + "optional argument foreign_alias of function Aliases.Foreign_alias_arg.+g is always supplied (1 calls)", + "optional argument foreign_include of function Aliases.Foreign_include_arg.+g is always supplied (1 calls)", + ]); + runImportDigestSelectionTest(); checkDiff(); console.log("Test successful!"); diff --git a/src/Compat.ml b/src/Compat.ml index ef1d6538..9a5b5ee0 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -22,6 +22,43 @@ let filter_map f = aux [] #endif +(* The interface reused by a native compilation can be recorded only as a + self-import: its .cmt has no direct interface digest or sibling .cmti. *) +let interfaceDigest (infos : Cmt_format.cmt_infos) = + match infos.cmt_interface_digest with + | Some _ as digest -> digest + | None -> Option.join (List.assoc_opt infos.cmt_modname infos.cmt_imports) + +(* Output paths, backend options, and -I directories do not identify a typed + compilation: byte/native and install copies must share it. Imports identify + the resolved interfaces, but not ordered implicit opens or preprocessing. + Retain those source/typing options in command-line order. *) +let sourceContext (infos : Cmt_format.cmt_infos) = + let rec typingArgs = function + | (("-open" | "-pp" | "-ppx" | "-for-pack" | "-keywords") as flag) + :: value :: rest -> + flag :: value :: typingArgs rest + | (( "-principal" | "-no-principal" | "-rectypes" | "-no-rectypes" + | "-labels" | "-nolabels" | "-modern" | "-app-funct" | "-no-app-funct" + | "-alias-deps" | "-no-alias-deps" | "-opaque" | "-noassert" | "-unsafe" + | "-nopervasives" | "-safe-string" | "-unsafe-string" + | "-strict-sequence" | "-no-strict-sequence" | "-strict-formats" + | "-no-strict-formats" | "-unboxed-types" | "-no-unboxed-types" + | "-keep-docs" | "-no-keep-docs" | "-keep-locs" | "-no-keep-locs" ) as + flag) + :: rest -> + flag :: typingArgs rest + | _ :: rest -> typingArgs rest + | [] -> [] + in + ( infos.cmt_modname, + infos.cmt_sourcefile, + infos.cmt_builddir, + infos.cmt_source_digest, + List.sort_uniq compare infos.cmt_imports, + typingArgs (Array.to_list infos.cmt_args) ) + |> fun key -> Digest.to_hex (Digest.string (Marshal.to_string key [])) + let getStringValue const = match const with #if OCAML_VERSION >= (4, 11, 0) | Parsetree.Pconst_string(s, _, _) -> s @@ -149,6 +186,19 @@ let getTypeVariant (tk: ('a, 'b) type_kind) = match tk with #endif | _ -> assert false +(* Whether a signature item occupies a runtime slot, as the positions of a + [Tcoerce_structure] count them: values (not primitives), extension + constructors, present modules and classes. *) +let isRuntimeField (si : Types.signature_item) = + match si with + | Types.Sig_value (_, {val_kind = Val_prim _}, _) -> false + | Types.Sig_value _ -> true + | Types.Sig_typext _ -> true + | Types.Sig_module (_, Mp_present, _, _, _) -> true + | Types.Sig_module (_, Mp_absent, _, _, _) -> false + | Types.Sig_class _ -> true + | _ -> false + let getSigModuleModtype si = match si with #if OCAML_VERSION >= (4, 08, 0) | Types.Sig_module(id, _, {Types.md_type=moduleType; md_loc=loc}, _, _) @@ -304,10 +354,13 @@ let applyArgOfExpression e = #endif (* Index of the .cmt/.cmti files under analysis, keyed by compilation unit - name. Populated before processing so declaration dependencies pointing at - other units (e.g. a functor result constrained by a module type defined in - another file) can be resolved regardless of processing order. *) + name. Populated before processing so declaration dependencies and identifier + occurrences pointing at other units (e.g. a functor result constrained by a + module type defined in another file) can be resolved regardless of + processing order. *) let cmtFilesByUnit : (string, string list) Hashtbl.t = Hashtbl.create 256 +let compilationContexts : (string, string) Hashtbl.t = Hashtbl.create 256 +let compilationContextsReady = ref false let unitNameOfCmtFile path = path |> Filename.basename |> Filename.remove_extension @@ -320,8 +373,352 @@ let registerCmtFile path = | Some paths -> paths | None -> [] in - if not (List.mem path existing) then - Hashtbl.replace cmtFilesByUnit unit (path :: existing) + if not (List.mem path existing) then ( + Hashtbl.replace cmtFilesByUnit unit (path :: existing); + Hashtbl.reset compilationContexts; + compilationContextsReady := false) + +#if OCAML_VERSION >= (5, 3, 0) +(* Per compilation unit: the implementation shape and structure (from the + .cmt), and the uid -> declaration table (merged from .cmt and .cmti). + Loaded on demand. *) +type unitInfo = { + context : string; + shape : Shape.t option; + structure : Typedtree.structure option; + uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; + cmtPath : string; (** the .cmt (or, failing that, the first file) loaded *) + unitImports : Misc.crcs; + occurrences : (Longident.t Location.loc * Shape_reduce.result) list; +} + +(* Keyed by the list of files a unit is loaded from, so that same-named units + in different build targets (e.g. two unwrapped libraries each defining + [Config]) do not share an entry. *) +let unitInfoCache : (string list * string option * string, unitInfo) Hashtbl.t = + Hashtbl.create 64 + +(* An implementation compiled against an interface gets its digest from + the sibling .cmti. Retain both files of every matching unit, for shapes + as well as declaration dependencies. Only dependency extraction may fan + out to unmatched candidates; shape resolution must not choose one. *) +let selectUnitFilesByDigest ~interfaceDigest ~allowUnmatched digest files = + match digest with + | None -> files + | Some digest -> + let stem = Filename.remove_extension in + let matchingStems = + files |> List.map stem |> List.sort_uniq compare + |> List.filter (fun base -> + [".cmt"; ".cmti"] + |> List.exists (fun ext -> interfaceDigest (base ^ ext) = Some digest)) + in + match matchingStems with + | [] when allowUnmatched -> files + | _ -> List.filter (fun path -> List.mem (stem path) matchingStems) files + +let candidateFilesForUnit ~currentCmtFile comp_unit = + let dir = Filename.dirname currentCmtFile in + let indexed = + match Hashtbl.find_opt cmtFilesByUnit comp_unit with + | Some paths -> paths + | None -> [] + in + (* Fall back to sibling files, for callers that did not register. *) + let siblings = + [".cmt"; ".cmti"] + |> List.concat_map (fun ext -> + [ + Filename.concat dir (comp_unit ^ ext); + Filename.concat dir (String.uncapitalize_ascii comp_unit ^ ext); + ]) + in + (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare + +(* Prefer local candidates within each artifact kind. An interface beside + the consumer must not hide its implementation in another directory, or + vice versa. Call only after selecting the recorded interface digest. *) +let preferSiblingUnitFiles ~currentCmtFile files = + let implementations, interfaces = + List.partition (fun path -> Filename.check_suffix path ".cmt") files + in + let prefer files = + match + List.filter + (fun path -> Filename.dirname path = Filename.dirname currentCmtFile) + files + with + | [] -> files + | siblings -> siblings + in + prefer implementations @ prefer interfaces + +(* Source/typing identity is only the initial partition. Identical clients + may link different implementations of the same interface. Refine that + partition by their resolved dependency contexts, transitively. This also + handles dependency cycles without recursive fingerprints or directory IDs: + actual byte/native/install copies keep the same class. *) +let compilationContext ~cmtFilePath infos = + if not !compilationContextsReady then ( + let metadata = Hashtbl.create 256 in + let read path = + match Hashtbl.find_opt metadata path with + | Some entry -> entry + | None -> + let entry = + try + let info = Cmt_format.read_cmt path in + Some + ( sourceContext info, + info.cmt_modname, + info.cmt_imports, + interfaceDigest info ) + with _ -> None + in + Hashtbl.add metadata path entry; + entry + in + let graph = Hashtbl.create 256 in + let rec collect path = + if not (Hashtbl.mem graph path) then + match read path with + | None -> () + | Some (source, unitName, imports, _) -> + Hashtbl.add graph path (source, []); + let dependencies = + imports + |> List.filter_map (fun (name, digest) -> + if name = unitName then None + else + let candidates = + candidateFilesForUnit ~currentCmtFile:path name + in + let interfaceDigest path = + match read path with + | Some (_, _, _, digest) -> digest + | None -> None + in + let candidates = + selectUnitFilesByDigest ~interfaceDigest + ~allowUnmatched:false digest candidates + in + let candidates = + preferSiblingUnitFiles ~currentCmtFile:path candidates + in + (* An implementation supplies shapes; a sibling interface + does not create a second implementation context. *) + let candidates = + match + List.filter + (fun p -> Filename.check_suffix p ".cmt") + candidates + with + | [] -> candidates + | implementations -> implementations + in + let candidates = + List.filter (fun p -> read p <> None) candidates + in + List.iter collect candidates; + Some (name, candidates)) + in + Hashtbl.replace graph path (source, dependencies) + in + Hashtbl.iter (fun _ files -> List.iter collect files) cmtFilesByUnit; + collect cmtFilePath; + let nodes = + Hashtbl.fold (fun path node acc -> (path, node) :: acc) graph [] + in + let partition signatures = + let classes = Hashtbl.create 256 in + signatures |> List.map snd |> List.sort_uniq compare + |> List.iteri (fun index signature -> Hashtbl.add classes signature index); + let colors = Hashtbl.create 256 in + List.iter + (fun (path, signature) -> + Hashtbl.add colors path (Hashtbl.find classes signature)) + signatures; + (colors, Hashtbl.length classes) + in + let initial, count = + partition (List.map (fun (path, (source, _)) -> (path, source)) nodes) + in + let rec refine colors count = + let next, nextCount = + partition + (List.map + (fun (path, (_, dependencies)) -> + let dependencies = + List.map + (fun (name, paths) -> + ( name, + List.map (Hashtbl.find colors) paths + |> List.sort_uniq compare )) + dependencies + |> List.sort_uniq compare + in + (path, (Hashtbl.find colors path, dependencies))) + nodes) + in + (* Refinement cannot merge classes, so an unchanged count is stable. *) + if nextCount = count then next else refine next nextCount + in + let colors = refine initial count in + Hashtbl.iter + (fun path color -> + Hashtbl.replace compilationContexts path + ("context:" ^ string_of_int color)) + colors; + compilationContextsReady := true); + match Hashtbl.find_opt compilationContexts cmtFilePath with + | Some context -> context + | None -> + (* A resolver reached an unindexed artifact outside the import graph. + Its equivalence is unproved: keep it separate rather than merging. *) + sourceContext infos ^ ":unindexed:" ^ cmtFilePath + +(* [imports] are the consumer's recorded imports: when the same unit name + exists in several build directories, the candidate whose interface digest + matches the one the consumer was compiled against is the actual + dependency. *) +let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = + let files = candidateFilesForUnit ~currentCmtFile comp_unit in + let digest = + match List.assoc_opt comp_unit imports with + | Some (Some digest) -> Some digest + | _ -> None + in + (* Both the import digest and the later sibling preference affect which + same-named unit a consumer can resolve. *) + let dir = Filename.dirname currentCmtFile in + let cacheKey = (files, Option.map Digest.to_hex digest, dir) in + match Hashtbl.find_opt unitInfoCache cacheKey with + | Some info -> Some info + | None -> ( + match files with + | [] -> None + | _ -> + let read path = + try Some (path, Cmt_format.read_cmt path) with _ -> None + in + let loaded = files |> List.filter_map read in + let interfaceDigest path = + match List.assoc_opt path loaded with + | Some infos -> interfaceDigest infos + | None -> ( + match read path with + | Some (_, infos) -> interfaceDigest infos + | None -> None) + in + let selected = + selectUnitFilesByDigest ~interfaceDigest ~allowUnmatched:false digest files + in + (* Prefer siblings only after selecting the recorded import digest: + a same-named sibling must not hide the actual dependency elsewhere. *) + let selected = + preferSiblingUnitFiles ~currentCmtFile selected + in + let loaded = + loaded |> List.filter (fun (path, _) -> List.mem path selected) + in + (* Copies of one compiled source (e.g. a library's objects and its + _build/install copy, or byte and native objects) are one unit: keep + the first of each. Distinct candidates of the same artifact kind + remain ambiguous, but a matching interface/implementation pair may + legitimately be stored in two different directories. *) + let loaded = + let seen = Hashtbl.create 4 in + loaded + |> List.filter (fun (path, (cmt_infos : Cmt_format.cmt_infos)) -> + let key = + (compilationContext ~cmtFilePath:path cmt_infos, cmt_infos.cmt_impl_shape <> None) + in + if Hashtbl.mem seen key then false + else ( + Hashtbl.replace seen key (); + true)) + in + let loaded = + let implementations, interfaces = + List.partition + (fun (path, _) -> Filename.check_suffix path ".cmt") + loaded + in + match (implementations, interfaces) with + | _ :: _ :: _, _ | _, _ :: _ :: _ -> [] + | _ -> loaded + in + let uidToDecl = Shape.Uid.Tbl.create 64 in + let shape = ref None in + let implementation = ref None in + loaded + |> List.iter (fun (path, (cmt_infos : Cmt_format.cmt_infos)) -> + Shape.Uid.Tbl.iter + (fun uid decl -> + if not (Shape.Uid.Tbl.mem uidToDecl uid) then + Shape.Uid.Tbl.replace uidToDecl uid decl) + cmt_infos.cmt_uid_to_decl; + match (!shape, cmt_infos.cmt_impl_shape) with + | None, Some _ -> + shape := cmt_infos.cmt_impl_shape; + implementation := Some (path, cmt_infos) + | _ -> ()); + let cmtPath, unitImports, occurrences, structure, context = + match (!implementation, loaded) with + | Some (path, cmt_infos), _ | None, (path, cmt_infos) :: _ -> + let structure = + match cmt_infos.cmt_annots with + | Implementation structure -> Some structure + | _ -> None + in + (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences, structure, + compilationContext ~cmtFilePath:path cmt_infos) + | None, [] -> ("", [], [], None, "") + in + let info = + {shape = !shape; structure; uidToDecl; cmtPath; unitImports; occurrences; context} + in + Hashtbl.replace unitInfoCache cacheKey info; + Some info) + +let locOfItemDeclaration = function + | Typedtree.Value {val_loc; _} -> Some val_loc + | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc + | _ -> None + +let declOfUid ~currentCmtFile ~imports + ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) uid = + match Shape.Uid.Tbl.find_opt local uid with + | Some decl -> Some decl + | None -> ( + match uid with + | Shape.Uid.Item {comp_unit; _} -> ( + match loadUnitInfo ~currentCmtFile ~imports comp_unit with + | Some {uidToDecl} -> Shape.Uid.Tbl.find_opt uidToDecl uid + | None -> None) + | _ -> None) + +let locOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with + | Some decl -> locOfItemDeclaration decl + | None -> None + +let moduleBindingOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with + | Some (Typedtree.Module_binding {mb_name = {loc}; mb_expr}) -> + Some (loc, mb_expr) + | _ -> None + +let moduleBindingLocOfUid ~currentCmtFile ~imports ~local uid = + match moduleBindingOfUid ~currentCmtFile ~imports ~local uid with + | Some (loc, _) -> Some loc + | None -> None + +let moduleTypeOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with + | Some (Typedtree.Module_type {mtd_type = Some {mty_type}}) -> Some mty_type + | _ -> None +#endif let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = #if OCAML_VERSION >= (5, 3, 0) @@ -366,7 +763,7 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = in let interface_digest_of_file path = match read_cmt path with - | Some infos -> infos.cmt_interface_digest + | Some infos -> interfaceDigest infos | None -> None in let loadedUnits : (string, Typedtree.item_declaration UidTbl.t list) Hashtbl.t @@ -399,25 +796,8 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = | Some (Some digest) -> Some digest | _ -> None in - match digest with - | None -> files - | Some digest -> ( - (* A .cmt compiled against an .mli carries no interface digest: the - digest is in the .cmti next to it. Group by stem so the whole unit - is kept when either file matches. *) - let stem path = Filename.remove_extension path in - let stems = files |> List.map stem |> List.sort_uniq compare in - let matching_stems = - stems - |> List.filter (fun stem -> - [".cmt"; ".cmti"] - |> List.exists (fun ext -> - interface_digest_of_file (stem ^ ext) = Some digest)) - in - match matching_stems with - | [] -> files - | _ -> files |> List.filter (fun path -> List.mem (stem path) matching_stems) - ) + selectUnitFilesByDigest ~interfaceDigest:interface_digest_of_file + ~allowUnmatched:true digest files in let decls_of_unit comp_unit = match Hashtbl.find_opt loadedUnits comp_unit with @@ -461,3 +841,790 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = |> List.map (fun (valueTo, valueFrom) -> (valueTo.Types.val_loc, valueFrom.Types.val_loc)) #endif + +(* Resolution of identifier occurrences to the implementation they denote. + + An occurrence such as [Inst.H.find_opt], where [H] is an instance of a + functor constrained by a named module type, has a [val_loc] pointing at the + module type item. Reducing the occurrence's shape (through the shapes of the + other compilation units) yields the implementation instead, so references + land on the right definition rather than on the shared module type item. + + Occurrences are keyed by their location and last name component, so that + distinct identifiers a ppx may emit at the same position do not collide. *) +type moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.t +#else + unit +#endif + +type definitionKey = Lexing.position * string + +(* Both occurrence and structural lookup must remember visited bindings. *) +type headVisited = +#if OCAML_VERSION >= (5, 3, 0) + Shape.Uid.t list * definitionKey list +#else + unit +#endif + +let noHeadVisited : headVisited = +#if OCAML_VERSION >= (5, 3, 0) + ([], []) +#else + () +#endif + +(* Source positions remain diagnostic locations, but are not identities when + the same source is compiled in different dependency/typing contexts. *) +type identResolutions = { + context : string; + valueKey : Types.value_description -> definitionKey; + valueImpl : Location.t -> string -> Location.t option; + (** occurrence location, last name -> implementation location *) + moduleShape : Location.t -> string -> moduleShape option; + (** occurrence location, last name -> shape of the module *) + projValue : moduleShape -> string -> Location.t option; + (** implementation of a value item of a module shape *) + projModule : moduleShape -> string -> moduleShape option; + (** shape of a module item of a module shape *) + moduleDefKey : Location.t -> string -> definitionKey option; + (** occurrence location, last name -> key of the module binding's + name, for a module (e.g. a functor) defined with [module X = ...] *) + moduleTypeOf : Location.t -> string -> Types.module_type option; + (** occurrence location, last name -> the module type a + [module type X = ...] declaration denotes *) + moduleTypeOfPath : Path.t -> Types.module_type option; + (** the module type a path denotes, in this unit's scope *) + shapeValueItems : moduleShape -> (string * Location.t) list; + (** the values a module shape exports, with their implementations; a + fallback when the module's signature cannot be expanded *) + bindingOfPath : + Path.t -> + (Location.t * Typedtree.module_expr * identResolutions option * int) option; + (** the binding a module path denotes, structurally, with the resolver + of its unit and the number of functor layers the path applied *) + headKeyOfPath : Path.t -> (definitionKey * int) option; + (** the binding key of the functor a module path denotes, + found structurally, and the arguments consumed *) + headKey : + headVisited -> Typedtree.module_expr -> (definitionKey * int) option; + (** visited bindings (start with [noHeadVisited]), module expression -> + the binding key of the functor it stands for, through + aliases and partial applications (possibly bound in other units, + resolved with those units' own occurrence data), and the number of + arguments those partial applications consumed; inline functors are + keyed by their own location *) + expandModuleType : Types.module_type -> Types.module_type; + (** follow module type aliases ([module type S = Base]) until a signature + or an unresolvable name is reached *) +} + +let emptyIdentResolutions = + { + context = ""; + valueKey = (fun vd -> (vd.Types.val_loc.loc_start, "")); + valueImpl = (fun _ _ -> None); + moduleShape = (fun _ _ -> None); + projValue = (fun _ _ -> None); + projModule = (fun _ _ -> None); + moduleDefKey = (fun _ _ -> None); + moduleTypeOf = (fun _ _ -> None); + moduleTypeOfPath = (fun _ -> None); + shapeValueItems = (fun _ -> []); + bindingOfPath = (fun _ -> None); + headKeyOfPath = (fun _ -> None); + headKey = (fun _ _ -> None); + expandModuleType = (fun mt -> mt); + } + +#if OCAML_VERSION >= (5, 3, 0) +(* Find, inside the implementation shape of the current unit, the shape of the + item defined with [uid]. Used for modules defined locally, whose occurrences + the compiler resolves to a uid rather than leaving a shape. *) +let rec findShapeByUid (shape : Shape.t) uid : Shape.t option = + if shape.uid = Some uid then Some shape + else + match shape.desc with + | Struct items -> + Shape.Item.Map.fold + (fun _item itemShape acc -> + match acc with + | Some _ -> acc + | None -> findShapeByUid itemShape uid) + items None + | Alias s -> findShapeByUid s uid + | Abs (_, body) -> findShapeByUid body uid + | _ -> None +#endif + +(* Whether occurrences can be resolved through shapes at all. Without it, + references through a functor parameter can only be credited conservatively, + to every implementation of the module type item. *) +let shapeResolutionAvailable = +#if OCAML_VERSION >= (5, 3, 0) + true +#else + false +#endif + +(* The shape of a functor application, as the compiler computes it for + [Tmod_apply]: reducing a projection of it lands in the functor's body, or + in the argument for items the body re-exports. *) +let applyShape (functorShape : moduleShape) (argumentShape : moduleShape) : + moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.app functorShape ~arg:argumentShape +#else + ignore functorShape; + argumentShape +#endif + +(* The shape standing for a functor parameter inside an application + ([Use (Make (P))] in the body of [functor (P : S) -> ...]): an empty + structure, so that a projection lands in [Make]'s body for the items it + defines and stays unresolved for those it takes from [P]. *) +let parameterShape : moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.dummy_mod +#else + () +#endif + +(* The shape of a generative application [F ()] ([Tmod_apply_unit]). *) +let applyUnitShape (functorShape : moduleShape) : moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.app functorShape ~arg:Shape.dummy_mod +#else + functorShape +#endif + +#if OCAML_VERSION >= (5, 3, 0) +(* Resolvers of other units, by .cmt path, for chasing definitions bound + there (aliases and partial applications of functors). *) +let resolverCache : (string, identResolutions) Hashtbl.t = Hashtbl.create 16 + +let rec makeResolver ~cmtFilePath ~context + ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) + ~(imports : Misc.crcs) ~(implShape : Shape.t option) + ~(occurrences : (Longident.t Location.loc * Shape_reduce.result) list) : + identResolutions = + let module Reduce = Shape_reduce.Make (struct + (* Bounds the reduction of recursive shapes; long alias and projection + chains must not be cut short by it. *) + let fuel = 100 + + let read_unit_shape ~unit_name = + match loadUnitInfo ~currentCmtFile:cmtFilePath ~imports unit_name with + | Some {shape} -> shape + | None -> None + end) in + let thisUnit = unitNameOfCmtFile cmtFilePath in + let compUnitShape name = + {Shape.uid = None; desc = Comp_unit name; approximated = false} + in + (* The uid of a declaration of this unit, by identifier. *) + let localUid (matches : Typedtree.item_declaration -> bool) = + Shape.Uid.Tbl.fold + (fun uid decl acc -> + match acc with + | Some _ -> acc + | None -> if matches decl then Some uid else None) + local None + in + let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~imports ~local in + let rec uidOfResult (result : Shape_reduce.result) = + match result with + | Resolved uid -> Some uid + | Resolved_alias (_, result) -> uidOfResult result + | _ -> None + in + let key (loc : Location.t) name = (loc.loc_start, loc.loc_end, name) in + let values = Hashtbl.create 64 in + let modules = Hashtbl.create 16 in + let moduleUids = Hashtbl.create 16 in + (* Occurrences sharing a key but spelled differently (distinct identifiers + a ppx emitted at one position, e.g. [A.f] and [B.f]) cannot be told apart + from the typed tree, whose paths differ from the written identifiers under + [open] and aliases: such keys are left unresolved, conservatively. *) + (* [Longident.last] and [flatten] are fatal on [Lapply] ([F(X).t]): such + occurrences are not values or modules of interest here. *) + let lidText (lid : Longident.t) = + let rec components suffix = function + | Longident.Lident name -> Some (name :: suffix) +#if OCAML_VERSION >= (5, 4, 0) + | Longident.Ldot ({txt = parent}, {txt = name}) -> + components (name :: suffix) parent +#else + | Longident.Ldot (parent, name) -> components (name :: suffix) parent +#endif + | Longident.Lapply _ -> None + in + components [] lid |> Option.map (String.concat ".") + in + (* Two occurrences with one key are the same identifier only if they are + spelled the same and the compiler resolved them the same way (the same + spelling can resolve differently under distinct local opens). *) + let identity (lid : Longident.t) (result : Shape_reduce.result) = + match lidText lid with + | None -> None + | Some text -> + let resolution = + match result with + | Unresolved shape -> Format.asprintf "%a" Shape.print shape + | result -> Format.asprintf "%a" Shape_reduce.print_result result + in + Some (text ^ " " ^ resolution) + in + let spelled = Hashtbl.create 64 in + let ambiguous = Hashtbl.create 4 in + occurrences + |> List.iter (fun ((lid : Longident.t Location.loc), result) -> + if not lid.loc.loc_ghost then + match identity lid.txt result with + | None -> () + | Some id -> ( + let k = key lid.loc (Longident.last lid.txt) in + match Hashtbl.find_opt spelled k with + | Some other when other <> id -> Hashtbl.replace ambiguous k () + | _ -> Hashtbl.replace spelled k id)); + occurrences + |> List.iter (fun ((lid : Longident.t Location.loc), result) -> + if (not lid.loc.loc_ghost) && lidText lid.txt <> None then + let name = Longident.last lid.txt in + let k = key lid.loc name in + if Hashtbl.mem ambiguous k then () + else + match result with + | Shape_reduce.Unresolved shape -> + (* Definition in another unit: reduce lazily, as a value and as a + module, depending on how the occurrence is used. *) + let uid = + lazy (Reduce.reduce_for_uid Env.empty shape |> uidOfResult) + in + Hashtbl.replace values k (lazy ( + match Lazy.force uid with + | Some uid -> locOfUid uid + | None -> None)); + Hashtbl.replace modules k (Some shape); + Hashtbl.replace moduleUids k uid + | _ -> ( + match uidOfResult result with + | Some uid -> + Hashtbl.replace values k (lazy (locOfUid uid)); + Hashtbl.replace modules k + (match implShape with + | Some impl -> findShapeByUid impl uid + | None -> None); + Hashtbl.replace moduleUids k (lazy (Some uid)) + | None -> ())); + let nonGhost (loc : Location.t option) = + match loc with Some l when not l.loc_ghost -> loc | _ -> None + in + let projValueLoc shape name = + let item = Shape.proj shape (Shape.Item.make name Value) in + match Reduce.reduce_for_uid Env.empty item |> uidOfResult with + | Some uid -> locOfUid uid |> nonGhost + | None -> None + in + let selfRef = ref emptyIdentResolutions in + let headKeyOfPathRef = ref (fun (_ : Path.t) -> (None : (definitionKey * int) option)) in + let moduleTypeOfPathRef = ref (fun (_ : Path.t) -> (None : Types.module_type option)) in + let bindingOfUid = + moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local + in + (* The resolver of the unit defining [uid]: this one, or that unit's own, + built from its occurrence data. *) + let resolverOfUid (uid : Shape.Uid.t) = + match uid with + | Shape.Uid.Item {comp_unit; _} when comp_unit = thisUnit -> Some !selfRef + | Shape.Uid.Item {comp_unit; _} -> + resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit + | _ -> None + in + (* Wrapped libraries introduce aliases to compilation units, such as + [Library.Unit.Member]. There is no module binding for the intermediate + compilation unit; reduce the complete path before structural lookup. *) + let rec globalPathShape (path : Path.t) = + match path with + | Pident id when Ident.global id -> Some (compUnitShape (Ident.name id)) + | Pdot (parent, name) -> + globalPathShape parent + |> Option.map (fun shape -> Shape.proj shape (Shape.Item.make name Module)) + | _ -> None + in + (* The binding a module path denotes, structurally: through units, + local bindings, and the bodies of applied functors, as in + [Outer (A).Inner]. Returns the binding, the resolver of its unit, + and the number of functor layers the path applied. *) + let activeBindingPaths = ref [] in + let rec bindingOfPath path = + if List.exists (Path.same path) !activeBindingPaths then None + else + let previous = !activeBindingPaths in + activeBindingPaths := path :: previous; + Fun.protect + ~finally:(fun () -> activeBindingPaths := previous) + (fun () -> bindingOfPathUnchecked path) + and bindingOfPathUnchecked (path : Path.t) : + (Location.t * Typedtree.module_expr * identResolutions option * int) + option = + let byShape = + match globalPathShape path with + | Some shape -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + Some (loc, definition, resolverOfUid uid, 0) + | None -> None) + | None -> None) + | None -> None + in + match byShape with + | Some binding -> Some binding + | None -> + match path with + | Pident id when Ident.global id -> ( + (* Unpacked modules have uid-less shapes. Keep the unit's structure + available so a projection can still find their actual binding. *) + let unitName = Ident.name id in + match loadUnitInfo ~currentCmtFile:cmtFilePath ~imports unitName with + | Some {structure = Some structure} -> + let definition : Typedtree.module_expr = + { + mod_desc = Tmod_structure structure; + mod_loc = Location.none; + mod_type = Types.Mty_signature structure.str_type; + mod_env = structure.str_final_env; + mod_attributes = []; + } + in + Some + ( Location.none, + definition, + resolverForUnit ~currentCmtFile:cmtFilePath ~imports unitName, + 0 ) + | _ -> None) + | Pident id -> ( + let uid = + localUid (function + | Typedtree.Module_binding {mb_id = Some mbId} -> + Ident.same mbId id + | _ -> false) + in + match uid with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> Some (loc, definition, Some !selfRef, 0) + | None -> None) + | None -> None) + | Pdot (parent, name) -> ( + match bindingOfPath parent with + | Some (_, definition, resolver, applied) -> ( + (* Peel the applied functor layers, then find the member, the + last binding of that name (also through [include]s). *) + let rec memberIn ~visited ~resolver (e : Typedtree.module_expr) + applied = + if List.memq e visited then None + else + let visited = e :: visited in + let lookup = + match resolver with + | Some (r : identResolutions) -> r.bindingOfPath + | None -> bindingOfPath + in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> + memberIn ~visited ~resolver inner applied + | Tmod_functor (_, inner) when applied > 0 -> + memberIn ~visited ~resolver inner (applied - 1) + | Tmod_apply (functorExpr, _, _) -> + memberIn ~visited ~resolver functorExpr (applied + 1) + | Tmod_apply_unit functorExpr -> + memberIn ~visited ~resolver functorExpr (applied + 1) + | Tmod_ident (p, _) when applied = 0 -> ( + (* [include Helpers] in a body: [Helpers] is local to the + unit defining the body, so its resolver must look it up. *) + match lookup (Pdot (p, name)) with + | Some (loc, expr, memberResolver, 0) -> + Some (loc, expr, memberResolver) + | _ -> None) + | Tmod_ident (p, _) -> ( + (* An applied functor named by a path ([include Mid (A)] in a + body): its own definition, with the layers it consumed. *) + match lookup p with + | Some (_, definition, resolver, applied') -> + memberIn ~visited ~resolver definition (applied + applied') + | None -> None) + | Tmod_structure structure when applied = 0 -> + structure.str_items + |> List.fold_left + (fun acc (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module ({mb_name = {txt = Some n}} as mb) + when n = name -> + Some (mb.mb_name.loc, mb.mb_expr, resolver) + | Tstr_recmodule mbs -> ( + match + mbs + |> List.find_opt + (fun (mb : Typedtree.module_binding) -> + mb.mb_name.txt = Some name) + with + | Some mb -> + Some (mb.mb_name.loc, mb.mb_expr, resolver) + | None -> acc) + | Tstr_include {incl_mod} -> ( + match memberIn ~visited ~resolver incl_mod 0 with + | Some member -> Some member + | None -> acc) + | _ -> acc) + None + | _ -> None + in + match memberIn ~visited:[] ~resolver definition applied with + | Some (loc, expr, memberResolver) -> + Some (loc, expr, memberResolver, 0) + | None -> None) + | None -> None) + | Papply (functorPath, _) -> ( + match bindingOfPath functorPath with + | Some (loc, definition, resolver, applied) -> + Some (loc, definition, resolver, applied + 1) + | None -> None) + | _ -> None + in + let self : identResolutions = { + context; + valueKey = (fun vd -> + let context = match resolverOfUid vd.Types.val_uid with + | Some resolver -> resolver.context + | None -> context + in + (vd.val_loc.loc_start, context)); + valueImpl = + (fun loc name -> + match Hashtbl.find_opt values (key loc name) with + | Some l -> Lazy.force l |> nonGhost + | None -> None); + moduleShape = + (fun loc name -> + match Hashtbl.find_opt modules (key loc name) with + | Some s -> s + | None -> None); + projValue = projValueLoc; + projModule = + (fun shape name -> + Some (Shape.proj shape (Shape.Item.make name Module))); + moduleDefKey = + (fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> + moduleBindingLocOfUid ~currentCmtFile:cmtFilePath ~imports ~local + uid + |> nonGhost + |> Option.map (fun loc -> + let context = match resolverOfUid uid with + | Some resolver -> resolver.context + | None -> context + in + (loc.Location.loc_start, context)) + | None -> None) + | None -> None); + moduleTypeOf = + (fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> + moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid + | None -> None) + | None -> None); + moduleTypeOfPath = (fun path -> !moduleTypeOfPathRef path); + shapeValueItems = + (* Values at any depth of submodules; [visited] guards recursive + shapes. Functor members have no values to reference. *) + (let rec items visited (shape : Shape.t) path = + let reduced = Reduce.reduce Env.empty shape in + if List.memq reduced visited then [] + else + let visited = reduced :: visited in + match reduced.desc with + | Struct fields -> + Shape.Item.Map.fold + (fun (name, kind) _ acc -> + match kind with + | Shape.Sig_component_kind.Value -> ( + match projValueLoc shape name with + | Some loc -> (String.concat "." (path @ [name]), loc) :: acc + | None -> acc) + | Shape.Sig_component_kind.Module -> + items visited + (Shape.proj shape (Shape.Item.make name Module)) + (path @ [name]) + @ acc + | _ -> acc) + fields [] + | Alias aliased -> items visited aliased path + | _ -> [] + in + fun shape -> items [] shape []); + bindingOfPath = (fun path -> bindingOfPath path); + headKeyOfPath = (fun path -> !headKeyOfPathRef path); + headKey = + (let rec unwrap (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> unwrap inner + | _ -> e + in + (* The key of a binding found for a module expression: a functor is + keyed by the binding; an alias or a partial application is chased + with the resolver of the unit binding it. *) + let keyOfBinding (uids, bindings) (loc : Location.t) + (definition : Typedtree.module_expr) resolver = + let context = match resolver with + | Some (resolver : identResolutions) -> resolver.context + | None -> context + in + let key = (loc.loc_start, context) in + if loc.loc_ghost || List.mem key bindings then None + else + let visited = (uids, key :: bindings) in + match (unwrap definition).mod_desc with + | Tmod_apply _ | Tmod_apply_unit _ | Tmod_ident _ -> ( + (* An unresolved alias is not a new functor definition. Giving + it its own key would bypass the unknown-head escape. *) + match resolver with + | Some (resolver : identResolutions) -> + resolver.headKey visited definition + | None -> None) + | Tmod_unpack _ -> + (* A first-class module: the functor it holds is not known + here. *) + None + | _ -> Some (key, 0) + in + headKeyOfPathRef := + (fun path -> + match bindingOfPath path with + | Some (loc, definition, resolver, applied) -> ( + match keyOfBinding noHeadVisited loc definition resolver with + | Some (loc, consumed) -> Some (loc, consumed + applied) + | None -> None) + | None -> None); + let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) | Tmod_apply_unit functorExpr -> ( + match headKey visited functorExpr with + | Some (loc, consumed) -> Some (loc, consumed + 1) + | None -> None) + | Tmod_constraint (inner, _, _, _) -> headKey visited inner + | Tmod_functor _ -> Some ((e.mod_loc.loc_start, context), 0) + | Tmod_ident (path, lid) -> ( + let byOccurrence = + match Longident.last lid.txt with + | exception Misc.Fatal_error -> None + | name -> ( + match Hashtbl.find_opt moduleUids (key lid.loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid when List.mem uid (fst visited) -> Some None + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + Some (keyOfBinding (uid :: fst visited, snd visited) loc definition + (resolverOfUid uid)) + | None -> None) + | _ -> None) + | None -> None) + in + match byOccurrence with + | Some head -> head + | None -> ( + (* No usable occurrence (e.g. [Outer (A).Inner]): structurally. *) + match bindingOfPath path with + | Some (loc, definition, resolver, 0) -> + keyOfBinding visited loc definition resolver + | _ -> None)) + | _ -> None + in + headKey); + expandModuleType = + ( (* Shape of a module path rooted at a compilation unit or at a module + of the current unit. *) + let rec moduleShapeOfPath (path : Path.t) = + match path with + | Pident id when Ident.global id -> Some (compUnitShape (Ident.name id)) + | Pident id -> ( + let uid = + localUid (function + | Typedtree.Module_binding {mb_id = Some mbId} -> + Ident.same mbId id + | _ -> false) + in + match (uid, implShape) with + | Some uid, Some impl -> findShapeByUid impl uid + | _ -> None) + | Pdot (p, name) -> ( + match moduleShapeOfPath p with + | Some shape -> Some (Shape.proj shape (Shape.Item.make name Module)) + | None -> None) + | Papply (functorPath, argumentPath) -> ( + (* [Outer (A).S]: the application's shape, reduced on projection. *) + match + (moduleShapeOfPath functorPath, moduleShapeOfPath argumentPath) + with + | Some functorShape, Some argumentShape -> + Some (Shape.app functorShape ~arg:argumentShape) + | _ -> None) + | _ -> None + in + let moduleTypeOfUid = moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local in + let rec hasApply (path : Path.t) = + match path with + | Papply _ -> true + | Pdot (p, _) -> hasApply p + | _ -> false + in + (* [module type S] in the body of a functor the path applies, as in + [Outer (A).S]: found structurally, whatever the argument. *) + let rec moduleTypeInBody ~visited ~resolver + (e : Typedtree.module_expr) applied name = + if List.memq e visited then None + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> + moduleTypeInBody ~visited ~resolver inner applied name + | Tmod_functor (_, inner) when applied > 0 -> + moduleTypeInBody ~visited ~resolver inner (applied - 1) name + | Tmod_apply (functorExpr, _, _) | Tmod_apply_unit functorExpr -> + moduleTypeInBody ~visited ~resolver functorExpr (applied + 1) name + | Tmod_ident (p, _) -> ( + (* An aliased member ([module Alias = Holder]) or an applied one: + follow it in the unit defining the body. *) + let r : identResolutions = + match resolver with Some r -> r | None -> !selfRef + in + if applied = 0 then r.moduleTypeOfPath (Pdot (p, name)) + else + match r.bindingOfPath p with + | Some (_, definition, resolver, applied') -> + moduleTypeInBody ~visited ~resolver definition + (applied + applied') name + | None -> None) + | Tmod_structure structure when applied = 0 -> + structure.str_items + |> List.fold_left + (fun acc (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_modtype {mtd_name; mtd_type = Some {mty_type}} + when mtd_name.txt = name -> + Some mty_type + | Tstr_include {incl_mod} -> ( + match + moduleTypeInBody ~visited ~resolver incl_mod 0 name + with + | Some mt -> Some mt + | None -> acc) + | _ -> acc) + None + | _ -> None + and moduleTypeOfPath (path : Path.t) = + match path with + | Pdot (p, name) when hasApply p -> ( + match bindingOfPath p with + | Some (_, definition, resolver, applied) -> + moduleTypeInBody ~visited:[] ~resolver definition applied name + | None -> None) + | Pdot (p, name) -> ( + match moduleShapeOfPath p with + | Some shape -> ( + let item = Shape.proj shape (Shape.Item.make name Module_type) in + match Reduce.reduce_for_uid Env.empty item |> uidOfResult with + | Some uid -> moduleTypeOfUid uid + | None -> None) + | None -> None) + | Pident id -> + (* A module type of the current unit, by identifier identity (the + same name may be declared in several scopes). *) + Shape.Uid.Tbl.fold + (fun _uid decl acc -> + match (acc, decl) with + | None, Typedtree.Module_type {mtd_id; mtd_type = Some {mty_type}} + when Ident.same mtd_id id -> + Some mty_type + | _ -> acc) + local None + | _ -> None + in + (* The declared type of the module a path denotes: a strengthened + signature turns submodules into aliases ([module N = Arg.N]), + which expose no items. *) + let moduleTypeOfModulePath (path : Path.t) = + match moduleShapeOfPath path with + | Some shape -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match declOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid with + | Some (Typedtree.Module_binding {mb_expr}) -> Some mb_expr.mod_type + | Some (Typedtree.Module {md_type}) -> Some md_type.mty_type + | _ -> None) + | None -> None) + | None -> None + in + (* Aliases are followed until a signature is reached; the visited + paths break cycles. *) + moduleTypeOfPathRef := moduleTypeOfPath; + let rec expand visited (moduleType : Types.module_type) = + match moduleType with + | Mty_ident path when not (List.exists (Path.same path) visited) -> ( + match moduleTypeOfPath path with + | Some expanded -> expand (path :: visited) expanded + | None -> moduleType) + | Mty_alias path when not (List.exists (Path.same path) visited) -> ( + match moduleTypeOfModulePath path with + | Some expanded -> expand (path :: visited) expanded + | None -> moduleType) + | _ -> moduleType + in + expand []); + } in + selfRef := self; + self + +and resolverForUnit ~currentCmtFile ~imports comp_unit = + match loadUnitInfo ~currentCmtFile ~imports comp_unit with + | Some info when info.cmtPath <> "" -> ( + match Hashtbl.find_opt resolverCache info.cmtPath with + | Some resolver -> Some resolver + | None -> + let resolver = + makeResolver ~cmtFilePath:info.cmtPath ~context:info.context ~local:info.uidToDecl + ~imports:info.unitImports ~implShape:info.shape + ~occurrences:info.occurrences + in + Hashtbl.replace resolverCache info.cmtPath resolver; + Some resolver) + | _ -> None +#endif + +let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : + identResolutions = +#if OCAML_VERSION >= (5, 3, 0) + makeResolver ~cmtFilePath ~context:(compilationContext ~cmtFilePath cmt_infos) + ~local:cmt_infos.cmt_uid_to_decl + ~imports:cmt_infos.cmt_imports ~implShape:cmt_infos.cmt_impl_shape + ~occurrences:cmt_infos.cmt_ident_occurrences +#else + let _ = (cmtFilePath, cmt_infos) in + emptyIdentResolutions +#endif + +#if OCAML_VERSION < (5, 3, 0) +let compilationContext ~cmtFilePath:_ infos = sourceContext infos +#endif diff --git a/src/DeadCode.ml b/src/DeadCode.ml index ee77c7dc..4c6e8c7a 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -8,16 +8,101 @@ let processSignature ~doValues ~doTypes (signature : Types.signature) = ~path:[!Common.currentModuleName] sig_item) +(* Restrict the declarations taken from a file's signature to definitions of + the file itself, see [DeadValue.setSignatureValueFilter]. *) +let setSignatureValueFilter ~(fileName : string option) ~buildDir + ~moduleTypeRanges = + match fileName with + | Some fileName -> + DeadValue.setSignatureValueFilter ~fileName ~buildDir ~moduleTypeRanges + | None -> DeadValue.isSignatureValueDeclaration := fun _ -> true + +(* Locations of every [module type] declaration of a file, at any depth. *) +let rec moduleTypeRangesOfStructure (structure : Typedtree.structure) = + structure.str_items + |> List.concat_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_modtype _ -> [item.str_loc] + | Tstr_module mb -> moduleTypeRangesOfModuleExpr mb.mb_expr + | Tstr_recmodule mbs -> + mbs + |> List.concat_map (fun (mb : Typedtree.module_binding) -> + moduleTypeRangesOfModuleExpr mb.mb_expr) + | Tstr_include {incl_mod} -> moduleTypeRangesOfModuleExpr incl_mod + | _ -> []) + +and moduleTypeRangesOfModuleExpr (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_structure structure -> moduleTypeRangesOfStructure structure + | Tmod_constraint (inner, _, Tmodtype_explicit mty, _) -> + moduleTypeRangesOfModuleExpr inner @ moduleTypeRangesOfModuleType mty + | Tmod_constraint (inner, _, _, _) -> moduleTypeRangesOfModuleExpr inner + | Tmod_functor (param, body) -> + (* A parameter's module type, whose items the result may expose. *) + moduleTypeRangesOfFunctorParameter param + @ moduleTypeRangesOfModuleExpr body + | Tmod_apply (functorExpr, argumentExpr, _) -> + (* An inline functor's body, and an argument's members that flow into + the result. *) + moduleTypeRangesOfModuleExpr functorExpr + @ moduleTypeRangesOfModuleExpr argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> moduleTypeRangesOfModuleExpr functorExpr +#endif + | _ -> [] + +and moduleTypeRangesOfFunctorParameter (param : Typedtree.functor_parameter) = + match param with + | Named (_, _, mty) -> moduleTypeRangesOfModuleType mty + | Unit -> [] + +and moduleTypeRangesOfSignature (signature : Typedtree.signature) = + signature.sig_items + |> List.concat_map (fun (item : Typedtree.signature_item) -> + match item.sig_desc with + | Tsig_modtype _ -> [item.sig_loc] + | Tsig_module md -> moduleTypeRangesOfModuleType md.md_type + | Tsig_recmodule mds -> + mds + |> List.concat_map (fun (md : Typedtree.module_declaration) -> + moduleTypeRangesOfModuleType md.md_type) + | Tsig_include {incl_mod} -> moduleTypeRangesOfModuleType incl_mod + | _ -> []) + +and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = + match moduleType.mty_desc with + | Tmty_signature signature -> moduleTypeRangesOfSignature signature + | Tmty_functor (param, body) -> + moduleTypeRangesOfFunctorParameter param @ moduleTypeRangesOfModuleType body + | Tmty_with (base, constraints) -> + (* A [with module type S = sig ... end] constraint carries a module type + whose items must not count as declarations either. *) + moduleTypeRangesOfModuleType base + @ (constraints + |> List.concat_map (fun (_, _, (constraint_ : Typedtree.with_constraint)) -> + match constraint_ with + | Twith_modtype mty | Twith_modtypesubst mty -> + mty.mty_loc :: moduleTypeRangesOfModuleType mty + | _ -> [])) + | Tmty_typeof moduleExpr -> moduleTypeRangesOfModuleExpr moduleExpr + | _ -> [] + let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = (match cmt_infos.cmt_annots with | Interface signature -> ProcessDeadAnnotations.signature signature; + setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~buildDir:cmt_infos.cmt_builddir + ~moduleTypeRanges:(moduleTypeRangesOfSignature signature); processSignature ~doValues:true ~doTypes:true signature.sig_type | Implementation structure -> let cmtiExists = Sys.file_exists ((cmtFilePath |> Filename.remove_extension) ^ ".cmti") in ProcessDeadAnnotations.structure ~doGenType:(not cmtiExists) structure; + setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~buildDir:cmt_infos.cmt_builddir + ~moduleTypeRanges:(moduleTypeRangesOfStructure structure); processSignature ~doValues:true ~doTypes:false structure.str_type; let doExternals = (* This is already handled at the interface level, avoid issues in inconsistent locations @@ -28,8 +113,11 @@ let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = let cmt_value_dependencies = Compat.extractValueDependencies ~cmtFilePath cmt_infos in + let cmt_ident_resolutions = + Compat.resolveIdentOccurrences ~cmtFilePath cmt_infos + in DeadValue.processStructure ~doTypes:true ~doExternals - ~cmt_value_dependencies structure + ~cmt_value_dependencies ~cmt_ident_resolutions structure | _ -> ()); DeadType.TypeDependencies.forceDelayedItems (); DeadType.TypeDependencies.clear () diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 03da9d6b..13bcf6e8 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -5,6 +5,8 @@ let active () = true type item = { posTo : Lexing.position; + posToImpl : Lexing.position option; + (** Shape-resolved implementation, used when [posTo] is not a declaration. *) argNames : string list; argNamesMaybe : string list; } @@ -46,12 +48,15 @@ let rec fromTypeExpr (texpr : Types.type_expr) = | Tsubst _ -> fromTypeExpr (Compat.getTSubst (Compat.get_desc texpr)) | _ -> [] -let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) ~path +let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) + ?(locToImpl : Location.t option) ~path (argNames, argNamesMaybe) = if active () then ( let posTo = locTo.loc_start in + let posToImpl = Option.map (fun (l : Location.t) -> l.loc_start) locToImpl in let posFrom = locFrom.loc_start in - delayedItems := {posTo; argNames; argNamesMaybe} :: !delayedItems; + delayedItems := + {posTo; posToImpl; argNames; argNamesMaybe} :: !delayedItems; if !Common.Cli.debug then Log_.item "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ @@ -61,17 +66,54 @@ let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) ~path (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) +(* A call through a functor parameter, credited to the implementation the + functor was applied to. When [posTo] could only be resolved to a module + type item rather than a declaration (no shapes, e.g. before OCaml 5.3, or + an argument without a resolvable shape), the call is forwarded to the + implementations of that item, conservatively. *) +let addCallToImplementation ~(posTo : Lexing.position) (argNames, argNamesMaybe) + = + if active () then + delayedItems := + {posTo; posToImpl = None; argNames; argNamesMaybe} + :: !delayedItems + +(* Once all declarations are known, calls whose target is not a declaration + but have a shape-resolved implementation are attributed to it. Must run + before [forwardDelayedItems] and [forceDelayedItems]. *) +let settleDelayedItems () = + delayedItems := + !delayedItems + |> List.map (fun item -> + match (item.posToImpl, PosHash.find_opt decls item.posTo) with + | Some posToImpl, None -> {item with posTo = posToImpl; posToImpl = None} + | _ -> item) + (* Calls recorded against a signature item that is not a declaration (e.g. a [val] inside a named module type) are re-attributed to the implementation. Must run before [forceDelayedItems]. *) -let forwardDelayedItems ~(posFrom : Lexing.position) ~(posTo : Lexing.position) - = - let forwarded = +let forwardDelayedItems dependencies = + (* Traverse each original call independently. A diamond or cycle in the + signature graph must not multiply a call, while distinct calls with the + same argument labels must remain distinct. Declarations are endpoints: + ordinary function references handle their optional-argument state. *) + delayedItems := !delayedItems - |> List.filter_map (fun item -> - if item.posTo = posFrom then Some {item with posTo} else None) - in - delayedItems := forwarded @ !delayedItems + |> List.concat_map (fun item -> + let rec visit seen pos = + if PosSet.mem pos seen then seen + else + let seen = PosSet.add pos seen in + if PosHash.mem decls pos then seen + else + PosSet.fold + (fun target seen -> visit seen target) + (PosHash.findSet dependencies pos) + seen + in + visit PosSet.empty item.posTo + |> PosSet.elements + |> List.map (fun posTo -> {item with posTo})) let forceDelayedItems () = let items = !delayedItems |> List.rev in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 332b74b8..5bba9083 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -15,10 +15,14 @@ let checkAnyValueBindingWithNoSideEffects ~sideEffects:false | _ -> () +(* See [registerPackedModule], defined once its helpers are. *) +let registerPackedModuleRef = ref (fun (_ : Typedtree.value_binding) -> ()) + let collectValueBinding super self (vb : Typedtree.value_binding) = let oldCurrentBindings = !Current.bindings in let oldLastBinding = !Current.lastBinding in checkAnyValueBindingWithNoSideEffects vb; + !registerPackedModuleRef vb; let loc = match vb.vb_pat.pat_desc with #if OCAML_VERSION < (5, 2, 0) @@ -95,7 +99,619 @@ let collectValueBinding super self (vb : Typedtree.value_binding) = Current.lastBinding := oldLastBinding; r -let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args = +(* Implementation locations and compilation identities resolved through + shapes. See [Compat.resolveIdentOccurrences]. *) +let identResolutions = ref Compat.emptyIdentResolutions + +type definitionKey = Compat.definitionKey + +let definitionKey ?(resolutions = !identResolutions) pos = + (pos, resolutions.Compat.context) + +let keyToString (pos, _) = posToString pos + +module DefinitionSet = Set.Make (struct + type t = definitionKey + let compare = compare +end) + +type definitionRange = definitionKey * Lexing.position + +type functorParameter = { + paramId : Ident.t; + functorDef : definitionKey; + (** position of the name of the module binding defining the functor *) + paramIndex : int; (** position of the parameter, for curried functors *) + prefix : string list; + (** for an alias of (a submodule of) a parameter, [module N = M.Sub], + the path from the parameter: ["Sub"] *) + paramType : Types.module_type option; + (** the parameter's declared module type, for module types rooted at + the parameter ([module type T = M.T]) *) +} + +let functorParameters : functorParameter list ref = ref [] + +let findFunctorParameter ?(parameters = !functorParameters) (path : Path.t) = + match Path.head path with + | head -> List.find_opt (fun p -> Ident.same p.paramId head) parameters + | exception _ -> None + +let isFunctorParameterPath path = findFunctorParameter path <> None + +(* Calls with optional arguments made through a functor parameter, keyed by + the functor definition, parameter index, and path of the value within the + parameter (e.g. ["g"] for [M.g], ["Sub"; "g"] for [M.Sub.g]). They are + credited to the actual arguments at application sites, once all files are + scanned. *) +type parameterCall = { + call : string list * string list; (** supplied, maybe supplied *) + callFrom : Location.t; + callTo : Location.t; (** the module type item *) + callToImpl : Location.t option; + callPath : Path.t; +} + +let parameterCalls : + (definitionKey * int * string list, parameterCall list) Hashtbl.t = + Hashtbl.create 16 + +type argumentResolver = + | Direct of (string list -> Location.t option) + (** implementation of a value of the actual argument, by path *) + | ViaParameter of definitionKey * int * string list + (** the argument is (a submodule of) a parameter of the enclosing + functor: resolved through that functor's own applications *) + +(* The functor an application chain applies. *) +type functorHead = + | Key of definitionKey * int + (** a functor's key, and the arguments partial applications already + consumed, as in [module G = F (A)] followed by [G (B)] *) + | Partial of definitionKey * functorHead + (** application expression supplying the already consumed arguments; + retained so separate partial bindings keep their own context *) + | ParamHead of definitionKey * int * string list * int + (** (a submodule of) a parameter of the enclosing functor, applied in + its body: the functor's key, the parameter's index, the path within + the parameter, and the arguments already consumed. Which functors it + stands for is known once all applications are recorded. *) + | Packed of definitionKey * int + (** a first-class module unpacked from a value, [(val packed : FT)]: + the position of the value's binding, and the arguments consumed. + Resolved once all files are scanned, through [packedModules]. *) + +type delayedApplication = { + applicationId : int; + (** the application chain ([F (A) (B)]) the argument belongs to *) + appliedFunctor : functorHead; + argIndex : int; + (** index of the parameter the argument is for; relative to the + functor a [ParamHead] resolves to *) + resolver : argumentResolver; + argHead : string list -> functorHead option; + (** the functor (a submodule of) the argument denotes, when the + argument is passed on to a higher-order functor parameter *) + bindings : (definitionKey * int) list; + (** for an application derived from a parameter-headed one ([F (M)] in + the body of [Outer (F) (M)]): the application of each enclosing + functor the head came through, by the functor's key. A parameter + of such a functor then resolves through that application only, + so that [M] pairs with the [F] of the same application. *) + argRange : definitionRange list; + (** source ranges of the argument's definition, see [escapedRanges] *) +} + +let delayedApplications : delayedApplication list ref = ref [] +let nextApplicationId = ref 0 + +let applicationIdsByPosition : (definitionKey, int list) Hashtbl.t = + Hashtbl.create 16 + +let applicationPrefixes : (int, definitionKey list) Hashtbl.t = + Hashtbl.create 16 + +(* Unit-only applications have no argument record but can still extend a + partial context that a later application must inherit. *) +let applicationHeads : (int, functorHead) Hashtbl.t = Hashtbl.create 16 + +let prefixApplicationIds sources = + let rec first = function + | [] -> [] + | pos :: rest -> ( + match Hashtbl.find_opt applicationIdsByPosition pos with + | Some ids -> ids + | None -> first rest) + in + first sources + +let rec extendsApplication ?(visited = []) applicationId prefixId = + applicationId = prefixId + || ((not (List.mem applicationId visited)) + && match Hashtbl.find_opt applicationPrefixes applicationId with + | None -> false + | Some sources -> + prefixApplicationIds sources + |> List.exists + (fun parent -> + extendsApplication ~visited:(applicationId :: visited) + parent prefixId)) + +let compatibleApplications left right = + extendsApplication left right || extendsApplication right left + +(* A completed application is a more specific context than its prefix. + Do not replace it with the prefix when inheriting another binding set. *) +let mergeBindings bindings = + bindings + |> List.fold_left + (fun acc ((def, id) as binding) -> + match List.assoc_opt def acc with + | Some prior when extendsApplication prior id -> acc + | _ -> binding :: List.remove_assoc def acc) + [] + |> List.sort compare + +(* The applications of the functor keyed [functorDef] supplying its parameter + [argIndex], under [bindings]. *) +let applicationsOf ~bindings functorDef argIndex = + !delayedApplications + |> List.filter (fun {applicationId; appliedFunctor; argIndex = index; + bindings = own} -> + appliedFunctor = Key (functorDef, 0) + && index = argIndex + && (match List.assoc_opt functorDef bindings with + | Some id -> + extendsApplication applicationId id + || (match List.assoc_opt functorDef own with + | Some ownId -> compatibleApplications ownId id + | None -> false) + | None -> true) + (* A template instantiated through different enclosing applications + retains its source ID. Its inherited context must agree too, + before the caller prepends [own] to the requested bindings. *) + && List.for_all + (fun (def, id) -> + match List.assoc_opt def bindings with + | Some requested -> compatibleApplications id requested + | None -> true) + own) + +(* Functors whose applications cannot all be seen: packed as first-class + modules that flow somewhere other than a direct [(val p)], or passed to + an application whose head cannot be chased. Calls through their parameters + are forwarded to every implementation of the item; a functor never applied + nor escaping credits nothing, as its calls never run. A module that + escapes takes the functors nested in its definition with it: those are + covered by source ranges rather than keys. *) +let escapedHeads : functorHead list ref = ref [] + +let escapedRanges : definitionRange list ref = ref [] + +(* Positions of the value expressions that are the operand of a + [(val e : S)], and the values (by binding position) used anywhere else: + a packed module used only through direct unpacks is followed precisely, + any other use makes it escape. *) +let unpackOperands = ref PosSet.empty +let usedOutsideUnpack = ref DefinitionSet.empty + +let inRanges ((pos : Lexing.position), context) ranges = + ranges + |> List.exists (fun (((start : Lexing.position), rangeContext), (stop : Lexing.position)) -> + context = rangeContext && start.pos_fname = pos.pos_fname + && start.pos_cnum <= pos.pos_cnum + && pos.pos_cnum <= stop.pos_cnum) + +let rec functorHeadToString head = + match head with + | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> keyToString) consumed + | Partial (pos, head) -> + Printf.sprintf "partial(%s,%s)" (pos |> keyToString) + (functorHeadToString head) + | ParamHead (def, index, components, consumed) -> + Printf.sprintf "param(%s,%d,%s)+%d" (def |> keyToString) index + (String.concat "." components) + consumed + | Packed (pos, consumed) -> + Printf.sprintf "packed(%s)+%d" (pos |> keyToString) consumed + +(* [let packed = (module M : S)]: what the first-class value holds, by the + position of its binding, for [(val packed : S)] used as a functor or as an + argument, in any file. Computed where the value is bound, with that file's + resolver. Other ways to obtain a first-class module (function results, + patterns) are not chased: they stay conservative. *) +type packedModule = { + packedHead : functorHead option; + packedShape : Compat.moduleShape option; + packedConcrete : Types.module_type option; + packedResolveValue : string list -> Location.t option; + packedRange : definitionRange list; + packedExpr : Typedtree.module_expr; +} + +let packedModules : (definitionKey, packedModule) Hashtbl.t = + Hashtbl.create 4 + +(* Whether a packed module expression is the right-hand side of a value + binding registered in [packedModules]; other packs escape at once. *) +let isRegisteredPack (moduleExpr : Typedtree.module_expr) = + Hashtbl.fold + (fun _ {packedExpr} acc -> acc || packedExpr == moduleExpr) + packedModules false + +(* The binding a [(val e : S)] unpacks, when [e] names a value. *) +let unpackedBinding ?(resolutions = !identResolutions) (e : Typedtree.expression) = + match e.exp_desc with + | Texp_ident (_, _, vd) -> Some (resolutions.Compat.valueKey vd) + | _ -> None + +(* Implementations of a value of the argument at [argIndex] of every + application of the functor keyed [functorDef] (under [bindings]). Retain + [None] for each unresolved branch: a resolved sibling cannot erase it. *) +let rec resolveArgumentItems ~visited ~bindings functorDef argIndex components + = + if List.mem (functorDef, argIndex) visited then [None] + else + let visited = (functorDef, argIndex) :: visited in + applicationsOf ~bindings functorDef argIndex + |> List.concat_map (fun {resolver; bindings = own} -> + match resolver with + | Direct resolve -> + let resolved = resolve components in + if resolved = None && !Common.Cli.debug then + Log_.item "unresolvedArgument %s index:%d %s@." + (keyToString functorDef) argIndex (String.concat "." components); + [resolved] + | ViaParameter (outerDef, outerIndex, prefix) -> + let resolved = + resolveArgumentItems ~visited + ~bindings:(mergeBindings (own @ bindings)) outerDef outerIndex + (prefix @ components) + in + if resolved = [] then [None] else resolved) + +(* Whether the functor keyed [functorDef] has an application supplying its + parameter [argIndex]. *) +let hasApplication functorDef argIndex = + applicationsOf ~bindings:[] functorDef argIndex <> [] + +(* The packed module a value position denotes: bound there, or declared + there in an interface and bound at the implementation position. *) +let findPackedModule ~sigToImpl pos = + match Hashtbl.find_opt packedModules pos with + | Some packed -> Some packed + | None -> ( + match Hashtbl.find_opt sigToImpl pos with + | Some implPos -> Hashtbl.find_opt packedModules implPos + | None -> None) + +(* Repacking an unpacked functor adds another value-binding indirection. + Chase the whole chain after every unit is registered, preserving partial + applications and guarding cycles. *) +let rec resolvePackedHead ~sigToImpl ?(visited = []) head = + match head with + | Packed (pos, consumed) when not (List.mem pos visited) -> ( + match findPackedModule ~sigToImpl pos with + | Some {packedHead = Some head} -> ( + match resolvePackedHead ~sigToImpl ~visited:(pos :: visited) head with + | Some (head, sources) -> + let head = + match head with + | Key (key, consumed') -> Key (key, consumed + consumed') + | ParamHead (def, index, components, consumed') -> + ParamHead (def, index, components, consumed + consumed') + | _ -> head + in + Some (head, sources) + | _ -> None) + | _ -> None) + | Packed _ -> None + | Partial (pos, head) -> + resolvePackedHead ~sigToImpl ~visited head + |> Option.map (fun (head, sources) -> (head, pos :: sources)) + | head -> Some (head, []) + +(* The functors (a submodule of) the argument at [argIndex] of the + applications of [functorDef] denotes: their keys, the arguments they + consumed, and the applications they came through. *) +let rec resolveHeads ?(onUnresolved = fun _ -> ()) ~sigToImpl ~visited ~bindings functorDef argIndex + components = + if List.mem (functorDef, argIndex, components) visited then [] + else + let visited = (functorDef, argIndex, components) :: visited in + applicationsOf ~bindings functorDef argIndex + |> List.concat_map (fun ({applicationId; argHead; bindings = own} as application) -> + let here = + mergeBindings (((functorDef, applicationId) :: own) @ bindings) + in + let withPrefixes sources (pos, consumed, bindings) = + match prefixApplicationIds sources with + | [] -> [(pos, consumed, bindings)] + | ids -> + List.map + (fun id -> + (pos, consumed, mergeBindings ((pos, id) :: bindings))) + ids + in + match Option.bind (argHead components) (resolvePackedHead ~sigToImpl) with + | Some (Key (pos, consumed), sources) -> + withPrefixes sources (pos, consumed, here) + | Some (ParamHead (def, index, prefix, consumed), sources) -> + resolveHeads ~onUnresolved ~sigToImpl ~visited ~bindings:here def index + prefix + |> List.map (fun (pos, consumed', bindings) -> + (pos, consumed + consumed', bindings)) + |> List.concat_map (withPrefixes sources) + | Some ((Packed _ | Partial _), _) | None -> + onUnresolved application; + []) + +(* Applications headed by a functor parameter stand for the applications of + the functors passed for it. Resolved to a fixed point, as an argument may + itself come through a parameter; the ones left unresolved (the enclosing + functor is never applied, or applied to something not resolvable) are + dropped, and the calls they would credit fall back to forwarding. *) +let resolveParameterHeadedApplications ~sigToImpl = + (* First-class modules, from the values they were packed into. *) + Hashtbl.iter + (fun id head -> + match resolvePackedHead ~sigToImpl head with + | Some (_, sources) -> Hashtbl.replace applicationPrefixes id sources + | None -> ()) + applicationHeads; + delayedApplications := + !delayedApplications + |> List.map (fun application -> + match resolvePackedHead ~sigToImpl application.appliedFunctor with + | Some (head, sources) -> + Hashtbl.replace applicationPrefixes application.applicationId sources; + (match head with + | Key (key, consumed) -> + { + application with + appliedFunctor = Key (key, 0); + argIndex = application.argIndex + consumed; + } + | appliedFunctor -> {application with appliedFunctor}) + | None -> application); + (* Keep the templates until the whole fixed point is complete: resolving + one head does not mean all enclosing applications are known yet. *) + let templates = + !delayedApplications + |> List.filter (fun {appliedFunctor} -> + match appliedFunctor with ParamHead _ -> true | _ -> false) + in + (* Function-valued resolvers cannot be compared. The original application + identity, target argument, and effective enclosing bindings identify a + derived application without comparing those closures. *) + let key {applicationId; appliedFunctor; argIndex; bindings} = + (applicationId, appliedFunctor, argIndex, mergeBindings bindings) + in + let known = Hashtbl.create 16 in + List.iter (fun application -> Hashtbl.replace known (key application) ()) + !delayedApplications; + let heads application def index components = + resolveHeads ~sigToImpl ~visited:[] ~bindings:application.bindings def + index components + in + let rec loop () = + let additions = ref [] in + templates + |> List.iter (fun application -> + match application.appliedFunctor with + | ParamHead (def, index, components, consumed) -> + heads application def index components + |> List.iter (fun (pos, consumed', bindings) -> + let derived = + { + application with + appliedFunctor = Key (pos, 0); + argIndex = application.argIndex + consumed + consumed'; + bindings = + mergeBindings (bindings @ application.bindings); + } + in + let key = key derived in + if not (Hashtbl.mem known key) then ( + Hashtbl.add known key (); + additions := derived :: !additions)) + | Key _ | Packed _ | Partial _ -> ()); + if !additions <> [] then ( + delayedApplications := !delayedApplications @ List.rev !additions; + loop ()) + in + loop (); + (* One resolved branch does not prove that all applications resolved. + Escape the unknown arguments, not their precisely resolved siblings. *) + let escapeArgument {argRange; argHead} = + escapedRanges := argRange @ !escapedRanges; + match argHead [] with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> () + in + delayedApplications := + !delayedApplications + |> List.filter (fun application -> + match application.appliedFunctor with + | ParamHead (def, index, components, _) -> + let onUnresolved argument = + escapeArgument argument; + escapeArgument application + in + resolveHeads ~onUnresolved ~sigToImpl ~visited:[] + ~bindings:application.bindings def index components = [] + | Key _ | Packed _ | Partial _ -> true); + !delayedApplications + |> List.iter (fun {appliedFunctor; argIndex; argHead; argRange} -> + match appliedFunctor with + | ParamHead _ | Packed _ | Partial _ -> ( + if !Common.Cli.debug then + Log_.item "unresolvedApplication %s index:%d@." + (functorHeadToString appliedFunctor) + argIndex; + (* The unresolved head may itself hide a nested functor in an + argument holder. Escape its known definition ranges too. *) + escapedHeads := appliedFunctor :: !escapedHeads; + escapedRanges := argRange @ !escapedRanges; + match argHead [] with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | Key _ -> ()) + +(* The definition ranges of the arguments at [argIndex] of the applications + of [functorDef], through parameters of enclosing functors. *) +let rec resolveRanges ~visited functorDef argIndex = + if List.mem (functorDef, argIndex) visited then [] + else + let visited = (functorDef, argIndex) :: visited in + applicationsOf ~bindings:[] functorDef argIndex + |> List.concat_map (fun {argRange; resolver} -> + argRange + @ + match resolver with + | ViaParameter (def, index, _) -> resolveRanges ~visited def index + | Direct _ -> []) + +(* The keys and definition ranges of what escaped, see [escapedHeads]. *) +let escapedKeysAndRanges ~sigToImpl = + let rec ofHead visited head = + match head with + | Key (pos, _) -> ([pos], []) + | Partial (_, head) -> ofHead visited head + | ParamHead (def, index, components, _) -> + ( resolveHeads ~sigToImpl ~visited:[] ~bindings:[] def index components + |> List.map (fun (pos, _, _) -> pos), + resolveRanges ~visited:[] def index ) + | Packed (pos, _) when not (List.mem pos visited) -> ( + match findPackedModule ~sigToImpl pos with + | Some {packedHead = Some head; packedRange} -> + let keys, ranges = ofHead (pos :: visited) head in + (keys, packedRange @ ranges) + | Some {packedRange} -> ([], packedRange) + | None -> ([], [])) + | Packed _ -> ([], []) + in + let keys, ranges = !escapedHeads |> List.map (ofHead []) |> List.split in + (List.concat keys, List.concat ranges @ !escapedRanges) + +(* Packed modules that flowed somewhere other than a direct unpack escape, + decided once every use is known; an interface item stands for its + implementation. *) +let escapePackedModulesUsedElsewhere ~sigToImpl = + let usedElsewhere = ref !usedOutsideUnpack in + Hashtbl.iter + (fun sigPos implPos -> + if DefinitionSet.mem sigPos !usedOutsideUnpack then + usedElsewhere := DefinitionSet.add implPos !usedElsewhere) + sigToImpl; + Hashtbl.iter + (fun pos {packedHead; packedRange} -> + if DefinitionSet.mem pos !usedElsewhere then ( + if !Common.Cli.debug then + Log_.item "packedEscapes %s@." (pos |> keyToString); + escapedRanges := packedRange @ !escapedRanges; + match packedHead with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ())) + packedModules + +(* Coercion references made through a functor parameter, as in + [module Outer (M : S) = Inner (M)]: credited to the arguments of the + enclosing functor's applications, once all files are scanned. *) +type parameterCoercion = { + outerFunctor : definitionKey; + outerIndex : int; + itemPath : string list; + coercionFrom : Location.t; + coercionTo : Location.t; (** the module type item, as fallback *) +} + +let parameterCoercions : parameterCoercion list ref = ref [] + +(* A module expression under any [( M : S )] constraints. *) +let rec unwrapConstraints (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> unwrapConstraints inner + | _ -> moduleExpr + +(* The module path an argument or functor expression denotes, through any + [( M : S )] constraints. *) +let rec moduleIdent (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_ident (path, lid) -> Some (path, lid) + | Tmod_constraint (inner, _, _, _) -> moduleIdent inner + | _ -> None + +(* Keys of functor expressions, by node identity: the module binding's name + for named functors, and the enclosing functor's key for curried parameters. + Functors not listed (inline applications) are keyed by their own position. + A list rather than a single slot, as the mapper may visit a binding's body + (and the bindings nested in it) before its module expression. *) +let functorKeys : (Typedtree.module_expr * definitionKey) list ref = ref [] + +let setFunctorKey (moduleExpr : Typedtree.module_expr) pos = + functorKeys := (moduleExpr, pos) :: !functorKeys + +(* Keys pair positions with compilation contexts, since applications learn a + definition through its declaration in the defining unit. Two distinct + definitions a ppx emitted at one position therefore share a key: the + calls through either's parameters are credited to the arguments of every + application of that key, which is tighter than forwarding to every + implementation and never hides a supplied argument. *) + +let findFunctorKey (moduleExpr : Typedtree.module_expr) = + match List.find_opt (fun (e, _) -> e == moduleExpr) !functorKeys with + | Some (_, pos) -> Some pos + | None -> None + +(* Functors that applications in the same file cannot find by uid, keyed by + identifier: [let module] bindings (not registered as declarations before + OCaml 5.5) and recursive modules (whose occurrences have no uid). *) +let functorsByIdent : (Ident.t * functorHead) list ref = ref [] + +(* Heads of module bindings of this file whose right-hand side applies or + aliases a functor parameter or a first-class module ([module G = F (A)] + in the body of [functor (F : FT) -> ...], [module G = (val packed)]), + by the position of the binding's name: the resolver of occurrences cannot + see through those. *) +let headsByBinding : (definitionKey, functorHead) Hashtbl.t = + Hashtbl.create 4 + +let rec pathComponents (path : Path.t) = + match path with + | Pident _ -> Some [] + | Pdot (p, name) -> ( + match pathComponents p with + | Some comps -> Some (comps @ [name]) + | None -> None) + | _ -> None + +(* [module N = M] or [module N = M.Sub] inside a functor body, where [M] is a + parameter: [N] then stands for the parameter too. *) +let registerParameterAlias (id : Ident.t option) + (moduleExpr : Typedtree.module_expr) = + let rec ident (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_ident (path, _) -> Some path + | Tmod_constraint (inner, _, _, _) -> ident inner + | _ -> None + in + match (id, ident moduleExpr) with + | Some id, Some path -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + if !Common.Cli.debug then + Log_.item "parameterAlias %s = %s (prefix %s)@." (Ident.unique_name id) + (Path.name path) + (String.concat "." (p.prefix @ components)); + functorParameters := + {p with paramId = id; prefix = p.prefix @ components} + :: !functorParameters + | _ -> ()) + | _ -> () + +let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl + ~path args = let args = List.map (fun (lbl, arg) -> (lbl, Compat.applyArgToOption arg)) args in @@ -126,11 +742,651 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args = if argIsSupplied <> Some false then supplied := s :: !supplied; if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe | _ -> ()); - (!supplied, !suppliedMaybe) - |> DeadOptionalArgs.addReferences ~locFrom ~locTo ~path) + let call = (!supplied, !suppliedMaybe) in + let parameter = findFunctorParameter path in + (* Without shape resolution the call is only forwarded (below); recording + it here too would credit it twice. *) + (match (parameter, pathComponents path) with + | Some {functorDef; paramIndex; prefix}, Some components + when Compat.shapeResolutionAvailable -> + let components = prefix @ components in + let key = (functorDef, paramIndex, components) in + if !Common.Cli.debug then + Log_.item "parameterCall %s functor:%s index:%d@." + (String.concat "." components) + (functorDef |> keyToString) + paramIndex; + let calls = + match Hashtbl.find_opt parameterCalls key with + | Some calls -> calls + | None -> [] + in + Hashtbl.replace parameterCalls key + ({call; callFrom = locFrom; callTo = locTo; callToImpl = locToImpl; + callPath = path} + :: calls) + | _ -> ()); + (* A call through a parameter is credited to the actual arguments once + all applications are known (see [forceDelayedItems]); without shape + resolution it can only be forwarded to every implementation. *) + if parameter = None || not Compat.shapeResolutionAvailable then + call + |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) + +(* References whose target may be redirected to a shape-resolved + implementation. Decided in [forceDelayedItems], once every declaration is + known: if the original target is a declaration (e.g. a [val] in an .mli), it + is kept, otherwise the implementation is referenced. *) +type redirectedReference = { + locFrom : Location.t; + locTo : Location.t; + locToImpl : Location.t; +} + +let delayedRedirects : redirectedReference list ref = ref [] + +let findResolution ~(identLoc : Location.t) ~(path : Path.t) = + !identResolutions.valueImpl identLoc (Path.last path) + +(* Functor parameters in scope during traversal. A reference through a + parameter (e.g. [M.f] in [functor (M : S) -> ...]) is credited to the actual + arguments at application sites, via the coercion in [Tmod_apply]; it must + not be forwarded to every implementation of the module type item. *) +(* (module type item position, referencing position) pairs that must not be + forwarded to implementations. *) +module PosPairSet = Set.Make (struct + type t = Lexing.position * Lexing.position + + let compare = compare +end) + +let nonForwardableReferences = ref PosPairSet.empty +let ordinaryReferences = ref PosPairSet.empty + +let effectiveLocFrom (locFrom : Location.t) = + let lastBinding = !Current.lastBinding in + match lastBinding = Location.none with + | true -> locFrom + | false -> lastBinding + +let addRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~locToImpl = + match locToImpl with + | Some (locToImpl : Location.t) when locToImpl.loc_start <> locTo.loc_start -> + let locFrom = effectiveLocFrom locFrom in + if not locFrom.loc_ghost then + delayedRedirects := {locFrom; locTo; locToImpl} :: !delayedRedirects + | _ -> addValueReference ~addFileReference:true ~locFrom ~locTo + +let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) + ~path = + let pair = (locTo.loc_start, (effectiveLocFrom locFrom).loc_start) in + let locToImpl = findResolution ~identLoc:locFrom ~path in + (if isFunctorParameterPath path && Compat.shapeResolutionAvailable then ( + if not (PosPairSet.mem pair !ordinaryReferences) then + nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences) + else + match locToImpl with + | Some (impl : Location.t) when impl.loc_start <> locTo.loc_start -> () + | _ -> + (* Once an ordinary occurrence lands on this item, the pair remains + forwardable regardless of later parameter occurrences from the + same enclosing binding. Redirected occurrences do not land here. *) + ordinaryReferences := PosPairSet.add pair !ordinaryReferences; + nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); + addRedirect ~locFrom ~locTo ~locToImpl + +(* An application of an inline functor, [(functor (A : S) -> body) (X)]: + the body, with the parameters bound to the actual arguments ([None] for a + unit argument). Curried applications bind every layer. *) +let appliedInlineFunctor (moduleExpr : Typedtree.module_expr) = + let rec apply (e : Typedtree.module_expr) (args : Typedtree.module_expr option list) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> apply inner args + | Tmod_apply (functorExpr, argumentExpr, _) -> + apply functorExpr (Some argumentExpr :: args) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> apply functorExpr (None :: args) +#endif + | Tmod_functor (param, body) -> ( + match args with + | [] -> None + | arg :: rest -> ( + let bound = + match (param, arg) with + | Named (Some id, _, _), Some argumentExpr -> [(id, argumentExpr)] + | _ -> [] + in + match rest with + | [] -> Some (body, bound) + | _ -> ( + match apply body rest with + | Some (innerBody, innerBound) -> Some (innerBody, bound @ innerBound) + | None -> None))) + | _ -> None + in + match moduleExpr.mod_desc with + | Tmod_apply _ -> apply moduleExpr [] +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> apply moduleExpr [] +#endif + | _ -> None + +(* The names after the head of a path, [["Sub"; "X"]] for [A.Sub.X]. *) +let rec pathTail (path : Path.t) = + match path with + | Pident _ -> Some [] + | Pdot (p, name) -> ( + match pathTail p with Some tail -> Some (tail @ [name]) | None -> None) + | _ -> None + +(* The shape of a module expression used as a functor argument: a module + path's, that of an application ([Use (Make (A))]) built from the functor's + and the argument's as the compiler does, or of a first-class module + unpacked from a value bound to a packed module (in a file scanned earlier; + the argument resolver looks it up again once every file is scanned). [env] + binds the parameters of inline functors being applied to their + arguments. *) +let rec moduleShapeOfExpr ?(env = []) (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_ident (path, lid) -> ( + let bound = + match Path.head path with + | head -> List.find_opt (fun (id, _) -> Ident.same id head) env + | exception _ -> None + in + match bound with + | Some (_, argumentExpr) -> ( + match (moduleShapeOfExpr ~env argumentExpr, pathTail path) with + | Some shape, Some tail -> + tail + |> List.fold_left + (fun shape name -> + match shape with + | Some shape -> !identResolutions.projModule shape name + | None -> None) + (Some shape) + | _ -> None) + | None -> + if Compat.shapeResolutionAvailable && isFunctorParameterPath path then + Some Compat.parameterShape + else !identResolutions.moduleShape lid.loc (Path.last path)) + | Tmod_constraint (inner, _, _, _) -> moduleShapeOfExpr ~env inner + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedShape} -> packedShape + | None -> None) + | None -> None) + | Tmod_apply (functorExpr, argumentExpr, _) -> ( + match appliedInlineFunctor moduleExpr with + | Some (body, bound) -> moduleShapeOfExpr ~env:(bound @ env) body + | None -> ( + match + (moduleShapeOfExpr ~env functorExpr, moduleShapeOfExpr ~env argumentExpr) + with + | Some functorShape, Some argumentShape -> + Some (Compat.applyShape functorShape argumentShape) + | _ -> None)) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> ( + match appliedInlineFunctor moduleExpr with + | Some (body, bound) -> moduleShapeOfExpr ~env:(bound @ env) body + | None -> ( + match moduleShapeOfExpr ~env functorExpr with + | Some functorShape -> Some (Compat.applyUnitShape functorShape) + | None -> None)) +#endif + | _ -> None + +(* The source ranges of the definition a module expression denotes, for + the functors nested in it (see [escapedRanges]): its own for a structure + or functor, its binding's through paths and aliases (in any unit), and + those of the functor and the arguments for an application (the result + may re-export either). *) +let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) + (e : Typedtree.module_expr) = + let own = + if e.mod_loc.loc_ghost then [] + else [(definitionKey ~resolutions e.mod_loc.loc_start, e.mod_loc.loc_end)] + in + if List.memq e visited then [] + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_structure {str_items} -> + own + @ (str_items + |> List.concat_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module {mb_expr} -> + definitionRange ~visited ~resolutions mb_expr + | Tstr_recmodule bindings -> + bindings + |> List.concat_map (fun (binding : Typedtree.module_binding) -> + definitionRange ~visited ~resolutions binding.mb_expr) + | Tstr_include {incl_mod} -> + definitionRange ~visited ~resolutions incl_mod + | _ -> [])) + | Tmod_functor (_, body) -> own @ definitionRange ~visited ~resolutions body + | Tmod_constraint (inner, _, _, _) -> + definitionRange ~visited ~resolutions inner + | Tmod_ident (path, _) -> definitionRangeOfPath ~visited ~resolutions path + | Tmod_apply (functorExpr, argumentExpr, _) -> + definitionRange ~visited ~resolutions functorExpr + @ definitionRange ~visited ~resolutions argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> + definitionRange ~visited ~resolutions functorExpr +#endif + | Tmod_unpack (packed, _) -> ( + match unpackedBinding ~resolutions packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedRange} -> packedRange + | None -> []) + | None -> []) + +and definitionRangeOfPath ?(visited = []) ?(resolutions = !identResolutions) + (path : Path.t) = + match resolutions.bindingOfPath path with + | Some (loc, definition, definingResolver, _) -> + let resolutions = Option.value definingResolver ~default:resolutions in + (* A named functor is keyed at its binding name, which precedes the + module expression's range. Aliases must retain that key as well. *) + let bindingRange = + if loc.loc_ghost then [] else [(definitionKey ~resolutions loc.loc_start, loc.loc_end)] + in + bindingRange @ definitionRange ~visited ~resolutions definition + | None -> [] + +(* Unlike ordinary functor keys, an unpacked head refers to a value binding + whose pack may be registered later, in another unit or behind an .mli. + Chase aliases using each definition's own resolver, without depending on + traversal order or on the unpack's (possibly uid-less) shape. *) +let packedHeadOfPath resolutions path = + let rec ofPath visited (resolutions : Compat.identResolutions) path consumed = + match resolutions.bindingOfPath path with + | Some (_, definition, resolver, applied) -> + let resolutions = Option.value resolver ~default:resolutions in + ofExpr visited resolutions definition (consumed + applied) + | None -> None + and ofExpr visited resolutions (e : Typedtree.module_expr) consumed = + if List.memq e visited then None + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> + ofExpr visited resolutions inner consumed + | Tmod_apply (inner, _, _) -> + ofExpr visited resolutions inner (consumed + 1) + |> Option.map (fun head -> Partial (definitionKey ~resolutions e.mod_loc.loc_start, head)) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit inner -> + ofExpr visited resolutions inner (consumed + 1) + |> Option.map (fun head -> Partial (definitionKey ~resolutions e.mod_loc.loc_start, head)) +#endif + | Tmod_ident (path, _) -> ofPath visited resolutions path consumed + | Tmod_unpack (packed, _) -> + unpackedBinding ~resolutions packed |> Option.map (fun pos -> Packed (pos, consumed)) + | _ -> None + in + ofPath [] resolutions path 0 + +(* A foreign alias of a partial application may be read before its unit is + traversed. Its application position still identifies the argument group + once that unit has been scanned. *) +let partialHeadOfPath resolutions path head = + let rec ofPath visited (resolutions : Compat.identResolutions) path = + match resolutions.bindingOfPath path with + | Some (_, definition, resolver, _) -> + ofExpr visited (Option.value resolver ~default:resolutions) definition + | None -> None + and ofExpr visited resolutions (e : Typedtree.module_expr) = + if List.memq e visited then None + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_apply _ -> Some (definitionKey ~resolutions e.mod_loc.loc_start) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> Some (definitionKey ~resolutions e.mod_loc.loc_start) +#endif + | Tmod_constraint (inner, _, _, _) -> ofExpr visited resolutions inner + | Tmod_ident (path, _) -> ofPath visited resolutions path + | _ -> None + in + match head with + | Key (_, consumed) when consumed > 0 -> ( + match ofPath [] resolutions path with + | Some pos -> Partial (pos, head) + | None -> head) + | _ -> head + +(* The functor a module expression applies, and the number of arguments + already consumed by partial applications it stands for, as in + [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are + chased within the current file, and bindings in other files through the + resolver. A functor parameter ([F (M)] in [functor (F : FT) -> ...]) is + resolved once all applications are known. *) +let rec functorHeadOf (e : Typedtree.module_expr) : functorHead option = + let rec consume head = + match head with + | Some (Key (pos, consumed)) -> Some (Key (pos, consumed + 1)) + | Some (ParamHead (def, index, components, consumed)) -> + Some (ParamHead (def, index, components, consumed + 1)) + | Some (Packed (pos, consumed)) -> Some (Packed (pos, consumed + 1)) + | Some (Partial (pos, head)) -> + consume (Some head) |> Option.map (fun head -> Partial (pos, head)) + | None -> None + in + let applied inner = + consume (functorHeadOf inner) + |> Option.map (fun head -> Partial (definitionKey e.mod_loc.loc_start, head)) + in + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> applied functorExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> + (* [F ()]: the unit parameter occupies an index. *) + applied functorExpr +#endif + | Tmod_constraint (inner, _, _, _) -> functorHeadOf inner + | Tmod_functor _ -> + (* Inline functor: keyed by its own position, see [functorKeys]. *) + Some (Key (definitionKey e.mod_loc.loc_start, 0)) + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> Some (Packed (pos, 0)) + | None -> None) + | Tmod_ident (path, lid) -> headOfPath ~lid path [] + | _ -> None + +(* The head a module path denotes, extended by [components] ([Holder.F] for + the functor [F] of the argument [Holder]). *) +and headOfPath ?lid (path : Path.t) components : functorHead option = + let extended = + components |> List.fold_left (fun p name -> Path.Pdot (p, name)) path + in + let byParameter () = + match (findFunctorParameter path, pathComponents path) with + | Some p, Some pathComponents -> + Some + (ParamHead + (p.functorDef, p.paramIndex, p.prefix @ pathComponents @ components, 0)) + | _ -> None + in + let byBinding () = + match (lid, components) with + | Some (lid : Longident.t Location.loc), [] -> ( + match !identResolutions.moduleDefKey lid.loc (Path.last path) with + | Some key -> Hashtbl.find_opt headsByBinding key + | None -> None) + | _ -> None + in + let byIdent () = + match (path, components) with + | Pident id, [] -> ( + match List.find_opt (fun (id', _) -> Ident.same id' id) !functorsByIdent with + | Some (_, head) -> Some head + | None -> None) + | _ -> None + in + let byResolver () = + let key = + match (lid, components) with + | Some lid, [] -> + !identResolutions.headKey Compat.noHeadVisited + { + Typedtree.mod_desc = Tmod_ident (path, lid); + mod_loc = lid.loc; + mod_type = Types.Mty_signature []; + mod_env = Env.empty; + mod_attributes = []; + } + | _ -> !identResolutions.headKeyOfPath extended + in + match key with + | Some (key, consumed) -> + Some + (partialHeadOfPath !identResolutions extended + (Key (key, consumed))) + | None -> None + in + let rec first = function + | [] -> None + | f :: rest -> ( + match f () with Some head -> Some head | None -> first rest) + in + first + [ + byParameter; + byBinding; + byIdent; + (fun () -> packedHeadOfPath !identResolutions extended); + byResolver; + ] + +(* Register the head a module binding stands for, when its right-hand side + is an alias, an application or an unpacking (see [headsByBinding]). *) +let registerBindingHead ~(namePos : Lexing.position) (id : Ident.t option) + (moduleExpr : Typedtree.module_expr) = + match (unwrapConstraints moduleExpr).mod_desc with + | Tmod_functor _ | Tmod_structure _ -> () + | _ -> ( + match functorHeadOf moduleExpr with + | Some head -> + Hashtbl.replace headsByBinding (definitionKey namePos) head; + (match id with + | Some id -> functorsByIdent := (id, head) :: !functorsByIdent + | None -> ()) + | None -> ()) + +type unpackedExportCandidate = { + exportId : Ident.t; + exportOrigin : Typedtree.module_expr; + exportResolutions : Compat.identResolutions; + exportScope : unpackedExportCandidate list; +} + +let unpackedExportCandidates : unpackedExportCandidate list ref = ref [] + +let addUnpackedExports resolutions scope signature moduleExpr = + signature + |> List.fold_left + (fun acc item -> + match item with + | Types.Sig_module _ -> ( + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> + { + exportId = id; + exportOrigin = moduleExpr; + exportResolutions = resolutions; + exportScope = scope; + } :: acc + | None -> acc) + | _ -> acc) + scope + +let rec unpackedCandidate candidates path components = + match path with + | Path.Pident id -> + List.find_opt (fun candidate -> Ident.same id candidate.exportId) candidates + |> Option.map (fun candidate -> (candidate, Ident.name id :: components)) + | Path.Pdot (parent, name) -> + unpackedCandidate candidates parent (name :: components) + | _ -> None + +(* Opens and includes can introduce fresh identifiers whose unpacked origin + cannot be recovered at an application. Follow only the demanded export: + an unused unpacked sibling must not make its parameter calls escape. *) +let rec escapeUnpackedExports ?(visited = []) + ?(resolutions = !identResolutions) ?(components = []) + ?(candidates = !unpackedExportCandidates) + (e : Typedtree.module_expr) = + if not (List.memq e visited) then + let visited = e :: visited in + let walk = + escapeUnpackedExports ~visited ~resolutions ~components ~candidates + in + match e.mod_desc with + | Tmod_unpack (packed, _) -> ( + match unpackedBinding ~resolutions packed with + | Some pos -> escapedHeads := Packed (pos, 0) :: !escapedHeads + | None -> ()) + | Tmod_constraint (inner, _, _, _) | Tmod_functor (_, inner) -> walk inner + | Tmod_apply (functorExpr, argumentExpr, _) -> + walk functorExpr; + walk argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit inner -> walk inner +#endif + | Tmod_ident (path, _) -> ( + match unpackedCandidate candidates path components with + | Some (candidate, components) -> + escapeUnpackedExports ~visited ~components + ~resolutions:candidate.exportResolutions ~candidates:candidate.exportScope + candidate.exportOrigin + | None -> + let rec root path components = + match path with + | Path.Pdot (parent, name) -> root parent (name :: components) + | _ -> (path, components) + in + let path, components = root path components in + (match resolutions.bindingOfPath path with + | Some (_, definition, resolver, _) -> + let next = Option.value resolver ~default:resolutions in + escapeUnpackedExports ~visited ~resolutions:next ~components + ~candidates:(if next == resolutions then candidates else []) definition + | None -> ())) + | Tmod_structure {str_items} -> ( + (* A foreign structure can itself alias an identifier introduced by an + include/open. Reconstruct that lexical scope using its own AST and + resolver, without mixing identifier stamps from different units. *) + let candidates = + str_items + |> List.fold_left + (fun scope (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_include {incl_mod; incl_type} -> + addUnpackedExports resolutions scope incl_type incl_mod + | Tstr_open {open_expr; open_bound_items} -> + addUnpackedExports resolutions scope open_bound_items open_expr + | _ -> scope) + candidates + in + let walk = + escapeUnpackedExports ~visited ~resolutions ~components ~candidates + in + match components with + | [] -> + str_items + |> List.iter (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module {mb_expr} -> walk mb_expr + | Tstr_recmodule bindings -> + List.iter (fun (mb : Typedtree.module_binding) -> walk mb.mb_expr) + bindings + | Tstr_include {incl_mod} -> walk incl_mod + | _ -> ()) + | name :: rest -> + let matching (mb : Typedtree.module_binding) = mb.mb_name.txt = Some name in + let rec find = function + | [] -> () + | (item : Typedtree.structure_item) :: items -> ( + let binding = + match item.str_desc with + | Tstr_module mb when matching mb -> Some mb.mb_expr + | Tstr_recmodule bindings -> + List.find_opt matching bindings + |> Option.map (fun (mb : Typedtree.module_binding) -> mb.mb_expr) + | _ -> None + in + match binding with + | Some expr -> + escapeUnpackedExports ~visited ~resolutions ~components:rest + ~candidates expr + | None -> ( + match item.str_desc with + | Tstr_include {incl_mod; incl_type} + when List.exists + (fun item -> + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> Ident.name id = name + | None -> false) + incl_type -> walk incl_mod + | _ -> find items)) + in + find (List.rev str_items)) + +(* Candidates are keyed by the actual identifiers introduced into scope, + not just their names. Registering an open alone does not escape anything. *) +let registerUnpackedExports signature moduleExpr = + unpackedExportCandidates := + addUnpackedExports !identResolutions !unpackedExportCandidates signature + moduleExpr let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in + (* [let module F (M : S) = ... in]: key the functor by its binding. On + OCaml >= 5.5 this is a [Texp_struct_item] holding a [Tstr_module], which + the structure item handler covers. *) + #if OCAML_VERSION >= (5, 5, 0) + (* The mapper visits the body of a [let module] before the binding, so an + alias of a parameter must be registered here for uses in the body. The + structure item handler registers it again, harmlessly. *) + (match e.exp_desc with + | Texp_struct_item ({str_desc = Tstr_module {mb_id; mb_expr; mb_name}}, _) -> + registerParameterAlias mb_id mb_expr; + registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr + | Texp_struct_item ({str_desc = Tstr_open {open_expr; open_bound_items}}, _) -> + registerUnpackedExports open_bound_items open_expr + | Texp_struct_item ({str_desc = Tstr_include {incl_mod; incl_type}}, _) -> + registerUnpackedExports incl_type incl_mod + | _ -> ()); + #else + (match e.exp_desc with + | Texp_open ({open_expr; open_bound_items}, _) -> + registerUnpackedExports open_bound_items open_expr + | Texp_letmodule (id, name, _, moduleExpr, _) -> + setFunctorKey moduleExpr (definitionKey name.loc.loc_start); + registerParameterAlias id moduleExpr; + (match id with + | Some exportId -> + unpackedExportCandidates := + {exportId; exportOrigin = moduleExpr; + exportResolutions = !identResolutions; + exportScope = !unpackedExportCandidates} :: !unpackedExportCandidates + | None -> ()); + (match id with + | Some id -> + (* [let module G = F in] or [let module G = F (A) in]: G stands for + F's key, with the arguments already consumed. *) + let key = + match (unwrapConstraints moduleExpr).mod_desc with + | Tmod_functor _ -> Some (Key (definitionKey name.loc.loc_start, 0)) + | _ -> functorHeadOf moduleExpr + in + (match key with + | Some key -> functorsByIdent := (id, key) :: !functorsByIdent + | None -> ()) + | None -> ()) + | _ -> ()); + #endif + (match e.exp_desc with + | Texp_pack moduleExpr when not (isRegisteredPack moduleExpr) -> ( + (* A module packed as a first-class value anywhere but in a value + binding escapes at once, with the functors nested in it. *) + escapedRanges := definitionRange moduleExpr @ !escapedRanges; + match functorHeadOf moduleExpr with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | Texp_ident (_, _, vd) + when not (PosSet.mem e.exp_loc.loc_start !unpackOperands) -> + usedOutsideUnpack := + DefinitionSet.add (!identResolutions.valueKey vd) !usedOutsideUnpack + | _ -> ()); (match e.exp_desc with | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) -> @@ -143,19 +1399,21 @@ let rec collectExpr super self (e : Typedtree.expression) = (Location.none.loc_start |> posToString) (locTo.loc_start |> posToString); ValueReferences.add locTo.loc_start Location.none.loc_start) - else addValueReference ~addFileReference:true ~locFrom ~locTo + else addValueReferenceOrRedirect ~locFrom ~locTo ~path:_path | Texp_apply ( { exp_desc = Texp_ident (path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}); exp_type; + exp_loc = identLoc; }, args ) -> + let locToImpl = findResolution ~identLoc ~path in args |> processOptionalArgs ~expType:exp_type ~locFrom:(locFrom : Location.t) - ~locTo ~path + ~locTo ?locToImpl ~path | Texp_let ( (* generated for functions with optional args *) Nonrecursive, @@ -310,70 +1568,232 @@ let findSignatureItem name signature = | Some itemName -> itemName = name | None -> false) -let addValueReferenceFromSignatureItem ~locFrom signatureItem = - let _id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in - if not locTo.loc_ghost then - addValueReference ~addFileReference:true ~locFrom ~locTo +(* The value items a module coercion uses, with the path of submodules + leading to each. *) +(* Module type expansion, also for module types rooted at a functor + parameter in scope ([module type T = M.T], [M.Sub.T2]): those are found in + the parameter's declared module type. *) +let rec expandModuleType ?(visited = []) ?(resolutions = !identResolutions) + ?(parameters = !functorParameters) (moduleType : Types.module_type) = + let expanded = resolutions.Compat.expandModuleType moduleType in + match expanded with + | Mty_ident path when not (List.exists (Path.same path) visited) -> ( + let visited = path :: visited in + match moduleTypeViaParameter ~visited ~resolutions ~parameters path with + | Some moduleType -> + expandModuleType ~visited ~resolutions ~parameters moduleType + | None -> expanded) + | _ -> expanded -let rec addAllModuleValueReferences ~locFrom (moduleType : Types.module_type) = - moduleType |> getSignature +and moduleTypeViaParameter ~visited ~resolutions ~parameters (path : Path.t) = + match (findFunctorParameter ~parameters path, pathComponents path) with + | Some {paramType = Some paramType; prefix}, Some components -> + let rec walk (moduleType : Types.module_type) components = + let signature = + moduleType + |> expandModuleType ~visited ~resolutions ~parameters + |> getSignature + in + match components with + | [] -> None + | [name] -> ( + match signature |> findSignatureItem name with + | Some (Types.Sig_modtype _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_, moduleType, _) -> Some moduleType + | None -> None) + | _ -> None) + | m :: rest -> ( + match signature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_, moduleType, _) -> walk moduleType rest + | None -> None) + | _ -> None) + in + walk paramType (prefix @ components) + | _ -> None + +(* Signature of a module type, with aliases of named module types expanded + ([module N : Other.O] inside a signature is [Mty_ident] in the typed tree, + which exposes no items). Only runtime modules ([Sig_module]) are walked: + a [Sig_modtype] declaration has no fields. *) +let expandedSignature (moduleType : Types.module_type) = + moduleType |> expandModuleType |> getSignature + +(* The location of a value in a module type, by path of names. *) +let rec findValueInModuleType ?(expand = fun mt -> expandModuleType mt) + (moduleType : Types.module_type) components = + let signature = moduleType |> expand |> getSignature in + match components with + | [] -> None + | [name] -> ( + match signature |> findSignatureItem name with + | Some (Types.Sig_value _ as item) -> + let _id, loc, _kind, _valType = item |> Compat.getSigValue in + if loc.loc_ghost then None else Some loc + | _ -> None) + | m :: rest -> ( + match signature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_id, moduleType, _loc) -> + findValueInModuleType ~expand moduleType rest + | None -> None) + | _ -> None) + +let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = + moduleType |> expandedSignature |> List.iter (fun (signatureItem : Types.signature_item) -> match signatureItem with - | Types.Sig_value _ -> - addValueReferenceFromSignatureItem ~locFrom signatureItem - | Types.Sig_module _ | Types.Sig_modtype _ -> ( + | Types.Sig_value _ -> f ~path signatureItem + | Types.Sig_module _ -> ( match signatureItem |> Compat.getSigModuleModtype with - | Some (_id, moduleType, _moduleLoc) -> - addAllModuleValueReferences ~locFrom moduleType + | Some (id, moduleType, _moduleLoc) -> + iterAllModuleValues ~path:(path @ [Ident.name id]) moduleType f | None -> ()) | _ -> ()) -let rec addCoercedModuleValueReferences ~locFrom ~coercion ~actualType = - let actualSignature = actualType |> getSignature in +let rec iterCoercedValues ~path ~coercion ~actualType f = + let actualSignature = actualType |> expandedSignature in match coercion with - | Typedtree.Tcoerce_none -> addAllModuleValueReferences ~locFrom actualType - | Typedtree.Tcoerce_structure (values, modules) -> - let actualFields = - actualSignature - |> List.filter (function - | Types.Sig_type _ | Types.Sig_module _ | Types.Sig_modtype _ -> - false - | _ -> true) - in - values - |> List.iter (fun (index, _coercion) -> - match nth_opt actualFields index with - | Some (Types.Sig_value _ as actualItem) -> - addValueReferenceFromSignatureItem ~locFrom actualItem - | Some _ -> () - | None -> ()); - let actualModules = - actualSignature - |> List.filter (function - | Types.Sig_module _ | Types.Sig_modtype _ -> true - | _ -> false) - in - modules - |> List.iter (fun (id, index, coercion) -> - let actualItem = - match actualSignature |> findSignatureItem (Ident.name id) with - | Some item -> Some item - | None -> nth_opt actualModules index - in - match actualItem with - | Some actualItem -> ( + | Typedtree.Tcoerce_none -> iterAllModuleValues ~path actualType f + | Typedtree.Tcoerce_structure (fields, _idPositions) -> + (* [fields] has one entry per runtime component of the target, giving + the position in the source's runtime fields and the coercion of that + component; submodules recurse with theirs. The second list only maps + source module identifiers to positions, for aliases. *) + let runtimeFields = actualSignature |> List.filter Compat.isRuntimeField in + fields + |> List.iter (fun (index, coercion) -> + match nth_opt runtimeFields index with + | Some (Types.Sig_value _ as actualItem) -> f ~path actualItem + | Some (Types.Sig_module _ as actualItem) -> ( match actualItem |> Compat.getSigModuleModtype with - | Some (_actualId, actualType, _moduleLoc) -> - addCoercedModuleValueReferences ~locFrom ~coercion ~actualType + | Some (actualId, actualType, _moduleLoc) -> + iterCoercedValues + ~path:(path @ [Ident.name actualId]) + ~coercion ~actualType f | None -> ()) - | None -> ()) + | _ -> ()) | Typedtree.Tcoerce_alias (_env, _path, coercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion ~actualType + iterCoercedValues ~path ~coercion ~actualType f | Typedtree.Tcoerce_functor (_argCoercion, resultCoercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion:resultCoercion - ~actualType + iterCoercedValues ~path ~coercion:resultCoercion ~actualType f | Typedtree.Tcoerce_primitive _ -> () +(* Reference the values a functor argument's coercion uses. [shape], when + known, is the argument module's shape: items are then redirected to their + implementation rather than to a shared module type item. *) +let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ?concrete + ~actualType () = + (match (expandedSignature actualType, shape) with + | [], Some shape -> + (* The argument's signature could not be expanded (a module type this + analysis cannot resolve): reference the values its shape exports + instead, which is precise to this argument. *) + !identResolutions.shapeValueItems shape + |> List.iter (fun (_, locTo) -> + addValueReference ~addFileReference:true ~locFrom ~locTo) + | _ -> ()); + iterCoercedValues ~path:[] ~coercion ~actualType (fun ~path signatureItem -> + let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in + if not locTo.loc_ghost then + let resolutions = !identResolutions in + let itemShape = + path + |> List.fold_left + (fun shape name -> + match shape with + | Some shape -> resolutions.projModule shape name + | None -> None) + shape + in + let locToImpl = + match itemShape with + | Some shape -> resolutions.projValue shape (Ident.name id) + | None -> None + in + let locToImpl = + match (locToImpl, concrete) with + | None, Some concrete -> + findValueInModuleType concrete (path @ [Ident.name id]) + | _ -> locToImpl + in + addRedirect ~locFrom ~locTo ~locToImpl) + +(* Same, when the argument is a functor parameter: deferred to the arguments + of the enclosing functor's applications. *) +let recordParameterCoercion ~locFrom ~coercion ~actualType + (parameter : functorParameter) components = + iterCoercedValues ~path:[] ~coercion ~actualType (fun ~path signatureItem -> + let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in + if not locTo.loc_ghost then + parameterCoercions := + { + outerFunctor = parameter.functorDef; + outerIndex = parameter.paramIndex; + itemPath = parameter.prefix @ components @ path @ [Ident.name id]; + coercionFrom = locFrom; + coercionTo = locTo; + } + :: !parameterCoercions) + +(* Whether a value item of a file's signature is a definition of that file. + Items whose location lies in another file, or inside a [module type] of the + file, come from [include]s (e.g. [include T] of a functor parameter, whose + items point at the module type's [val]s): they are not declarations. *) +let isSignatureValueDeclaration = ref (fun (_ : Location.t) -> true) + +let setSignatureValueFilter ~(fileName : string) ~(buildDir : string) + ~(moduleTypeRanges : Location.t list) = + (* Full paths resolved against the build directory the compiler ran in + (both the recorded source file and positions are relative to it), and + compared exactly, without extensions (a preprocessed source is recorded + as [foo.pp.ml] while its positions say [foo.ml]). Basenames or suffixes + alone would confuse same-named sources in different directories. *) + let normalize path = + let path = + if Filename.is_relative path then Filename.concat buildDir path else path + in + let base = + match String.index_opt (Filename.basename path) '.' with + | Some i -> String.sub (Filename.basename path) 0 i + | None -> Filename.basename path + in + (* Drop [.] segments and resolve [..], which one side may carry; both + separators, as Windows paths may carry either. *) + let segments = + String.split_on_char '/' + (String.map + (fun c -> if c = '\\' then '/' else c) + (Filename.dirname path)) + |> List.fold_left + (fun acc segment -> + match (segment, acc) with + | ".", _ -> acc + | "..", _ :: rest -> rest + | _ -> segment :: acc) + [] + |> List.rev + in + String.concat "/" (segments @ [base]) + in + let self = normalize fileName in + isSignatureValueDeclaration := + fun (loc : Location.t) -> + let sameFile = normalize loc.loc_start.pos_fname = self in + if (not sameFile) && !Common.Cli.debug then + Log_.item "signatureValueSkipped %s (file %s)@." + (loc.loc_start |> posToString) + fileName; + sameFile + && not + (moduleTypeRanges + |> List.exists (fun (range : Location.t) -> + range.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && loc.loc_start.pos_cnum < range.loc_end.pos_cnum)) + let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path (si : Types.signature_item) = match si with @@ -383,7 +1803,7 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path DeadType.addDeclaration ~typeId:id ~typeKind:t.type_kind | Sig_value _ when doValues -> let id, loc, kind, valType = si |> Compat.getSigValue in - if not loc.Location.loc_ghost then + if (not loc.Location.loc_ghost) && !isSignatureValueDeclaration loc then let isPrimitive = match kind with Val_prim _ -> true | _ -> false in if (not isPrimitive) || !Config.analyzeExternals then let optionalArgs = @@ -408,26 +1828,582 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path | None -> ()) | _ -> () +(* The type of a functor argument, with an explicit constraint by a named + module type [(M : Other.S)] expanded to that module type's signature: the + typed tree leaves it as [Mty_ident], which exposes no items. *) +let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = + let expand moduleType = expandModuleType moduleType in + match (argumentExpr.mod_desc, argumentExpr.mod_type) with + | ( Tmod_constraint + (_, _, Tmodtype_explicit {mty_desc = Tmty_ident (path, lid)}, _), + Mty_ident _ ) -> ( + match !identResolutions.moduleTypeOf lid.loc (Path.last path) with + | Some moduleType -> expand moduleType + | None -> expand argumentExpr.mod_type) + | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner + | _ -> expand argumentExpr.mod_type + +(* The module type of a submodule of a module type, by path of names. *) +let rec findModuleInModuleType (moduleType : Types.module_type) components = + match components with + | [] -> Some moduleType + | m :: rest -> ( + match moduleType |> expandedSignature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_id, moduleType, _loc) -> findModuleInModuleType moduleType rest + | None -> None) + | _ -> None) + +(* A more concrete type of an argument than its own, when the expression + shows one: the type of the module under [( _ : S )] constraints, for an + application of an inline functor the type of the functor's body (with the + parameters standing for the actual arguments, as in + [(functor (A : S) -> A) (M)]), and for a first-class module the type of + the packed module. Its items are the same runtime fields as the + argument's, so a value the argument's signature only names (a shared module + type item) is found there by name; when the argument's own type cannot be + expanded at all (a module type outside the analysis root), callers + reference all of its values. *) +let rec concreteArgumentType ?(env = []) (argumentExpr : Typedtree.module_expr) + = + let ownType (e : Typedtree.module_expr) = + let moduleType = expandModuleType e.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType + in + (* The concrete type of an expression, or its own when it exposes items. *) + let concrete (e : Typedtree.module_expr) = + match concreteArgumentType ~env e with + | Some moduleType -> Some moduleType + | None -> ownType e + in + match argumentExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> concrete inner + | Tmod_ident (path, _) -> ( + let bound = + match Path.head path with + | head -> List.find_opt (fun (id, _) -> Ident.same id head) env + | exception _ -> None + in + match (bound, pathTail path) with + | Some (_, boundExpr), Some tail -> ( + match concrete boundExpr with + | Some moduleType -> findModuleInModuleType moduleType tail + | None -> None) + | _ -> None) + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedConcrete} -> packedConcrete + | None -> None) + | None -> None) + | Tmod_apply _ +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ +#endif + -> ( + match appliedInlineFunctor argumentExpr with + | Some (body, bound) -> ( + let env = bound @ env in + match concreteArgumentType ~env body with + | Some moduleType -> Some moduleType + | None -> ownType body) + | None -> None) + | _ -> None + +let rec valueInShape ~resolutions shape components = + match components with + | [] -> None + | [name] -> resolutions.Compat.projValue shape name + | name :: rest -> + Option.bind (resolutions.projModule shape name) (fun shape -> + valueInShape ~resolutions shape rest) + +(* Resolve anonymous members underneath their constraints, retaining the + defining scope for any named types reached after traversal has finished. *) +let rec argumentValue ~resolutions ~parameters ?(visited = []) + (e : Typedtree.module_expr) components = + if List.memq e visited then None + else + let visited = e :: visited in + let resolve = argumentValue ~resolutions ~parameters ~visited in + let fromType () = + findValueInModuleType + ~expand:(fun mt -> expandModuleType ~resolutions ~parameters mt) + e.mod_type components + in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> resolve inner components + | Tmod_structure {str_items} -> ( + match components with + | name :: (_ :: _ as rest) -> + let rec member = function + | [] -> None + | (item : Typedtree.structure_item) :: items -> ( + let matching (mb : Typedtree.module_binding) = + mb.mb_name.txt = Some name + in + let binding = + match item.str_desc with + | Tstr_module mb when matching mb -> Some mb + | Tstr_recmodule mbs -> List.find_opt matching mbs + | _ -> None + in + match binding with + | Some mb -> resolve mb.mb_expr rest + | None -> ( + match item.str_desc with + | Tstr_include {incl_mod; incl_type} + when List.exists + (fun item -> signatureItemName item = Some name) + incl_type -> + resolve incl_mod components + | _ -> member items)) + in + member (List.rev str_items) + | _ -> fromType ()) + | Tmod_ident (path, _) -> ( + match resolutions.Compat.bindingOfPath path with + | Some (_, definition, resolver, 0) -> + let next = Option.value resolver ~default:resolutions in + argumentValue ~resolutions:next + ~parameters: + (if next.context = resolutions.context then parameters else []) + ~visited definition components + | _ -> None) + | _ -> None + +let registerPackedModule (vb : Typedtree.value_binding) = + let packed = + match vb.vb_expr.exp_desc with + | Texp_pack moduleExpr -> Some moduleExpr + | _ -> None + in + match (vb.vb_pat.pat_desc, packed) with +#if OCAML_VERSION < (5, 2, 0) + | Tpat_var (_, {loc}), Some moduleExpr -> +#else + | Tpat_var (_, {loc}, _), Some moduleExpr -> +#endif + let concrete = + match concreteArgumentType moduleExpr with + | Some moduleType -> Some moduleType + | None -> ( + let moduleType = expandModuleType moduleExpr.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType) + in + let resolutions = !identResolutions in + let parameters = !functorParameters in + let shape = moduleShapeOfExpr moduleExpr in + let resolveValue components = + match + Option.bind shape (fun shape -> + valueInShape ~resolutions shape components) + with + | Some _ as loc -> loc + | None -> ( + match argumentValue ~resolutions ~parameters moduleExpr components with + | Some _ as loc -> loc + | None -> + Option.bind concrete (fun mt -> + findValueInModuleType + ~expand:(fun mt -> expandModuleType ~resolutions ~parameters mt) + mt components)) + in + Hashtbl.replace packedModules (definitionKey loc.loc_start) + { + packedHead = functorHeadOf moduleExpr; + packedShape = shape; + packedConcrete = concrete; + packedResolveValue = resolveValue; + packedRange = definitionRange moduleExpr; + packedExpr = moduleExpr; + } + | _ -> () + +let () = registerPackedModuleRef := registerPackedModule + +(* Implementation of a value of an actual functor argument, by path. *) +let argumentItemResolver (argumentExpr : Typedtree.module_expr) = + match moduleIdent argumentExpr with + | Some (path, _) + when Compat.shapeResolutionAvailable && isFunctorParameterPath path -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + ViaParameter (p.functorDef, p.paramIndex, p.prefix @ components) + | _ -> Direct (fun _ -> None)) + | _ -> + (* A first-class module from a value: looked up when resolving, once every + file has registered its packed modules. *) + let packedPos = + match (unwrapConstraints argumentExpr).mod_desc with + | Tmod_unpack (packed, _) -> unpackedBinding packed + | _ -> None + in + let shape = + match packedPos with None -> moduleShapeOfExpr argumentExpr | Some _ -> None + in + let resolutions = !identResolutions in + let parameters = !functorParameters in + let expand mt = expandModuleType ~resolutions ~parameters mt in + let declared = argumentModuleType argumentExpr in + let concrete = + match packedPos with + | None -> concreteArgumentType argumentExpr + | Some _ -> None + in + let packed () = + match packedPos with + | Some pos -> Hashtbl.find_opt packedModules pos + | None -> None + in + let shape () = + (* A pack's shape and named types belong to its defining resolver, not + the unit unpacking it. Its stored closure handles both together. *) + match packed () with Some _ -> None | None -> shape + in + let concrete () = + match packed () with Some _ -> None | None -> concrete + in + (* By shape, then by name in the concrete type, then in the declared + one (a shared module type item, forwarded to its implementations). *) + let firstSome resolvers components = + resolvers + |> List.fold_left + (fun acc resolve -> + match acc with Some _ -> acc | None -> resolve components) + None + in + Direct + (firstSome + [ + (fun components -> + match shape () with + | Some shape -> valueInShape ~resolutions shape components + | None -> None); + (fun components -> + match packed () with + | Some {packedResolveValue} -> packedResolveValue components + | None -> argumentValue ~resolutions ~parameters argumentExpr components); + (fun components -> + match concrete () with + | Some concrete -> findValueInModuleType ~expand concrete components + | None -> None); + findValueInModuleType ~expand declared; + ]) + +(* Applications already recorded as part of an outer curried application, + by node identity (a ppx may emit distinct applications at one position). *) +let recordedApplications : Typedtree.module_expr list ref = ref [] + +(* A holder argument need not have a path: [Apply (struct module F ... end)]. + Capture its lexical member resolvers now, before the traversal leaves the + enclosing parameter scope. Includes and aliases retain that same scope. *) +let argumentHeadResolver argumentExpr = + let resolutions = !identResolutions in + let rec ofExpr env ?namePos (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> ofExpr env ?namePos inner + | Tmod_structure {str_items} -> ( + let _, members = + List.fold_left + (fun (env, members) (item : Typedtree.structure_item) -> + let bind (env, members) (mb : Typedtree.module_binding) = + let resolve = + ofExpr env ~namePos:mb.mb_name.loc.loc_start mb.mb_expr + in + let env = + match mb.mb_id with + | Some id -> (id, resolve) :: env + | None -> env + in + let members = + match mb.mb_name.txt with + | Some name -> (name, resolve) :: members + | None -> members + in + (env, members) + in + match item.str_desc with + | Tstr_module mb -> bind (env, members) mb + | Tstr_recmodule mbs -> List.fold_left bind (env, members) mbs + | Tstr_include {incl_mod; incl_type} -> + let resolve = ofExpr env incl_mod in + List.fold_left + (fun (env, members) item -> + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> + let name = Ident.name id in + let member rest = resolve (name :: rest) in + ((id, member) :: env, (name, member) :: members) + | None -> (env, members)) + (env, members) incl_type + | _ -> (env, members)) + (env, []) str_items + in + function + | name :: rest -> + Option.bind (List.assoc_opt name members) (fun f -> f rest) + | [] -> None) + | Tmod_ident (path, _) -> ( + let direct = functorHeadOf e in + let parameter = findFunctorParameter path in + let rec local path components = + match path with + | Path.Pident id -> + List.find_opt (fun (other, _) -> Ident.same id other) env + |> Option.map (fun (_, resolve) -> (resolve, components)) + | Path.Pdot (parent, name) -> local parent (name :: components) + | _ -> None + in + let local = local path [] in + fun components -> + match (local, parameter, pathComponents path) with + | Some (resolve, prefix), _, _ -> resolve (prefix @ components) + | _, Some p, Some prefix -> + Some + (ParamHead + (p.functorDef, p.paramIndex, p.prefix @ prefix @ components, 0)) + | _ -> ( + let extended = + List.fold_left (fun p name -> Path.Pdot (p, name)) path components + in + if components = [] && direct <> None then direct + else + match packedHeadOfPath resolutions extended with + | Some head -> Some head + | None -> + resolutions.headKeyOfPath extended + |> Option.map (fun (key, consumed) -> + partialHeadOfPath resolutions extended (Key (key, consumed)))) + ) + | Tmod_functor _ -> ( + let pos = Option.value namePos ~default:e.mod_loc.loc_start in + function + | [] -> Some (Key (definitionKey ~resolutions pos, 0)) + | _ -> None) + | _ -> ( + let direct = functorHeadOf e in + function [] -> direct | _ -> None) + in + ofExpr [] argumentExpr + +(* [F (A) (B)] is [Tmod_apply (Tmod_apply (F, A), B)]: collect the functor and + the arguments in order, and defer crediting the calls made through each + parameter to the corresponding argument. *) +let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = + if not (List.memq moduleExpr !recordedApplications) then + let chain = ref [] in + (* The arguments of this application chain, in order, and its head. A + unit application ([F ()]) consumes an index without an argument. *) + let rec flatten (e : Typedtree.module_expr) args = + match e.mod_desc with + | Tmod_apply (functorExpr, argumentExpr, _) -> + recordedApplications := e :: !recordedApplications; + chain := e :: !chain; + flatten functorExpr (Some argumentExpr :: args) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> + recordedApplications := e :: !recordedApplications; + chain := e :: !chain; + flatten functorExpr (None :: args) +#endif + | Tmod_constraint (inner, _, _, _) -> flatten inner args + | _ -> (e, args) + in + let headExpr, args = flatten moduleExpr [] in + let head = functorHeadOf headExpr in + if !Common.Cli.debug then + Log_.item "functorApplication %s key:%s args:%d@." + (moduleExpr.mod_loc.loc_start |> posToString) + (match head with + | Some head -> functorHeadToString head + | None -> "none") + (List.length args); + match head with + | None -> + (* The functors passed to an application whose head cannot be chased + (a first-class module from elsewhere, a member of the result of an + applied functor parameter) escape: their calls can only be + forwarded. So does the nearest resolvable parent of the head: + [G.Inner (X)] with [module G = F (A)] applies a functor nested in + the argument passed for [F], while [Other.G.Inner (X)] may apply + one nested in a foreign unpacked module. *) + args + |> List.iter (fun argumentExpr -> + match argumentExpr with + | Some argumentExpr -> ( + escapedRanges := definitionRange argumentExpr @ !escapedRanges; + match functorHeadOf argumentExpr with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | None -> ()); + let rec escapeParent = function + | Path.Pdot (parent, _) -> ( + match headOfPath parent [] with + | Some head -> + escapedHeads := head :: !escapedHeads; + escapedRanges := definitionRangeOfPath parent @ !escapedRanges + | None -> escapeParent parent) + | _ -> () + in + (match headExpr.mod_desc with + | Tmod_ident (path, _) -> + escapeUnpackedExports headExpr; + escapeParent path + | _ -> ()) + | Some head -> + incr nextApplicationId; + let applicationId = !nextApplicationId in + Hashtbl.replace applicationHeads applicationId head; + !chain + |> List.iter (fun (e : Typedtree.module_expr) -> + let pos = definitionKey e.mod_loc.loc_start in + let ids = + Option.value (Hashtbl.find_opt applicationIdsByPosition pos) + ~default:[] + in + Hashtbl.replace applicationIdsByPosition pos + (List.sort_uniq compare (applicationId :: ids))); + args + |> List.iteri (fun i argumentExpr -> + match argumentExpr with + | Some argumentExpr -> + delayedApplications := + { + applicationId; + bindings = []; + appliedFunctor = head; + argIndex = i; + resolver = argumentItemResolver argumentExpr; + argHead = argumentHeadResolver argumentExpr; + argRange = definitionRange argumentExpr; + } + :: !delayedApplications + | None -> ()) + (* Traverse the AST *) let traverseStructure ~doTypes ~doExternals = let super = Tast_mapper.default in let expr self e = e |> collectExpr super self in let pat self p = p |> collectPattern super self in let module_expr self (moduleExpr : Typedtree.module_expr) = + let oldFunctorParameters = !functorParameters in + (match moduleExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> ( + (* [module F : FT = functor ...]: carry the binding's key through. *) + match findFunctorKey moduleExpr with + | Some pos -> setFunctorKey inner pos + | None -> ()) + | Tmod_functor (param, body) -> + let functorDef = + match findFunctorKey moduleExpr with + | Some pos -> pos + | None -> definitionKey moduleExpr.mod_loc.loc_start + in + setFunctorKey body functorDef; + let paramIndex = + !functorParameters + |> List.filter (fun p -> p.functorDef = functorDef) + |> List.length + in + (match param with + | Named (Some id, _, mty) -> + functorParameters := + { + paramId = id; + functorDef; + paramIndex; + prefix = []; + paramType = Some mty.mty_type; + } + :: !functorParameters + | _ -> + (* Unnamed or unit parameter: still occupies an index. *) + functorParameters := + { + paramId = Ident.create_local "_"; + functorDef; + paramIndex; + prefix = []; + paramType = None; + } + :: !functorParameters) + | _ -> ()); (match moduleExpr.mod_desc with | Tmod_apply (_functorExpr, argumentExpr, coercion) -> (* Functor arguments are used through the parameter coercion, not every - value exposed by the actual argument module. *) - addCoercedModuleValueReferences ~locFrom:argumentExpr.mod_loc ~coercion - ~actualType:argumentExpr.mod_type + value exposed by the actual argument module. When the argument is a + module path, its shape lets the references target that module's + implementation rather than a shared module type item. *) + let ident = moduleIdent argumentExpr in + let shape = moduleShapeOfExpr argumentExpr in + (* A constraint node [(M : S)] can carry a ghost location, which would + drop the references: use the module path's own location then. *) + let locFrom = + match ident with + | Some (_, lid) when not lid.loc.loc_ghost -> lid.loc + | _ when not argumentExpr.mod_loc.loc_ghost -> argumentExpr.mod_loc + | _ -> moduleExpr.mod_loc + in + let concrete = concreteArgumentType argumentExpr in + let actualType, coercion = + let declared = argumentModuleType argumentExpr in + match (expandedSignature declared, concrete) with + | [], Some concrete -> (concrete, Typedtree.Tcoerce_none) + | _ -> (declared, coercion) + in + if !Common.Cli.debug then + Log_.item "functorArgument %s coercion:%s type:%s items:%d@." + (argumentExpr.mod_loc.loc_start |> posToString) + (match coercion with + | Tcoerce_none -> "none" + | Tcoerce_structure (vs, ms) -> + Printf.sprintf "structure(%d values, %d modules)" (List.length vs) + (List.length ms) + | Tcoerce_alias _ -> "alias" + | Tcoerce_functor _ -> "functor" + | Tcoerce_primitive _ -> "primitive") + (match actualType with + | Mty_ident p -> "ident " ^ Path.name p + | Mty_signature _ -> "signature" + | Mty_functor _ -> "functor" + | Mty_alias p -> "alias " ^ Path.name p) + (List.length (expandedSignature actualType)); + let parameter = + match ident with + | Some (path, _) when Compat.shapeResolutionAvailable -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> Some (p, components) + | _ -> None) + | _ -> None + in + (match parameter with + | Some (p, components) -> + recordParameterCoercion ~locFrom ~coercion ~actualType p components + | None -> + addCoercedModuleValueReferences ~locFrom ~coercion ?shape ?concrete + ~actualType ()); + recordFunctorApplication moduleExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> recordFunctorApplication moduleExpr +#endif + | Tmod_unpack (packed, _) -> + unpackOperands := PosSet.add packed.exp_loc.loc_start !unpackOperands | _ -> ()); - super.Tast_mapper.module_expr self moduleExpr + let r = super.Tast_mapper.module_expr self moduleExpr in + functorParameters := oldFunctorParameters; + r in let value_binding self vb = vb |> collectValueBinding super self in let structure_item self (structureItem : Typedtree.structure_item) = let oldModulePath = ModulePath.getCurrent () in (match structureItem.str_desc with - | Tstr_module {mb_expr; mb_id; mb_loc} -> ( + | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( + setFunctorKey mb_expr (definitionKey mb_name.loc.loc_start); + registerParameterAlias mb_id mb_expr; + registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in @@ -449,6 +2425,61 @@ let traverseStructure ~doTypes ~doExternals = ((ModulePath.getCurrent ()).path @ [!Common.currentModuleName])) | _ -> ()) + | Tstr_recmodule moduleBindings -> + moduleBindings + |> List.iter (fun (mb : Typedtree.module_binding) -> + setFunctorKey mb.mb_expr (definitionKey mb.mb_name.loc.loc_start); + registerParameterAlias mb.mb_id mb.mb_expr; + match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with + | Some id, Tmod_functor _ -> + functorsByIdent := + (id, Key (definitionKey mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent + | _ -> ()); + (* [module rec G : T = H and H : T = F]: an alias or partial + application stands for the functor's key; a forward alias resolves + once the later binding has, so iterate to a fixed point. *) + let resolveKeys () = + moduleBindings + |> List.fold_left + (fun changed (mb : Typedtree.module_binding) -> + match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with + | ( Some id, + ( Tmod_apply _ | Tmod_ident _ | Tmod_unpack _ +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ +#endif + ) ) -> ( + match functorHeadOf mb.mb_expr with + | Some key when List.assq_opt id !functorsByIdent <> Some key -> + functorsByIdent := + (id, key) + :: List.filter + (fun (id', _) -> not (Ident.same id id')) + !functorsByIdent; + true + | _ -> changed) + | _ -> changed) + false + in + let rec fixpoint n = if n > 0 && resolveKeys () then fixpoint (n - 1) in + fixpoint (List.length moduleBindings); + (* Likewise for aliases of a functor parameter: [module rec G : S = H + and H : S = M] registers H first, then G through H. *) + let registerAliases () = + moduleBindings + |> List.fold_left + (fun changed (mb : Typedtree.module_binding) -> + match mb.mb_id with + | Some id when findFunctorParameter (Pident id) = None -> + registerParameterAlias mb.mb_id mb.mb_expr; + findFunctorParameter (Pident id) <> None || changed + | _ -> changed) + false + in + let rec aliasFixpoint n = + if n > 0 && registerAliases () then aliasFixpoint (n - 1) + in + aliasFixpoint (List.length moduleBindings) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in let path = currentModulePath.path @ [!Common.currentModuleName] in @@ -474,6 +2505,41 @@ let traverseStructure ~doTypes ~doExternals = DeadType.addDeclaration ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( + registerUnpackedExports incl_type incl_mod; + (* [include M] with [M] a functor parameter: the included identifiers + stand for the parameter's items. *) + (match moduleIdent incl_mod with + | Some (path, _) -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + incl_type + |> List.iter (fun (item : Types.signature_item) -> + match item with + | Sig_value _ -> + let id, _, _, _ = item |> Compat.getSigValue in + functorParameters := + { + p with + paramId = id; + prefix = p.prefix @ components @ [Ident.name id]; + } + :: !functorParameters + | Sig_module _ | Sig_modtype _ -> ( + (* Included modules, and module types ([module type T = + T] after [include M]), stand for the parameter's. *) + match item |> Compat.getSigModuleModtype with + | Some (id, _, _) -> + functorParameters := + { + p with + paramId = id; + prefix = p.prefix @ components @ [Ident.name id]; + } + :: !functorParameters + | None -> ()) + | _ -> ()) + | _ -> ()) + | None -> ()); match incl_mod.mod_desc with | Tmod_ident (_path, _lid) -> let currentPath = @@ -485,6 +2551,8 @@ let traverseStructure ~doTypes ~doExternals = ~doValues:false (* TODO: also values? *) ~moduleLoc:incl_mod.mod_loc ~path:currentPath) | _ -> ()) + | Tstr_open {open_expr; open_bound_items} -> + registerUnpackedExports open_bound_items open_expr | Tstr_exception _ -> ( match structureItem.str_desc |> Compat.tstrExceptionGet with | Some (id, loc) -> @@ -515,11 +2583,18 @@ let processValueDependency (* The signature item is not a declaration (e.g. a [val] inside a named module type used to constrain a module or functor result), so it can never be resolved as dead. Forward the references made to the - signature item onto the implementation instead. *) - DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; + signature item onto the implementation instead. Occurrences resolved + through shapes already point at the implementation and are not in + this set; this is the conservative fallback for the rest, and keeps + every implementation of the item live. *) ValueReferences.find posFrom |> PosSet.iter (fun posRef -> - if posRef <> posTo then + if + posRef <> posTo + && not + (PosPairSet.mem (posFrom, posRef) + !nonForwardableReferences) + then let locRef = { Location.loc_start = posRef; @@ -536,16 +2611,189 @@ let processValueDependency (* Value dependencies are processed once all files have been scanned, so that declarations and references from every file are known. *) let delayedValueDependencies = ref [] +let packedValueDependencies = ref [] + +let processValueDependencies dependencies = + let targets = PosHash.create 64 in + let locations = PosHash.create 64 in + let declarationEdges = ref [] in + dependencies + |> List.iter (fun ((locTo : Location.t), (locFrom : Location.t)) -> + if + (not (locTo.loc_ghost || locFrom.loc_ghost)) + && locTo.loc_start <> locFrom.loc_start + then ( + if + PosHash.mem decls locFrom.loc_start + && not + (PosSet.mem locTo.loc_start + (PosHash.findSet targets locFrom.loc_start)) + then declarationEdges := (locTo, locFrom) :: !declarationEdges; + PosHash.addSet targets locFrom.loc_start locTo.loc_start; + PosHash.replace locations locFrom.loc_start locFrom; + PosHash.replace locations locTo.loc_start locTo)); + let pending = Queue.create () in + let queued = ref PosSet.empty in + let enqueue pos = + if not (PosHash.mem decls pos || PosSet.mem pos !queued) then ( + queued := PosSet.add pos !queued; + Queue.add pos pending) + in + let forward posFrom posTo = + processValueDependency + (PosHash.find locations posTo, PosHash.find locations posFrom) + in + (* Declaration edges add real references exactly once. Signature-only + nodes then forward to a fixed point, regardless of dependency order. *) + (* Preserve the compiler's declaration-edge order for ordinary function + references; only signature forwarding needs the work queue. *) + List.rev !declarationEdges |> List.iter processValueDependency; + PosHash.iter (fun posFrom _ -> enqueue posFrom) targets; + while not (Queue.is_empty pending) do + let posFrom = Queue.take pending in + queued := PosSet.remove posFrom !queued; + PosHash.findSet targets posFrom + |> PosSet.iter (fun posTo -> + let before = ValueReferences.find posTo in + forward posFrom posTo; + if not (PosSet.equal before (ValueReferences.find posTo)) then + enqueue posTo) + done; + DeadOptionalArgs.forwardDelayedItems targets let forceDelayedItems () = + let redirects = List.rev !delayedRedirects in + delayedRedirects := []; + redirects + |> List.iter (fun {locFrom; locTo; locToImpl} -> + let locTo = + match PosHash.find_opt decls locTo.loc_start with + | Some _ -> locTo + | None -> locToImpl + in + addValueReference ~addFileReference:true ~locFrom ~locTo); + (* Credit calls made through functor parameters to the actual arguments. + A functor without any application supplying the parameter (never + applied, or applied through something this analysis cannot chase, such + as a first-class module from another file) keeps the conservative + behaviour: the calls are forwarded to every implementation of the item. + An argument whose item cannot be resolved falls back to the item too. *) + delayedApplications := List.rev !delayedApplications; + (* Interface items stand for their implementations (value dependencies + pair an implementation with the item it satisfies). *) + let sigToImpl = Hashtbl.create 16 in + !packedValueDependencies + |> List.iter (fun (context, ((locTo : Location.t), (locFrom : Location.t))) -> + if not (locTo.loc_ghost || locFrom.loc_ghost) then + Hashtbl.replace sigToImpl (locFrom.loc_start, context) (locTo.loc_start, context)); + packedValueDependencies := []; + resolveParameterHeadedApplications ~sigToImpl; + escapePackedModulesUsedElsewhere ~sigToImpl; + let keys, ranges = escapedKeysAndRanges ~sigToImpl in + let isEscaped def = List.mem def keys || inRanges def ranges in + Hashtbl.iter + (fun (def, index, components) calls -> + let calls = List.rev calls in + if !Common.Cli.debug then + Log_.item "parameterCalls %s index:%d %s: %s@." (def |> keyToString) + index + (String.concat "." components) + (if isEscaped def then "escaped" + else if hasApplication def index then "applied" + else "never applied"); + (* An escaping functor may have applications this analysis cannot + see: its calls are forwarded, even when some applications are + known (crediting those precisely as well would count them twice). *) + if isEscaped def then + calls + |> List.iter (fun {call; callFrom; callTo; callToImpl; callPath} -> + call + |> DeadOptionalArgs.addReferences ~locFrom:callFrom ~locTo:callTo + ?locToImpl:callToImpl ~path:callPath) + else if hasApplication def index then + match + resolveArgumentItems ~visited:[] ~bindings:[] def index components + with + | [] -> + calls + |> List.iter (fun {call; callTo} -> + DeadOptionalArgs.addCallToImplementation + ~posTo:callTo.loc_start call) + | locs -> + locs + |> List.iter (fun locTo -> + calls + |> List.iter (fun {call; callTo; callFrom} -> + (* Resolution can become possible only after the + argument's pack was scanned. The actual call is + a use even when its coercion could not resolve it. *) + Option.iter + (fun locTo -> + addValueReference ~addFileReference:true + ~locFrom:callFrom ~locTo) + locTo; + let locTo = Option.value locTo ~default:callTo in + DeadOptionalArgs.addCallToImplementation + ~posTo:locTo.loc_start call)) + else ()) + parameterCalls; + Hashtbl.reset parameterCalls; + (* Reference the items a parameter's coercion uses, in the arguments of the + enclosing functor's applications; the module type item is the fallback + when an argument cannot be resolved. An escaped functor also needs that + fallback even when some known applications resolve precisely: its + unseen applications can supply other implementations of the item. *) + List.rev !parameterCoercions + |> List.iter + (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> + if isEscaped outerFunctor then + addValueReference ~addFileReference:true ~locFrom:coercionFrom + ~locTo:coercionTo + else + let resolved = + resolveArgumentItems ~visited:[] ~bindings:[] outerFunctor + outerIndex itemPath + in + let applied = hasApplication outerFunctor outerIndex in + match resolved with + | [] when applied -> + addValueReference ~addFileReference:true ~locFrom:coercionFrom + ~locTo:coercionTo + | _ -> + resolved + |> List.iter (fun locTo -> + let locTo = Option.value locTo ~default:coercionTo in + addValueReference ~addFileReference:true + ~locFrom:coercionFrom ~locTo)); + parameterCoercions := []; + escapedHeads := []; + escapedRanges := []; + delayedApplications := []; + Hashtbl.reset applicationIdsByPosition; + Hashtbl.reset applicationPrefixes; + Hashtbl.reset applicationHeads; + DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; - dependencies |> List.iter processValueDependency + processValueDependencies dependencies -let processStructure ~cmt_value_dependencies ~doTypes ~doExternals - (structure : Typedtree.structure) = +let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes + ~doExternals (structure : Typedtree.structure) = let traverseStructure = traverseStructure ~doTypes ~doExternals in + identResolutions := cmt_ident_resolutions; + unpackedExportCandidates := []; + recordedApplications := []; + functorsByIdent := []; + functorKeys := []; structure |> traverseStructure.structure traverseStructure |> ignore; + unpackedExportCandidates := []; + recordedApplications := []; + functorKeys := []; + identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in + packedValueDependencies := + List.rev_append + (List.map (fun dep -> (cmt_ident_resolutions.Compat.context, dep)) valueDependencies) + !packedValueDependencies; delayedValueDependencies := List.rev_append valueDependencies !delayedValueDependencies diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 630d8386..df106235 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -1,7 +1,22 @@ open Common +(* Compiled units already scanned, by source and dependency context: a broad + root may hold copies of the same artifact (a library's objects and its + _build/install copy, byte and native objects), which must not be scanned + twice. *) +let scannedUnits = Hashtbl.create 256 + let loadCmtFile ~cmtRoot cmtFilePath = let cmt_infos = Cmt_format.read_cmt cmtFilePath in + (* Identical source can use different dependency implementations, even + through the same interface. Preserve the full resolved context without + distinguishing actual byte/native/install copies. *) + let unitKey = + (Compat.compilationContext ~cmtFilePath cmt_infos, Filename.check_suffix cmtFilePath ".cmti") + in + if Hashtbl.mem scannedUnits unitKey then () + else + let () = Hashtbl.replace scannedUnits unitKey () in let excludePath sourceFile = !Cli.excludePaths |> List.exists (fun prefix_ ->