diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index acaf98d896c..0a62ff817ee 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -186,11 +186,11 @@ module Consistbl = Consistbl.Make (CU.Name) (Import_info.Intf.Nonalias.Kind) let crc_interfaces = Consistbl.create () let interfaces = ref ([] : CU.Name.t list) -let implementations_defined = ref ([] : (CU.Name.t * string) list) +let implementations_defined = ref ([] : (CU.t * string) list) let check_consistency file_name cu = begin try - let source = List.assoc (CU.name cu.cu_name) !implementations_defined in + let source = List.assoc cu.cu_name !implementations_defined in raise (Error (Multiple_definition(cu.cu_name, file_name, source))); with Not_found -> () end; @@ -213,7 +213,7 @@ let check_consistency file_name cu = raise(Error(Inconsistent_import(name, user, auth))) end; implementations_defined := - (CU.name cu.cu_name, file_name) :: !implementations_defined + (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = Consistbl.extract !interfaces crc_interfaces diff --git a/dune b/dune index 18728e02c05..ba6eafb4e2a 100644 --- a/dune +++ b/dune @@ -199,6 +199,7 @@ mode jkind_types jkind_intf + signature_with_global_bindings typedtree printtyped ctype diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml index 996e014ba18..929ce526ae1 100644 --- a/file_formats/cmi_format.ml +++ b/file_formats/cmi_format.ml @@ -63,15 +63,17 @@ type flags = pers_flags list type header = { header_name : Compilation_unit.Name.t; header_kind : kind; + header_globals : Global_module.t array; header_sign : Serialized.signature; - header_params : Global_module.Name.t list; + header_params : Global_module.t list; } type 'sg cmi_infos_generic = { cmi_name : Compilation_unit.Name.t; cmi_kind : kind; + cmi_globals : Global_module.t array; cmi_sign : 'sg; - cmi_params : Global_module.Name.t list; + cmi_params : Global_module.t list; cmi_crcs : crcs; cmi_flags : flags; } @@ -125,6 +127,7 @@ let input_cmi_lazy ic = let { header_name = name; header_kind = kind; + header_globals = globals; header_sign = sign; header_params = params; } = (input_value ic : header) in @@ -134,6 +137,7 @@ let input_cmi_lazy ic = { cmi_name = name; cmi_kind = kind; + cmi_globals = globals; cmi_sign = deserialize data sign; cmi_params = params; cmi_crcs = crcs; @@ -192,6 +196,7 @@ let output_cmi filename oc cmi = { header_name = cmi.cmi_name; header_kind = cmi.cmi_kind; + header_globals = cmi.cmi_globals; header_sign = sign; header_params = cmi.cmi_params; }; diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli index 590f7233da5..c5de4ad8217 100644 --- a/file_formats/cmi_format.mli +++ b/file_formats/cmi_format.mli @@ -32,8 +32,9 @@ type kind = type 'sg cmi_infos_generic = { cmi_name : Compilation_unit.Name.t; cmi_kind : kind; + cmi_globals : Global_module.t array; cmi_sign : 'sg; - cmi_params : Global_module.Name.t list; + cmi_params : Global_module.t list; (* CR lmaurer: Should be [Parameter_name.t list] *) cmi_crcs : Import_info.t array; cmi_flags : pers_flags list; } diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 0d1cd871792..917916d7719 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -152,6 +152,7 @@ COMPILERLIBS_SOURCES=\ typing/typedtree.ml \ typing/btype.ml \ typing/subst.ml \ + typing/signature_with_global_bindings.ml \ typing/predef.ml \ typing/datarepr.ml \ file_formats/cmi_format.ml \ diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index cb847cedd01..5fc28cb331b 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -127,6 +127,7 @@ lazy_backtrack zero_alloc_utils subst + signature_with_global_bindings predef datarepr unit_info @@ -300,6 +301,8 @@ (copy_files ../../typing/subst.ml) +(copy_files ../../typing/signature_with_global_bindings.ml) + (copy_files ../../typing/predef.ml) (copy_files ../../typing/datarepr.ml) @@ -456,6 +459,8 @@ (copy_files ../../typing/subst.mli) +(copy_files ../../typing/signature_with_global_bindings.mli) + (copy_files ../../typing/predef.mli) (copy_files ../../typing/datarepr.mli) @@ -606,6 +611,7 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Btype.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Subst.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Signature_with_global_bindings.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Bytesections.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Cmi_format.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Debuginfo.cmo @@ -703,6 +709,7 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Btype.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Subst.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Signature_with_global_bindings.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Bytesections.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Cmi_format.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Debuginfo.cmx diff --git a/testsuite/tests/packs/inconsistent/main.compilers.reference b/testsuite/tests/packs/inconsistent/main.compilers.reference index 521126ca5a7..ee87d64c20e 100644 --- a/testsuite/tests/packs/inconsistent/main.compilers.reference +++ b/testsuite/tests/packs/inconsistent/main.compilers.reference @@ -1,3 +1,5 @@ -File "main.ml", line 1: +File "main.ml", line 28, characters 11-30: +28 | module _ = Use_member_directly + ^^^^^^^^^^^^^^^^^^^ Error: The file subdir/use_member_directly.cmi is imported both as "Pack.Member" and as "Member". diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index a0b800c037f..e8fd8325014 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -1005,10 +1005,10 @@ module Value1 : sig end module Value2 : sig end -> sig end -> sig end module Name2_1 : sig end module Name2_1 : sig end ->> Fatal error: Unimplemented: instance identifier - Base[Name1:Value1][Name2:Value2[Name2_1:Value2_1]] -Uncaught exception: Misc.Fatal_error - +Line 9, characters 11-64: +9 | module _ = Base(Name1)(Value1)(Name2)(Value2(Name2_1)(Value2_1)) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Unbound module "Base[Name1:Value1][Name2:Value2[Name2_1:Value2_1]]" |}](*********) (* modes *) diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml index e41fcd246b8..6d23e771ef9 100644 --- a/testsuite/tests/self-contained-toplevel/main.ml +++ b/testsuite/tests/self-contained-toplevel/main.ml @@ -31,6 +31,7 @@ let () = cmi_kind; cmi_params; cmi_sign; + cmi_globals; cmi_crcs; cmi_flags } = @@ -41,6 +42,7 @@ let () = cmi_kind; cmi_params; cmi_sign = Subst.Lazy.of_signature cmi_sign; + cmi_globals; cmi_crcs; cmi_flags } diff --git a/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.ml b/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.ml new file mode 100644 index 00000000000..24ff3f1f83b --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.ml @@ -0,0 +1,2 @@ +module Monoid_utils_of_banana = + Monoid_utils(Banana)(List_monoid) [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.reference b/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.reference new file mode 100644 index 00000000000..f508cfb5ba9 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_name_not_found.reference @@ -0,0 +1,5 @@ +File "bad_instance_arg_name_not_found.ml", line 2, characters 2-35: +2 | Monoid_utils(Banana)(List_monoid) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module "Monoid_utils" has no parameter "Banana". +Hint: Parameters for "Monoid_utils": "Monoid" diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.ml b/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.ml new file mode 100644 index 00000000000..566700940fd --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.ml @@ -0,0 +1,2 @@ +module Monoid_utils_of_int = + Monoid_utils(Monoid)(Monoid_utils(Monoid)(List_monoid)) [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.reference b/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.reference new file mode 100644 index 00000000000..0d9c02db899 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_not_arg.reference @@ -0,0 +1,6 @@ +File "bad_instance_arg_value_not_arg.ml", line 2, characters 2-57: +2 | Monoid_utils(Monoid)(Monoid_utils(Monoid)(List_monoid)) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module "Monoid_utils[Monoid:List_monoid]" + cannot be used as an argument for parameter "Monoid". +Hint: Compile "monoid_utils.cmi" with "-as-argument-for Monoid". diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.ml b/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.ml new file mode 100644 index 00000000000..735908be3a7 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.ml @@ -0,0 +1,2 @@ +module Monoid_utils_of_int = + Monoid_utils(Monoid)(Banana) [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.reference b/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.reference new file mode 100644 index 00000000000..83c5e3a035d --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_not_found.reference @@ -0,0 +1,4 @@ +File "bad_instance_arg_value_not_found.ml", line 2, characters 2-30: +2 | Monoid_utils(Monoid)(Banana) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Unbound module "Banana" in instance "Monoid_utils[Monoid:Banana]" diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.ml b/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.ml new file mode 100644 index 00000000000..c2e53bb34d8 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.ml @@ -0,0 +1,2 @@ +module Category_utils_of_list_monoid = + Category_utils(Category)(List_monoid) [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.reference b/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.reference new file mode 100644 index 00000000000..ebdff014301 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_arg_value_wrong_type.reference @@ -0,0 +1,7 @@ +File "bad_instance_arg_value_wrong_type.ml", line 2, characters 2-39: +2 | Category_utils(Category)(List_monoid) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module "List_monoid" + is used as an argument for the parameter "Category" but "List_monoid" + is an argument for "Monoid". +Hint: "list_monoid.cmi" was compiled with "-as-argument-for Category". diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml new file mode 100644 index 00000000000..6776ff31a5d --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml @@ -0,0 +1,5 @@ +let (f @ portable) () = + let module Monoid_utils_of_list_monoid = + Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] + in + () diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference new file mode 100644 index 00000000000..2656c411692 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference @@ -0,0 +1,4 @@ +File "bad_instance_wrong_mode.ml", line 3, characters 4-37: +3 | Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Modules are nonportable, so cannot be used inside a function that is portable. diff --git a/testsuite/tests/templates/basic/bad_param_not_param.reference b/testsuite/tests/templates/basic/bad_param_not_param.reference index 617c7f3d59e..b22c524fee1 100644 --- a/testsuite/tests/templates/basic/bad_param_not_param.reference +++ b/testsuite/tests/templates/basic/bad_param_not_param.reference @@ -1,3 +1,6 @@ -File "bad_param_not_param.mli", line 1: -Error: The module "Widget" is specified as a parameter, but "widget.cmi" - was not compiled with -as-parameter. +File "bad_param_not_param.mli", line 19, characters 17-25: +19 | val frobnicate : Widget.t -> Widget.t + ^^^^^^^^ +Error: The module "Widget" + is a parameter but is not declared as such for the current unit. +Hint: Compile the current unit with "-parameter Widget". diff --git a/testsuite/tests/templates/basic/bad_ref_direct.reference b/testsuite/tests/templates/basic/bad_ref_direct.reference index 8f19ec3859f..5790f587d91 100644 --- a/testsuite/tests/templates/basic/bad_ref_direct.reference +++ b/testsuite/tests/templates/basic/bad_ref_direct.reference @@ -1,3 +1,6 @@ -File "bad_ref_direct.ml", line 1: -Error: The file "monoid.cmi" contains the interface of a parameter. - "Monoid" is not declared as a parameter for the current unit (-parameter "Monoid"). +File "bad_ref_direct.ml", line 3, characters 12-21: +3 | let empty = Monoid.id + ^^^^^^^^^ +Error: The file "monoid.cmi" contains the interface of a parameter. "Monoid" + is not declared as a parameter for the current unit. +Hint: Compile the current unit with "-parameter Monoid". diff --git a/testsuite/tests/templates/basic/bad_ref_direct_imported.ml b/testsuite/tests/templates/basic/bad_ref_direct_imported.ml new file mode 100644 index 00000000000..6bff24a4455 --- /dev/null +++ b/testsuite/tests/templates/basic/bad_ref_direct_imported.ml @@ -0,0 +1,7 @@ +(* [Monoid] is not a parameter of this, but it _is_ imported because it's used + as a parameter *) + +module Monoid_utils_of_semigroup = + Monoid_utils(Monoid)(Monoid_of_semigroup) [@jane.non_erasable.instances] + +let empty = Monoid.empty diff --git a/testsuite/tests/templates/basic/bad_ref_direct_imported.reference b/testsuite/tests/templates/basic/bad_ref_direct_imported.reference new file mode 100644 index 00000000000..e10f16945fc --- /dev/null +++ b/testsuite/tests/templates/basic/bad_ref_direct_imported.reference @@ -0,0 +1,6 @@ +File "bad_ref_direct_imported.ml", line 7, characters 12-24: +7 | let empty = Monoid.empty + ^^^^^^^^^^^^ +Error: The file "monoid.cmi" contains the interface of a parameter. "Monoid" + is not declared as a parameter for the current unit. +Hint: Compile the current unit with "-parameter Monoid". diff --git a/testsuite/tests/templates/basic/bad_ref_indirect.reference b/testsuite/tests/templates/basic/bad_ref_indirect.reference index 02685ba7871..014115b7322 100644 --- a/testsuite/tests/templates/basic/bad_ref_indirect.reference +++ b/testsuite/tests/templates/basic/bad_ref_indirect.reference @@ -1,5 +1,7 @@ -File "bad_ref_indirect.ml", line 1: +File "bad_ref_indirect.ml", line 2, characters 13-32: +2 | let concat = Monoid_utils.concat + ^^^^^^^^^^^^^^^^^^^ Error: The module "Monoid_utils" is not accessible because it takes "Monoid" as a parameter and the current unit does not. -Hint: Pass `-parameter "Monoid"` to add "Monoid" as a parameter +Hint: Pass "-parameter Monoid" to add "Monoid" as a parameter of the current unit. diff --git a/testsuite/tests/templates/basic/category.mli b/testsuite/tests/templates/basic/category.mli new file mode 100644 index 00000000000..a43df728ddf --- /dev/null +++ b/testsuite/tests/templates/basic/category.mli @@ -0,0 +1 @@ +include Category_intf.S diff --git a/testsuite/tests/templates/basic/category_b.mli b/testsuite/tests/templates/basic/category_b.mli new file mode 100644 index 00000000000..a43df728ddf --- /dev/null +++ b/testsuite/tests/templates/basic/category_b.mli @@ -0,0 +1 @@ +include Category_intf.S diff --git a/testsuite/tests/templates/basic/category_b_of_category.ml b/testsuite/tests/templates/basic/category_b_of_category.ml new file mode 100644 index 00000000000..27065da9fa0 --- /dev/null +++ b/testsuite/tests/templates/basic/category_b_of_category.ml @@ -0,0 +1 @@ +include Category diff --git a/testsuite/tests/templates/basic/category_b_of_category.mli b/testsuite/tests/templates/basic/category_b_of_category.mli new file mode 100644 index 00000000000..d7668be20cb --- /dev/null +++ b/testsuite/tests/templates/basic/category_b_of_category.mli @@ -0,0 +1 @@ +include Category_intf.S with type ('a, 'b) t = ('a, 'b) Category.t diff --git a/testsuite/tests/templates/basic/category_intf.ml b/testsuite/tests/templates/basic/category_intf.ml new file mode 100644 index 00000000000..d4e57c911b0 --- /dev/null +++ b/testsuite/tests/templates/basic/category_intf.ml @@ -0,0 +1,6 @@ +module type S = sig + type ('a, 'b) t + + val id : ('a, 'a) t + val compose : first:('a, 'b) t -> second:('b, 'c) t -> ('a, 'c) t +end diff --git a/testsuite/tests/templates/basic/category_of_monoid.ml b/testsuite/tests/templates/basic/category_of_monoid.ml new file mode 100644 index 00000000000..7fd255ee680 --- /dev/null +++ b/testsuite/tests/templates/basic/category_of_monoid.ml @@ -0,0 +1,6 @@ +type ('a, 'b) t = Monoid.t + +let id = Monoid.empty +let compose ~first ~second = Monoid.append first second + +let as_unit t = t diff --git a/testsuite/tests/templates/basic/category_of_monoid.mli b/testsuite/tests/templates/basic/category_of_monoid.mli new file mode 100644 index 00000000000..bc181773279 --- /dev/null +++ b/testsuite/tests/templates/basic/category_of_monoid.mli @@ -0,0 +1,8 @@ +type ('a, 'b) t = Monoid.t + +val id : ('a, 'a) t +val compose : first:('a, 'b) t -> second:('b, 'c) t -> ('a, 'c) t + +(* Demonstrate that we can have extra functions beyond what's required by the + .mli for the parameter type *) +val as_unit : (_, _) t -> (unit, unit) t diff --git a/testsuite/tests/templates/basic/category_utils.ml b/testsuite/tests/templates/basic/category_utils.ml new file mode 100644 index 00000000000..0dce3abca5f --- /dev/null +++ b/testsuite/tests/templates/basic/category_utils.ml @@ -0,0 +1,5 @@ +let rec concat : type a b. (a, b) Chain.t -> (a, b) Category.t = + fun chain -> + match chain with + | [] -> Category.id + | a_to_b :: b_to_c -> Category.compose ~first:a_to_b ~second:(concat b_to_c) diff --git a/testsuite/tests/templates/basic/category_utils.mli b/testsuite/tests/templates/basic/category_utils.mli new file mode 100644 index 00000000000..9084e984301 --- /dev/null +++ b/testsuite/tests/templates/basic/category_utils.mli @@ -0,0 +1 @@ +val concat : ('a, 'b) Chain.t -> ('a, 'b) Category.t diff --git a/testsuite/tests/templates/basic/chain.ml b/testsuite/tests/templates/basic/chain.ml new file mode 100644 index 00000000000..b964b3e2e2b --- /dev/null +++ b/testsuite/tests/templates/basic/chain.ml @@ -0,0 +1,3 @@ +type (_, _) t = + | [] : ('a, 'a) t + | (::) : ('a, 'b) Category.t * ('b, 'c) t -> ('a, 'c) t diff --git a/testsuite/tests/templates/basic/chain.mli b/testsuite/tests/templates/basic/chain.mli new file mode 100644 index 00000000000..b964b3e2e2b --- /dev/null +++ b/testsuite/tests/templates/basic/chain.mli @@ -0,0 +1,3 @@ +type (_, _) t = + | [] : ('a, 'a) t + | (::) : ('a, 'b) Category.t * ('b, 'c) t -> ('a, 'c) t diff --git a/testsuite/tests/templates/basic/import.ml b/testsuite/tests/templates/basic/import.ml new file mode 100644 index 00000000000..2c91384df43 --- /dev/null +++ b/testsuite/tests/templates/basic/import.ml @@ -0,0 +1,7 @@ +module Chain_of_semigroup = + Chain(Category)(Category_of_monoid(Monoid)(Monoid_of_semigroup)) + [@jane.non_erasable.instances] + +module Chain_of_lists = + Chain(Category)(Category_of_monoid(Monoid)(List_monoid)) + [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/import_multi_arg.ml b/testsuite/tests/templates/basic/import_multi_arg.ml new file mode 100644 index 00000000000..2a53d8489a4 --- /dev/null +++ b/testsuite/tests/templates/basic/import_multi_arg.ml @@ -0,0 +1,15 @@ +module Category_of_semigroup_and_lists = + Product_category + (Category)(Category_of_monoid(Monoid)(Monoid_of_semigroup)) + (Category_b)(Category_b_of_category + (Category)(Category_of_monoid(Monoid)(List_monoid))) + [@jane.non_erasable.instances] + +module Chain_of_semigroup_and_lists = + Chain + (Category) + (Product_category + (Category)(Category_of_monoid(Monoid)(Monoid_of_semigroup)) + (Category_b)(Category_b_of_category + (Category)(Category_of_monoid(Monoid)(List_monoid)))) + [@jane.non_erasable.instances] diff --git a/testsuite/tests/templates/basic/list_element.mli b/testsuite/tests/templates/basic/list_element.mli new file mode 100644 index 00000000000..63c57c4e0cf --- /dev/null +++ b/testsuite/tests/templates/basic/list_element.mli @@ -0,0 +1 @@ +type t diff --git a/testsuite/tests/templates/basic/list_monoid.ml b/testsuite/tests/templates/basic/list_monoid.ml new file mode 100644 index 00000000000..8f4b7e483f9 --- /dev/null +++ b/testsuite/tests/templates/basic/list_monoid.ml @@ -0,0 +1,4 @@ +type t = List_element.t list + +let empty = [] +let append = List.append diff --git a/testsuite/tests/templates/basic/list_monoid.mli b/testsuite/tests/templates/basic/list_monoid.mli new file mode 100644 index 00000000000..9de59ce07f7 --- /dev/null +++ b/testsuite/tests/templates/basic/list_monoid.mli @@ -0,0 +1,4 @@ +type t = List_element.t list + +val empty : t +val append : t -> t -> t diff --git a/testsuite/tests/templates/basic/main.ml b/testsuite/tests/templates/basic/main.ml new file mode 100644 index 00000000000..c21ae6632de --- /dev/null +++ b/testsuite/tests/templates/basic/main.ml @@ -0,0 +1,27 @@ +module Monoid_utils_of_semigroup = + Monoid_utils(Monoid)(Monoid_of_semigroup) [@jane.non_erasable.instances] + +module Category_utils_of_semigroup = + Category_utils(Category)(Category_of_monoid(Monoid)(Monoid_of_semigroup)) + [@jane.non_erasable.instances] + +module Category_utils_of_list = + Category_utils(Category)(Category_of_monoid(Monoid)(List_monoid)) + [@jane.non_erasable.instances] + +module Category_of_list_monoid = + Category_of_monoid(Monoid)(List_monoid) + [@jane.non_erasable.instances] + +let concat_semi : Monoid_utils_of_semigroup.ts -> Monoid_of_semigroup.t = + Monoid_utils_of_semigroup.concat + +let concat_chain_semi = Category_utils_of_semigroup.concat + +let append3_semi a b c = Category_utils_of_semigroup.concat [ a; b; c ] + +let concat_lists = List.concat + +let concat_chain_lists = Category_utils_of_list.concat + +let append3_lists a b c = concat_chain_lists [ a; b; c ] diff --git a/testsuite/tests/templates/basic/main.mli b/testsuite/tests/templates/basic/main.mli new file mode 100644 index 00000000000..f74eb55f3d1 --- /dev/null +++ b/testsuite/tests/templates/basic/main.mli @@ -0,0 +1,19 @@ +open Import + +val append3_semi + : Semigroup.t option + -> Semigroup.t option + -> Semigroup.t option + -> Semigroup.t option + +val concat_semi : Semigroup.t option list -> Monoid_of_semigroup.t + +val concat_chain_semi + : (unit, unit) Chain_of_semigroup.t -> Monoid_of_semigroup.t + +val append3_lists + : List_monoid.t -> List_monoid.t -> List_monoid.t -> List_monoid.t + +val concat_lists : List_monoid.t list -> List_element.t list + +val concat_chain_lists : (_, _) Chain_of_lists.t -> List_element.t list diff --git a/testsuite/tests/templates/basic/main.reference b/testsuite/tests/templates/basic/main.reference new file mode 100644 index 00000000000..37e8c42317c --- /dev/null +++ b/testsuite/tests/templates/basic/main.reference @@ -0,0 +1,24 @@ +module Monoid_utils_of_semigroup = Monoid_utils[Monoid:Monoid_of_semigroup] +module Category_utils_of_semigroup = + Category_utils[Category:Category_of_monoid[Monoid:Monoid_of_semigroup]] +module Category_utils_of_list = + Category_utils[Category:Category_of_monoid[Monoid:List_monoid]] +module Category_of_list_monoid = Category_of_monoid[Monoid:List_monoid] +val concat_semi : Monoid_utils_of_semigroup.ts -> Monoid_of_semigroup.t +val concat_chain_semi : + ('a, 'b) Chain[Category:Category_of_monoid[Monoid:Monoid_of_semigroup]].t -> + ('a, 'b) Category_of_monoid[Monoid:Monoid_of_semigroup].t +val append3_semi : + ('a, 'b) Category_of_monoid[Monoid:Monoid_of_semigroup].t -> + ('b, 'c) Category_of_monoid[Monoid:Monoid_of_semigroup].t -> + ('c, 'd) Category_of_monoid[Monoid:Monoid_of_semigroup].t -> + ('a, 'd) Category_of_monoid[Monoid:Monoid_of_semigroup].t +val concat_lists : 'a list list -> 'a list +val concat_chain_lists : + ('a, 'b) Chain[Category:Category_of_monoid[Monoid:List_monoid]].t -> + ('a, 'b) Category_of_monoid[Monoid:List_monoid].t +val append3_lists : + ('a, 'b) Category_of_monoid[Monoid:List_monoid].t -> + ('b, 'c) Category_of_monoid[Monoid:List_monoid].t -> + ('c, 'd) Category_of_monoid[Monoid:List_monoid].t -> + ('a, 'd) Category_of_monoid[Monoid:List_monoid].t diff --git a/testsuite/tests/templates/basic/main_multi_arg.ml b/testsuite/tests/templates/basic/main_multi_arg.ml new file mode 100644 index 00000000000..f0920c22893 --- /dev/null +++ b/testsuite/tests/templates/basic/main_multi_arg.ml @@ -0,0 +1,14 @@ +open Import_multi_arg + +module Category_utils_of_semigroup_and_lists = + Category_utils + (Category) + (Product_category + (Category)(Category_of_monoid(Monoid)(Monoid_of_semigroup)) + (Category_b)(Category_b_of_category + (Category)(Category_of_monoid(Monoid)(List_monoid)))) + [@jane.non_erasable.instances] + +let concat_chain_semi_and_lists semi_and_lists = + Category_utils_of_semigroup_and_lists.concat semi_and_lists + |> Category_of_semigroup_and_lists.to_pair diff --git a/testsuite/tests/templates/basic/main_multi_arg.mli b/testsuite/tests/templates/basic/main_multi_arg.mli new file mode 100644 index 00000000000..265e604dc85 --- /dev/null +++ b/testsuite/tests/templates/basic/main_multi_arg.mli @@ -0,0 +1,5 @@ +open Import_multi_arg + +val concat_chain_semi_and_lists + : (_ * _, _ * _) Chain_of_semigroup_and_lists.t + -> Semigroup.t option * List_element.t list diff --git a/testsuite/tests/templates/basic/main_multi_arg.reference b/testsuite/tests/templates/basic/main_multi_arg.reference new file mode 100644 index 00000000000..49992bae475 --- /dev/null +++ b/testsuite/tests/templates/basic/main_multi_arg.reference @@ -0,0 +1,8 @@ +module Category_utils_of_semigroup_and_lists = + Category_utils[Category:Product_category[Category:Category_of_monoid[Monoid:Monoid_of_semigroup]][Category_b:Category_b_of_category[Category:Category_of_monoid[Monoid:List_monoid]]]] +val concat_chain_semi_and_lists : + ('a * 'b, 'c * 'd) + Chain[Category:Product_category[Category:Category_of_monoid[Monoid:Monoid_of_semigroup]][Category_b:Category_b_of_category[Category:Category_of_monoid[Monoid:List_monoid]]]].t -> + ('a, 'c) Category_of_monoid[Monoid:Monoid_of_semigroup].t * + ('b, 'd) + Category_b_of_category[Category:Category_of_monoid[Monoid:List_monoid]].t diff --git a/testsuite/tests/templates/basic/monoid_of_semigroup.ml b/testsuite/tests/templates/basic/monoid_of_semigroup.ml new file mode 100644 index 00000000000..cbf72c05103 --- /dev/null +++ b/testsuite/tests/templates/basic/monoid_of_semigroup.ml @@ -0,0 +1,9 @@ +type t = Semigroup.t option + +let empty = None +let append t1 t2 = + match t1, t2 with + | None, None -> None + | (Some _ as t), None + | None, (Some _ as t) -> t + | Some t1, Some t2 -> Some (Semigroup.op t1 t2) diff --git a/testsuite/tests/templates/basic/monoid_of_semigroup.mli b/testsuite/tests/templates/basic/monoid_of_semigroup.mli new file mode 100644 index 00000000000..e1ec0ff54c2 --- /dev/null +++ b/testsuite/tests/templates/basic/monoid_of_semigroup.mli @@ -0,0 +1,4 @@ +type t = Semigroup.t option + +val empty : t +val append : t -> t -> t diff --git a/testsuite/tests/templates/basic/product_category.ml b/testsuite/tests/templates/basic/product_category.ml new file mode 100644 index 00000000000..23e3687c353 --- /dev/null +++ b/testsuite/tests/templates/basic/product_category.ml @@ -0,0 +1,21 @@ +type (_, _) t = + | Pair + : ('a1, 'a2) Category.t * ('b1, 'b2) Category_b.t + -> ('a1 * 'b1, 'a2 * 'b2) t + | Id : ('a, 'a) t + +let id = Id +let compose (type a b c) ~(first : (a, b) t) ~(second : (b, c) t) : (a, c) t = + match first, second with + | Id, _ -> second + | _, Id -> first + | Pair (first_a, first_b), Pair (second_a, second_b) -> + Pair + ( Category.compose ~first:first_a ~second:second_a, + Category_b.compose ~first:first_b ~second:second_b ) + +let to_pair (type a1 a2 b1 b2) (t : (a1 * b1, a2 * b2) t) + : (a1, a2) Category.t * (b1, b2) Category_b.t = + match t with + | Id -> Category.id, Category_b.id + | Pair (a, b) -> a, b diff --git a/testsuite/tests/templates/basic/product_category.mli b/testsuite/tests/templates/basic/product_category.mli new file mode 100644 index 00000000000..0c0f378e28c --- /dev/null +++ b/testsuite/tests/templates/basic/product_category.mli @@ -0,0 +1,11 @@ +type (_, _) t = + | Pair + : ('a1, 'a2) Category.t * ('b1, 'b2) Category_b.t + -> ('a1 * 'b1, 'a2 * 'b2) t + | Id : ('a, 'a) t + +include Category_intf.S with type ('a, 'b) t := ('a, 'b) t + +val to_pair + : ('a1 * 'b1, 'a2 * 'b2) t + -> ('a1, 'a2) Category.t * ('b1, 'b2) Category_b.t diff --git a/testsuite/tests/templates/basic/ref_indirect.cmo.ocamlobjinfo.reference b/testsuite/tests/templates/basic/ref_indirect.cmo.ocamlobjinfo.reference index 5e4fdd34e2c..30932a0eb83 100644 --- a/testsuite/tests/templates/basic/ref_indirect.cmo.ocamlobjinfo.reference +++ b/testsuite/tests/templates/basic/ref_indirect.cmo.ocamlobjinfo.reference @@ -20,3 +20,5 @@ Interfaces imported: 00000000000000000000000000000000 Monoid_utils 00000000000000000000000000000000 Monoid 00000000000000000000000000000000 CamlinternalFormatBasics +Globals in scope: + Monoid_utils{Monoid} diff --git a/testsuite/tests/templates/basic/ref_indirect.cmx.ocamlobjinfo.reference b/testsuite/tests/templates/basic/ref_indirect.cmx.ocamlobjinfo.reference index 986e58b4771..b3ada40b49d 100644 --- a/testsuite/tests/templates/basic/ref_indirect.cmx.ocamlobjinfo.reference +++ b/testsuite/tests/templates/basic/ref_indirect.cmx.ocamlobjinfo.reference @@ -15,8 +15,6 @@ Currying functions: Apply functions: Send functions: Force link: no -Function summaries for static checks: - camlRef_indirect__entry = 0x15 File ref_indirect.cmi Unit name: Ref_indirect Is parameter: no @@ -28,3 +26,5 @@ Interfaces imported: 00000000000000000000000000000000 Monoid_utils 00000000000000000000000000000000 Monoid 00000000000000000000000000000000 CamlinternalFormatBasics +Globals in scope: + Monoid_utils{Monoid} diff --git a/testsuite/tests/templates/basic/ref_indirect.ml b/testsuite/tests/templates/basic/ref_indirect.ml index e80d19e6d02..f4888c4894a 100644 --- a/testsuite/tests/templates/basic/ref_indirect.ml +++ b/testsuite/tests/templates/basic/ref_indirect.ml @@ -1 +1,2 @@ +[@@@ocaml.flambda_o3] (* normalise objinfo output *) let concat = Monoid_utils.concat diff --git a/testsuite/tests/templates/basic/semigroup.mli b/testsuite/tests/templates/basic/semigroup.mli new file mode 100644 index 00000000000..c2d791042f4 --- /dev/null +++ b/testsuite/tests/templates/basic/semigroup.mli @@ -0,0 +1,3 @@ +type t + +val op : t -> t -> t diff --git a/testsuite/tests/templates/basic/test.ml b/testsuite/tests/templates/basic/test.ml index 00df07b5145..d76f5a6ad1d 100644 --- a/testsuite/tests/templates/basic/test.ml +++ b/testsuite/tests/templates/basic/test.ml @@ -2,15 +2,37 @@ readonly_files = "\ bad_arg_impl.ml bad_arg_impl.reference \ bad_arg_intf.mli bad_arg_intf.reference \ + bad_instance_arg_name_not_found.ml bad_instance_arg_name_not_found.reference \ + bad_instance_arg_value_not_arg.ml bad_instance_arg_value_not_arg.reference \ + bad_instance_arg_value_not_found.ml bad_instance_arg_value_not_found.reference \ + bad_instance_arg_value_wrong_type.ml bad_instance_arg_value_wrong_type.reference \ bad_instance_repeated_arg_name.ml bad_instance_repeated_arg_name.reference \ + bad_instance_wrong_mode.ml bad_instance_wrong_mode.reference \ bad_param_param.mli bad_param_param.reference \ bad_ref_direct.ml bad_ref_direct.reference \ + bad_ref_direct_imported.ml bad_ref_direct_imported.reference \ bad_ref_indirect.reference \ + category.ml category.mli \ + category_b.mli \ + category_b_of_category.ml category_b_of_category.mli \ + category_intf.ml \ + category_of_monoid.ml category_of_monoid.mli \ + category_utils.ml category_utils.mli \ + chain.ml chain.mli \ + import.ml \ + import_multi_arg.ml \ + list_element.mli \ + list_monoid.ml list_monoid.mli \ + main.ml main.mli main.reference \ + main_multi_arg.ml main_multi_arg.mli main_multi_arg.reference \ monoid.mli \ + monoid_of_semigroup.ml monoid_of_semigroup.mli \ monoid_utils.ml monoid_utils.mli monoid_utils_as_program.reference \ + product_category.ml product_category.mli \ ref_indirect.ml \ ref_indirect.cmo.ocamlobjinfo.reference \ ref_indirect.cmx.ocamlobjinfo.reference \ + semigroup.mli \ string_monoid.ml string_monoid.mli \ test_direct_access.ml test_direct_access.reference \ "; @@ -87,6 +109,33 @@ reference = "test_direct_access.reference"; check-program-output; }{ + flags = "-as-parameter"; + module = "semigroup.mli"; + ocamlc.byte; + + flags = ""; + module = "category_intf.ml"; + ocamlc.byte; + + flags = "-as-parameter"; + module = "category.mli"; + ocamlc.byte; + + flags = "-parameter Semigroup -as-argument-for Monoid"; + module = "monoid_of_semigroup.mli"; + ocamlc.byte; + + module = "monoid_of_semigroup.ml"; + ocamlc.byte; + + flags = "-as-parameter"; + module = "list_element.mli"; + ocamlc.byte; + + flags = "-parameter List_element -as-argument-for Monoid"; + module = "list_monoid.mli list_monoid.ml"; + ocamlc.byte; + flags = "-parameter Monoid"; module = "monoid_utils.mli monoid_utils.ml"; ocamlc.byte; @@ -108,9 +157,6 @@ module = "ref_indirect.ml"; ocamlc.byte; - (* [-no-code] and [-no-approx] are currently unimplemented (see PR 2737), which - sadly does make the reference file here a mite bloated and sensitive to - random changes in flambda2. *) program = "-no-code -no-approx ref_indirect.cmo ref_indirect.cmi"; output = "ref_indirect.cmo.ocamlobjinfo.output"; ocamlobjinfo; @@ -138,6 +184,132 @@ compiler_reference = "bad_instance_repeated_arg_name.reference"; check-ocamlc.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_name_not_found.ml"; + compiler_output = "bad_instance_arg_name_not_found.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_instance_arg_name_not_found.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_value_not_arg.ml"; + compiler_output = "bad_instance_arg_value_not_arg.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_instance_arg_value_not_arg.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_value_not_found.ml"; + compiler_output = "bad_instance_arg_value_not_found.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_instance_arg_value_not_found.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_wrong_mode.ml"; + compiler_output = "bad_instance_wrong_mode.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_instance_wrong_mode.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter Semigroup"; + module = "bad_ref_direct_imported.ml"; + compiler_output = "bad_ref_direct_imported.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_ref_direct_imported.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter Category"; + module = "chain.mli chain.ml"; + ocamlc.byte; + + flags = "-parameter Category"; + module = "category_utils.mli category_utils.ml"; + ocamlc.byte; + + flags = "-parameter Monoid -as-argument-for Category"; + module = "category_of_monoid.mli category_of_monoid.ml"; + ocamlc.byte; + { + flags = "-parameter List_element"; + module = "bad_instance_arg_value_wrong_type.ml"; + compiler_output = "bad_instance_arg_value_wrong_type.output"; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + + compiler_reference = "bad_instance_arg_value_wrong_type.reference"; + check-ocamlc.byte-output; + }{ + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "import.ml"; + ocamlc.byte; + + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "main.mli"; + ocamlc.byte; + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + module = "main.ml"; + ocamlc.byte; + + compiler_reference = "main.reference"; + check-ocamlc.byte-output; + }{ + module = "main.ml"; + ocamlc.byte; + + program = "main.cmo main.cmi"; + ocamlobjinfo; + + check-program-output; + } + }{ + flags = "-as-parameter"; + module = "category_b.mli"; + ocamlc.byte; + + flags = "-parameter Category -as-argument-for Category_b"; + module = "category_b_of_category.mli category_b_of_category.ml"; + ocamlc.byte; + + flags = "-parameter Category -parameter Category_b -as-argument-for Category"; + module = "product_category.mli product_category.ml"; + ocamlc.byte; + + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "import_multi_arg.ml"; + ocamlc.byte; + + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "main_multi_arg.mli"; + ocamlc.byte; + + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + module = "main_multi_arg.ml"; + compiler_output = "main_multi_arg.output"; + ocamlc.byte; + + compiler_reference = "main_multi_arg.reference"; + check-ocamlc.byte-output; + }{ + module = "main_multi_arg.ml"; + ocamlc.byte; + } + } + } } } }{ @@ -212,6 +384,33 @@ reference = "test_direct_access.reference"; check-program-output; }{ + flags = "-as-parameter"; + module = "semigroup.mli"; + ocamlopt.byte; + + flags = ""; + module = "category_intf.ml"; + ocamlc.byte; + + flags = "-as-parameter"; + module = "category.mli"; + ocamlopt.byte; + + flags = "-parameter Semigroup -as-argument-for Monoid"; + module = "monoid_of_semigroup.mli"; + ocamlopt.byte; + + module = "monoid_of_semigroup.ml"; + ocamlopt.byte; + + flags = "-as-parameter"; + module = "list_element.mli"; + ocamlopt.byte; + + flags = "-parameter List_element -as-argument-for Monoid"; + module = "list_monoid.mli list_monoid.ml"; + ocamlopt.byte; + flags = "-parameter Monoid"; module = "monoid_utils.mli monoid_utils.ml"; ocamlopt.byte; @@ -233,16 +432,10 @@ module = "ref_indirect.ml"; ocamlopt.byte; - (* [-no-code] and [-no-approx] are currently unimplemented (see PR 2737), which - sadly does make the reference file here a mite bloated and sensitive to - random changes in flambda2. *) program = "-no-code -no-approx ref_indirect.cmx ref_indirect.cmi"; output = "ref_indirect.cmx.ocamlobjinfo.output"; ocamlobjinfo; - reason = "sensitive to runtime4 vs. runtime5; will be fixed by PR 2737"; - skip; - reference = "ref_indirect.cmx.ocamlobjinfo.reference"; check-program-output; }{ @@ -266,6 +459,128 @@ compiler_reference = "bad_instance_repeated_arg_name.reference"; check-ocamlopt.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_name_not_found.ml"; + compiler_output = "bad_instance_arg_name_not_found.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_instance_arg_name_not_found.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_value_not_arg.ml"; + compiler_output = "bad_instance_arg_value_not_arg.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_instance_arg_value_not_arg.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_arg_value_not_found.ml"; + compiler_output = "bad_instance_arg_value_not_found.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_instance_arg_value_not_found.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter List_element"; + module = "bad_instance_wrong_mode.ml"; + compiler_output = "bad_instance_wrong_mode.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_instance_wrong_mode.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter Semigroup"; + module = "bad_ref_direct_imported.ml"; + compiler_output = "bad_ref_direct_imported.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_ref_direct_imported.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter Category"; + module = "chain.mli chain.ml"; + ocamlopt.byte; + + flags = "-parameter Category"; + module = "category_utils.mli category_utils.ml"; + ocamlopt.byte; + + flags = "-parameter Monoid -as-argument-for Category"; + module = "category_of_monoid.mli category_of_monoid.ml"; + ocamlopt.byte; + { + flags = "-parameter List_element"; + module = "bad_instance_arg_value_wrong_type.ml"; + compiler_output = "bad_instance_arg_value_wrong_type.output"; + ocamlopt_byte_exit_status = "2"; + ocamlopt.byte; + + compiler_reference = "bad_instance_arg_value_wrong_type.reference"; + check-ocamlopt.byte-output; + }{ + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "import.ml"; + ocamlopt.byte; + + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "main.mli"; + ocamlopt.byte; + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + module = "main.ml"; + compiler_output = "main.output"; + ocamlopt.byte; + + compiler_reference = "main.reference"; + check-ocamlopt.byte-output; + }{ + module = "main.ml"; + ocamlopt.byte; + } + }{ + flags = "-as-parameter"; + module = "category_b.mli"; + ocamlopt.byte; + + flags = "-parameter Category -as-argument-for Category_b"; + module = "category_b_of_category.mli category_b_of_category.ml"; + ocamlopt.byte; + + flags = "-parameter Category -parameter Category_b -as-argument-for Category"; + module = "product_category.mli product_category.ml"; + ocamlopt.byte; + + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "import_multi_arg.ml"; + ocamlopt.byte; + + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + module = "main_multi_arg.mli"; + ocamlopt.byte; + + { + flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + module = "main_multi_arg.ml"; + compiler_output = "main_multi_arg.output"; + ocamlopt.byte; + + compiler_reference = "main_multi_arg.reference"; + check-ocamlopt.byte-output; + }{ + module = "main_multi_arg.ml"; + ocamlopt.byte; + } + } + } } } } diff --git a/testsuite/tests/templates/basic/test.reference b/testsuite/tests/templates/basic/test.reference new file mode 100644 index 00000000000..3f29450a6e2 --- /dev/null +++ b/testsuite/tests/templates/basic/test.reference @@ -0,0 +1,53 @@ +File main.cmo +Unit name: Main +Interfaces imported: + 00000000000000000000000000000000 Stdlib__Seq + 00000000000000000000000000000000 Stdlib__List + 00000000000000000000000000000000 Stdlib__Either + 00000000000000000000000000000000 Stdlib + 00000000000000000000000000000000 Semigroup + 00000000000000000000000000000000 Monoid_utils + 00000000000000000000000000000000 Monoid_of_semigroup + 00000000000000000000000000000000 Monoid + 00000000000000000000000000000000 Main + 00000000000000000000000000000000 List_monoid + 00000000000000000000000000000000 List_element + 00000000000000000000000000000000 Import + 00000000000000000000000000000000 Chain + 00000000000000000000000000000000 Category_utils + 00000000000000000000000000000000 Category_of_monoid + 00000000000000000000000000000000 Category_intf + 00000000000000000000000000000000 Category + 00000000000000000000000000000000 CamlinternalFormatBasics +Required globals: + Stdlib__List +Uses unsafe features: no +Force link: no +File main.cmi +Unit name: Main +Is parameter: no +Parameters: + List_element + Semigroup +Interfaces imported: + 00000000000000000000000000000000 Main + 00000000000000000000000000000000 Stdlib + 00000000000000000000000000000000 Semigroup + 00000000000000000000000000000000 Monoid_of_semigroup + 00000000000000000000000000000000 Monoid + 00000000000000000000000000000000 List_monoid + 00000000000000000000000000000000 List_element + 00000000000000000000000000000000 Import + 00000000000000000000000000000000 Chain + 00000000000000000000000000000000 Category_of_monoid + 00000000000000000000000000000000 Category_intf + 00000000000000000000000000000000 Category + 00000000000000000000000000000000 CamlinternalFormatBasics +Globals in scope: + Chain[Category:Category_of_monoid[Monoid:Monoid_of_semigroup{Semigroup}]] + Monoid_of_semigroup{Semigroup} + Chain[Category:Category_of_monoid[Monoid:List_monoid{List_element}]] + Import{List_element}{Semigroup} + Category_of_monoid[Monoid:List_monoid{List_element}] + List_monoid{List_element} + Category_of_monoid[Monoid:Monoid_of_semigroup{Semigroup}] diff --git a/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/testsuite/tests/tool-toplevel/pr6468.compilers.reference index 25490f7a18f..9b957b47363 100644 --- a/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -8,15 +8,15 @@ Warning 21 [nonreturning-statement]: this statement never returns (or has an uns val g : unit -> int = Exception: Not_found. Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1287, characters 8-48 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1287, characters 8-48 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1287, characters 8-48 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 909dbb51b0d..58f6f616c42 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -65,9 +65,12 @@ let print_intf_import import = print_name_crc name crco let print_impl_import import = - let unit = Import_info.cu import in + let name = Import_info.name import in let crco = Import_info.crc import in - print_name_crc (Compilation_unit.name unit) crco + print_name_crc name crco + +let print_global_name_binding global = + printf "\t%a\n" Global_module.output global let print_line name = printf "\t%s\n" name @@ -76,8 +79,7 @@ let print_global_line glob = printf "\t%a\n" Global_module.Name.output glob let print_global_as_name_line glob = - (* Type will change soon for parameterised libraries *) - printf "\t%a\n" Global_module.Name.output glob + printf "\t%a\n" Global_module.Name.output (Global_module.to_name glob) let print_name_line cu = (* Drop the pack prefix for backward compatibility, but keep the instance @@ -121,7 +123,7 @@ let print_cma_infos (lib : Cmo_format.library) = printf "\n"; List.iter print_cmo_infos lib.lib_units -let print_cmi_infos name crcs kind params = +let print_cmi_infos name crcs kind params global_name_bindings = if not !quiet then begin let open Cmi_format in printf "Unit name: %a\n" Compilation_unit.Name.output name; @@ -142,7 +144,9 @@ let print_cmi_infos name crcs kind params = () end; printf "Interfaces imported:\n"; - Array.iter print_intf_import crcs + Array.iter print_intf_import crcs; + printf "Globals in scope:\n"; + Array.iter print_global_name_binding global_name_bindings end let print_cmt_infos cmt = @@ -424,6 +428,7 @@ let dump_obj_by_kind filename ic obj_kind = | Some cmi -> print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs cmi.Cmi_format.cmi_kind cmi.Cmi_format.cmi_params + cmi.Cmi_format.cmi_globals end; begin match cmt with | None -> () diff --git a/typing/env.ml b/typing/env.ml index 6bbc3d0511e..98a3e6a2e8a 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -492,6 +492,18 @@ module IdTbl = let find_name_and_locks wrap ~mark name tbl = find_name_and_locks wrap ~mark name tbl [] + (** Find all the locks in the context. Equivalent to [find_name_and_locks] + on a missing name. *) + let rec get_all_locks tbl macc = + match tbl.layer with + | Open {next; _} + | Map {next; _} -> get_all_locks next macc + | Lock {lock; next} -> get_all_locks next (lock :: macc) + | Nothing -> macc + + let get_all_locks tbl = + get_all_locks tbl [] + (** Find item by name whose accesses are not affected by locks, and thus shouldn't encounter any locks. *) let find_name wrap ~mark name tbl = @@ -774,6 +786,7 @@ type lookup_error = Mode.Value.Comonadic.error * closure_context | Local_value_used_in_exclave of lock_item * Longident.t | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t + | Error_from_persistent_env of Persistent_env.error type error = | Missing_module of Location.t * Path.t * Path.t @@ -2869,6 +2882,25 @@ type _ load = | Load : module_data load | Don't_load : unit load +let lookup_global_name_module_no_locks + (type a) (load : a load) ~errors ~use ~loc name env = + let path = Pident(Ident.create_global name) in + match load with + | Don't_load -> + check_pers_mod ~allow_hidden:false ~loc name; + path, (() : a) + | Load -> begin + match find_pers_mod ~allow_hidden:false name with + | mda -> + use_module ~use ~loc path mda; + path, (mda : a) + | exception Not_found -> + let s = Global_module.Name.to_string name in + may_lookup_error errors loc env (Unbound_module (Lident s)) + | exception Persistent_env.Error err -> + may_lookup_error errors loc env (Error_from_persistent_env err) + end + let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = let path, locks, data = match find_name_module ~mark:use s env.modules with @@ -2886,20 +2918,13 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = | Mod_unbound reason -> report_module_unbound ~errors ~loc env reason | Mod_persistent -> begin - (* Currently there are never instance arguments *) + (* This is only used when processing [Longident.t]s, which never have + instance arguments *) let name = Global_module.Name.create_no_args s in - match load with - | Don't_load -> - check_pers_mod ~allow_hidden:false ~loc name; - path, locks, (() : a) - | Load -> begin - match find_pers_mod ~allow_hidden:false name with - | mda -> - use_module ~use ~loc path mda; - path, locks, (mda : a) - | exception Not_found -> - may_lookup_error errors loc env (Unbound_module (Lident s)) - end + let path, a = + lookup_global_name_module_no_locks load ~errors ~use ~loc name env + in + path, locks, a end let escape_mode ~errors ~env ~loc ~item ~lid vmode escaping_context = @@ -3436,6 +3461,12 @@ let open_signature (* General forms of the lookup functions *) +let walk_locks_for_module_lookup ~errors ~lock ~loc ~env ~lid locks = + if lock then + walk_locks ~errors ~loc ~env ~item:Module ~lid mda_mode None locks + else + mode_default mda_mode + let lookup_module_path ~errors ~use ~lock ~loc ~load lid env : Path.t * _ = let path, locks = match lid with @@ -3457,11 +3488,32 @@ let lookup_module_path ~errors ~use ~lock ~loc ~load lid env : Path.t * _ = let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in Papply(path_f, path_arg), [] in - let vmode = - if lock then - walk_locks ~errors ~loc ~env ~item:Module ~lid mda_mode None locks + let vmode = walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks in + path, vmode + +let lookup_module_instance_path ~errors ~use ~lock ~loc ~load name env = + (* The locks are whatever locks we would find if we went through + [lookup_module_path] on a module not found in the environment *) + let locks = IdTbl.get_all_locks env.modules in + let path = + if !Clflags.transparent_modules && not load then + let path, () = + lookup_global_name_module_no_locks Don't_load ~errors ~use ~loc name env + in + path else - mode_default mda_mode + let path, (_ : module_data) = + lookup_global_name_module_no_locks Load ~errors ~use ~loc name env + in + path + in + let vmode = + let lid : Longident.t = + (* This is only used for error reporting. Probably in the long term we + want [Longident.t] to include instance names *) + Lident (name |> Global_module.Name.to_string) + in + walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks in path, vmode @@ -3651,6 +3703,12 @@ let lookup_module_path ?(use=true) ?(lock=use) ~loc ~load lid env = in path, vmode.mode +let lookup_module_instance_path ?(use=true) ?(lock=use) ~loc ~load lid env = + let path, vmode = + lookup_module_instance_path ~errors:true ~use ~lock ~loc ~load lid env + in + path, vmode.mode + let lookup_module ?(use=true) ?(lock=use) ~loc lid env = let path, desc, vmode = lookup_module ~errors:true ~use ~lock ~loc lid env in path, desc, vmode.mode @@ -4256,6 +4314,8 @@ let report_lookup_error _loc env ppf = function (Style.as_inline_code !print_longident) lid (Jkind.Violation.report_with_offender ~offender:(fun ppf -> !print_type_expr ppf typ)) err + | Error_from_persistent_env err -> + Persistent_env.report_error ppf err let report_error ppf = function | Missing_module(_, path1, path2) -> diff --git a/typing/env.mli b/typing/env.mli index 2fd81adbd26..54a69062b6b 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -47,7 +47,7 @@ type summary = | Env_module_unbound of summary * string * module_unbound_reason (* CR zqian: track [add_lock] as well *) -type address = +type address = Persistent_env.address = | Aunit of Compilation_unit.t | Alocal of Ident.t | Adot of address * int @@ -240,6 +240,7 @@ type lookup_error = | Value_used_in_closure of lock_item * Longident.t * Mode.Value.Comonadic.error * closure_context | Local_value_used_in_exclave of lock_item * Longident.t | Non_value_used_in_object of Longident.t * type_expr * Jkind.Violation.t + | Error_from_persistent_env of Persistent_env.error val lookup_error: Location.t -> t -> lookup_error -> 'a @@ -285,6 +286,9 @@ val lookup_module_path: Path.t * Mode.Value.l val lookup_modtype_path: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t +val lookup_module_instance_path: + ?use:bool -> ?lock:bool -> loc:Location.t -> load:bool -> + Global_module.Name.t -> t -> Path.t * Mode.Value.l val lookup_constructor: ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> diff --git a/typing/persistent_env.ml b/typing/persistent_env.ml index 75e25f3cd35..6b0da3153ab 100644 --- a/typing/persistent_env.ml +++ b/typing/persistent_env.ml @@ -34,11 +34,39 @@ type error = | Direct_reference_from_wrong_package of CU.t * filepath * CU.Prefix.t | Illegal_import_of_parameter of Global_module.Name.t * filepath - | Not_compiled_as_parameter of Global_module.Name.t * filepath + | Not_compiled_as_parameter of Global_module.Name.t | Imported_module_has_unset_parameter of { imported : Global_module.Name.t; parameter : Global_module.Name.t; } + | Imported_module_has_no_such_parameter of + { imported : CU.Name.t; + valid_parameters : Global_module.Name.t list; + parameter : Global_module.Name.t; + value : Global_module.Name.t; + } + | Not_compiled_as_argument of + { param : Global_module.Name.t; + value : Global_module.Name.t; + filename : filepath; + } + | Argument_type_mismatch of + { value : Global_module.Name.t; + filename : filepath; + expected : Global_module.Name.t; + actual : Global_module.Name.t; + } + | Inconsistent_global_name_resolution of { + name: Global_module.Name.t; + old_global : Global_module.t; + new_global : Global_module.t; + first_mentioned_by : Global_module.Name.t; + now_mentioned_by : Global_module.Name.t; + } + | Unbound_module_as_argument_value of + { instance: Global_module.Name.t; + value: Global_module.Name.t; + } exception Error of error let error err = raise (Error err) @@ -64,13 +92,18 @@ type can_load_cmis = | Can_load_cmis | Cannot_load_cmis of Lazy_backtrack.log -(* Data relating directly to a .cmi *) +type global_name_info = { + gn_global : Global_module.t; + gn_mentioned_by : Global_module.Name.t; (* For error reporting *) +} + +(* Data relating directly to a .cmi - does not depend on arguments *) type import = { imp_is_param : bool; - imp_params : Global_module.Name.t list; + imp_params : Global_module.t list; (* CR lmaurer: Should be [Parameter_name.t list] *) imp_arg_for : Global_module.Name.t option; imp_impl : CU.t option; (* None iff import is a parameter *) - imp_sign : Subst.Lazy.signature; + imp_raw_sign : Signature_with_global_bindings.t; imp_filename : string; imp_visibility: Load_path.visibility; imp_crcs : Import_info.Intf.t array; @@ -83,6 +116,20 @@ type import_info = | Missing | Found of import +(* Data relating to a global name (possibly with arguments) but not necessarily + a value in scope. For example, if we've encountered a module only by seeing + it used as the name or value of an argument in a [Global_module.Name.t], we + won't bind it or construct a [pers_struct] for it but it will have a + [pers_name]. *) +type pers_name = { + pn_import : import; + pn_global : Global_module.t; + pn_arg_for : Global_module.Name.t option; + (* Currently always the same as [pn_import.imp_arg_for], since parameters + don't have parameters *) + pn_sign : Subst.Lazy.signature; +} + (* What a global identifier is actually bound to in Lambda code *) type binding = | Runtime_parameter of Ident.t (* Bound to a runtime parameter *) @@ -100,7 +147,9 @@ module Param_set = Global_module.Name.Set (* If you add something here, _do not forget_ to add it to [clear]! *) type 'a t = { + globals : (Global_module.Name.t, global_name_info) Hashtbl.t; imports : (CU.Name.t, import_info) Hashtbl.t; + persistent_names : (Global_module.Name.t, pers_name) Hashtbl.t; persistent_structures : (Global_module.Name.t, 'a pers_struct_info) Hashtbl.t; imported_units: CU.Name.Set.t ref; @@ -111,7 +160,9 @@ type 'a t = { } let empty () = { + globals = Hashtbl.create 17; imports = Hashtbl.create 17; + persistent_names = Hashtbl.create 17; persistent_structures = Hashtbl.create 17; imported_units = ref CU.Name.Set.empty; imported_opaque_units = ref CU.Name.Set.empty; @@ -122,7 +173,9 @@ let empty () = { let clear penv = let { + globals; imports; + persistent_names; persistent_structures; imported_units; imported_opaque_units; @@ -130,7 +183,9 @@ let clear penv = crc_units; can_load_cmis; } = penv in + Hashtbl.clear globals; Hashtbl.clear imports; + Hashtbl.clear persistent_names; Hashtbl.clear persistent_structures; imported_units := CU.Name.Set.empty; imported_opaque_units := CU.Name.Set.empty; @@ -159,6 +214,11 @@ let find_import_info_in_cache {imports; _} import = | Missing -> None | Found imp -> Some imp +let find_name_info_in_cache {persistent_names; _} name = + match Hashtbl.find persistent_names name with + | exception Not_found -> None + | pn -> Some pn + let find_info_in_cache {persistent_structures; _} name = match Hashtbl.find persistent_structures name with | exception Not_found -> None @@ -179,7 +239,7 @@ let register_parameter ({param_imports; _} as penv) modname = () | Some imp -> if not imp.imp_is_param then - raise (Error (Not_compiled_as_parameter(modname, imp.imp_filename))) + raise (Error (Not_compiled_as_parameter modname)) end; param_imports := Param_set.add modname !param_imports @@ -263,10 +323,7 @@ let acknowledge_import penv ~check modname pers_sig = let params = cmi.cmi_params in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in - let sign = - (* Freshen identifiers bound by signature *) - Subst.Lazy.signature Make_local Subst.identity cmi.cmi_sign - in + let sign = Signature_with_global_bindings.read_from_cmi cmi in if not (CU.Name.equal modname found_name) then error (Illegal_renaming(modname, found_name, filename)); List.iter @@ -303,7 +360,7 @@ let acknowledge_import penv ~check modname pers_sig = imp_params = params; imp_arg_for = arg_for; imp_impl = impl; - imp_sign = sign; + imp_raw_sign = sign; imp_filename = filename; imp_visibility = visibility; imp_crcs = crcs; @@ -344,23 +401,297 @@ let find_import ~allow_hidden penv ~check modname = add_import penv modname; acknowledge_import penv ~check modname psig +let remember_global { globals; _ } global ~mentioned_by = + if Global_module.has_arguments global then + let global_name = Global_module.to_name global in + match Hashtbl.find globals global_name with + | exception Not_found -> + Hashtbl.add globals global_name + { gn_global = global; gn_mentioned_by = mentioned_by } + | { gn_global = old_global; gn_mentioned_by = first_mentioned_by } -> + if not (Global_module.equal old_global global) then + error (Inconsistent_global_name_resolution { + name = global_name; + old_global; + new_global = global; + first_mentioned_by; + now_mentioned_by = mentioned_by; + }) + +let current_unit_is_aux name ~allow_args = + match CU.get_current () with + | None -> false + | Some current -> + match CU.to_global_name current with + | Some { head; args } -> + (args = [] || allow_args) + && CU.Name.equal name (head |> CU.Name.of_string) + | None -> false + +let current_unit_is name = + current_unit_is_aux name ~allow_args:false + +let current_unit_is_instance_of name = + current_unit_is_aux name ~allow_args:true + (* Enforce the subset rule: we can only refer to a module if that module's - parameters are also our parameters. *) -let check_for_unset_parameters penv modname import = + parameters are also our parameters. This assumes that all of the arguments in + [global] have already been checked, so we only need to check [global] + itself (in other words, we don't need to recurse). + + Formally, the subset rule for an unelaborated global (that is, a + [Global_module.Name.t]) says that [M[P_1:A_1]...[P_n:A_n]] is accessible if, + for each parameter [P] that [M] takes, either [P] is one of the parameters + [P_i], or the current compilation unit also takes [P]. + + This function takes an _elaborated_ global (that is, a [Global_module.t]), + which "bakes in" crucial information: all of the instantiated module's + parameters are accounted for, so we need only concern ourselves with the + syntax of the global and the current compilation unit's parameters. + Specifically, the subset rule for an elaborated global says that + [M[P_1:A_1]...[P_n:A_n]{Q_1:B_1}...{Q_m:B_m}] is accessible if each hidden + argument value [B_i] is a parameter of the current unit. Operationally, this + makes sense since the hidden argument [{Q:B}] means "as the argument [Q] to + [M], we're passing our own parameter [B] along." (Currently [B] is always + simply [Q] again. This is likely to change with future extensions, but the + requirement will be the same: [B] needs to be something we're taking as a + parameter.) *) +let check_for_unset_parameters penv global = List.iter - (fun param -> - if not (is_registered_parameter_import penv param) then + (fun ({ param = _; value = arg_value } : Global_module.argument) -> + let value_name = Global_module.to_name arg_value in + if not (is_registered_parameter_import penv value_name) then error (Imported_module_has_unset_parameter { - imported = modname; - parameter = param; + imported = Global_module.to_name global; + parameter = value_name; })) - import.imp_params + global.Global_module.hidden_args -let make_binding _penv modname (import : import) : binding = - match import with - | { imp_impl = Some unit; imp_params = [] } -> Constant unit - | { imp_impl = None } | { imp_params = _ :: _ } -> - Runtime_parameter (Ident.create_local_binding_for_global modname) +let rec global_of_global_name penv ~check name = + match Hashtbl.find penv.globals name with + | { gn_global; _ } -> gn_global + | exception Not_found -> + let pn = find_pers_name ~allow_hidden:true penv check name in + pn.pn_global + +and compute_global penv modname ~params check = + let arg_global_by_param_name = + List.map + (fun ({ param = name; value } : Global_module.Name.argument) -> + match global_of_global_name penv ~check value with + | value -> name, value + | exception Not_found -> + error + (Unbound_module_as_argument_value { instance = modname; value })) + modname.Global_module.Name.args + in + let subst : Global_module.subst = Global_module.Name.Map.of_list arg_global_by_param_name in + if check && modname.Global_module.Name.args <> [] then begin + (* A paragraph for the future that I don't want to lose track of: + + Produce the expected type of each argument. This takes into account + substitutions among the parameter types: if the parameters are T and + To_string[T] and the arguments are [Int] and [Int_to_string], we want to + check that [Int] has type [T] and that [Int_to_string] has type + [To_string[T\Int]]. + + For now, our parameters don't take parameters, so we can just assert that + the parameter name has no arguments and keep it as the expected type. *) + let expected_type_by_param_name = + List.map + (fun param -> + assert (not (Global_module.has_arguments param)); + Global_module.to_name param, param) + params + in + let compare_by_param (param1, _) (param2, _) = + Global_module.Name.compare param1 param2 + in + Misc.Stdlib.List.merge_iter + ~cmp:compare_by_param + expected_type_by_param_name + arg_global_by_param_name + ~left_only: + (fun _ -> + (* Parameter with no argument: fine (subset rule will be checked by + [check_for_unset_parameters] later) *) + ()) + ~right_only: + (fun (param, value) -> + (* Argument with no parameter: not fine *) + raise + (Error (Imported_module_has_no_such_parameter { + imported = CU.Name.of_head_of_global_name modname; + valid_parameters = params |> List.map Global_module.to_name; + parameter = param; + value = value |> Global_module.to_name; + }))) + ~both: + (fun (param_name, expected_type_global) (_arg_name, arg_value_global) -> + let arg_value = arg_value_global |> Global_module.to_name in + let pn = find_pers_name ~allow_hidden:true penv check arg_value in + let actual_type = + match pn.pn_arg_for with + | None -> + error (Not_compiled_as_argument + { param = param_name; value = arg_value; + filename = pn.pn_import.imp_filename }) + | Some ty -> ty + in + let actual_type_global = + global_of_global_name penv ~check actual_type + in + if not (Global_module.equal expected_type_global actual_type_global) + then begin + let expected_type = Global_module.to_name expected_type_global in + if Global_module.Name.equal expected_type actual_type then + (* This shouldn't happen, I don't think, but if it does, I'd rather + not output an "X != X" sort of error message *) + Misc.fatal_errorf + "Mismatched argument type (despite same name):@ \ + expected %a,@ got %a" + Global_module.print expected_type_global + Global_module.print actual_type_global + else + raise (Error (Argument_type_mismatch { + value = arg_value; + filename = pn.pn_import.imp_filename; + expected = expected_type; + actual = actual_type; + })) + end) + end; + (* Form the name without any arguments at all, then substitute in all the + arguments. A bit roundabout but should be sound *) + let hidden_args = + List.map + (fun param : Global_module.argument -> + { param = Global_module.to_name param; value = param }) + params + in + let global_without_args = + (* Won't raise an exception, since the hidden args are all different + (since the params are different, or else we have bigger problems) *) + Global_module.create_exn modname.Global_module.Name.head [] ~hidden_args + in + let global, _changed = Global_module.subst global_without_args subst in + global + +and acknowledge_pers_name penv check global_name import = + let params = import.imp_params in + let arg_for = import.imp_arg_for in + let sign = import.imp_raw_sign in + let global = compute_global penv global_name ~params check in + (* This checks only [global] itself without recursing into argument values. + That's fine, however, since those argument values will have come from + recursive calls to [global_of_global_name] and therefore have passed + through here already. *) + check_for_unset_parameters penv global; + let {persistent_names; _} = penv in + let sign = + let bindings = + List.map + (fun ({ param; value } : Global_module.argument) -> param, value) + global.Global_module.visible_args + in + (* Only need to substitute the visible args, since the hidden args only + reflect substitutions already made by visible args *) + Signature_with_global_bindings.subst sign bindings + in + Array.iter + (fun bound_global -> + remember_global penv bound_global ~mentioned_by:global_name) + sign.bound_globals; + let pn = { pn_import = import; + pn_global = global; + pn_arg_for = arg_for; + pn_sign = sign.sign; + } in + if check then check_consistency penv import; + Hashtbl.add persistent_names global_name pn; + remember_global penv global ~mentioned_by:global_name; + pn + +and find_pers_name ~allow_hidden penv check name = + let {persistent_names; _} = penv in + match Hashtbl.find persistent_names name with + | pn -> pn + | exception Not_found -> + let unit_name = CU.Name.of_head_of_global_name name in + let import = find_import ~allow_hidden penv ~check unit_name in + acknowledge_pers_name penv check name import + +let read_pers_name penv check name filename = + let unit_name = CU.Name.of_head_of_global_name name in + let import = read_import penv ~check unit_name filename in + acknowledge_pers_name penv check name import + +let need_local_ident penv (global : Global_module.t) = + (* There are three equivalent ways to phrase the question we're asking here: + + 1. Is this either a parameter or an open import? + 2. Will the generated lambda code need a parameter to take this module's + value? + 3. Is the value not statically bound? + + Crucially, all modules (besides the one being compiled or instantiated) + must be either statically bound or toplevel parameters, since the actual + functor calls that instantiate open modules happen elsewhere (so that they + can happen exactly once). *) + let global_name = global |> Global_module.to_name in + let name = global_name |> CU.Name.of_head_of_global_name in + if is_registered_parameter_import penv global_name + then + (* Already a parameter *) + true + else if current_unit_is name + then + (* Not actually importing it in the sense of needing its value (we're + building its value!) *) + false + else if current_unit_is_instance_of name + then + (* We're instantiating the module, so (here and only here!) we're accessing + its actual functor, which is a compile-time constant *) + (* CR lmaurer: Relying on [current_unit_is_instance_of] here feels hacky + when only a pretty specific call sequence gets here. *) + false + else if Global_module.is_complete global + then + (* It's a compile-time constant *) + false + else + (* Some argument is missing, or some argument's argument is missing, etc., + so it's not a compile-time constant *) + true + +let make_binding penv (global : Global_module.t) (impl : CU.t option) : binding = + let name = Global_module.to_name global in + if need_local_ident penv global + then Runtime_parameter (Ident.create_local_binding_for_global name) + else + let unit_from_cmi = + match impl with + | Some unit -> unit + | None -> + Misc.fatal_errorf + "Can't bind a parameter statically:@ %a" + Global_module.print global + in + let unit = + match global.visible_args with + | [] -> + (* Make sure the names are consistent up to the pack prefix *) + assert (Global_module.Name.equal + (unit_from_cmi |> CU.to_global_name_without_prefix) + name); + unit_from_cmi + | _ -> + (* Make sure the unit isn't supposed to be packed *) + assert (not (CU.is_packed unit_from_cmi)); + CU.of_global_name name + in + Constant unit type address = | Aunit of Compilation_unit.t @@ -379,25 +710,24 @@ type 'a sig_reader = (* Add a persistent structure to the hash table and bind it in the [Env]. Checks that OCaml source is allowed to refer to this module. *) -let acknowledge_pers_struct penv modname import val_of_pers_sig = - if modname.Global_module.Name.args <> [] then - Misc.fatal_errorf "TODO: Unsupported instance name: %a" - Global_module.Name.print modname; +let acknowledge_pers_struct penv modname pers_name val_of_pers_sig = let {persistent_structures; _} = penv in + let import = pers_name.pn_import in + let global = pers_name.pn_global in + let sign = pers_name.pn_sign in let is_param = import.imp_is_param in - let sign = import.imp_sign in + let impl = import.imp_impl in let filename = import.imp_filename in let flags = import.imp_flags in - check_for_unset_parameters penv modname import; begin match is_param, is_registered_parameter_import penv modname with | true, false -> error (Illegal_import_of_parameter(modname, filename)) | false, true -> - error (Not_compiled_as_parameter(modname, filename)) + error (Not_compiled_as_parameter modname) | true, true | false, false -> () end; - let binding = make_binding penv modname import in + let binding = make_binding penv global impl in let address : address = match binding with | Runtime_parameter id -> Alocal id @@ -432,22 +762,20 @@ let acknowledge_pers_struct penv modname import val_of_pers_sig = ps let read_pers_struct penv val_of_pers_sig check modname cmi ~add_binding = - let unit_name = CU.Name.of_head_of_global_name modname in - let import = read_import penv ~check unit_name cmi in + let pers_name = read_pers_name penv check modname cmi in if add_binding then ignore - (acknowledge_pers_struct penv modname import val_of_pers_sig + (acknowledge_pers_struct penv modname pers_name val_of_pers_sig : _ pers_struct_info); - import.imp_sign + pers_name.pn_sign let find_pers_struct ~allow_hidden penv val_of_pers_sig check name = let {persistent_structures; _} = penv in match Hashtbl.find persistent_structures name with | ps -> check_visibility ~allow_hidden ps.ps_import; ps | exception Not_found -> - let unit_name = CU.Name.of_head_of_global_name name in - let import = find_import ~allow_hidden penv ~check unit_name in - acknowledge_pers_struct penv name import val_of_pers_sig + let pers_name = find_pers_name ~allow_hidden penv check name in + acknowledge_pers_struct penv name pers_name val_of_pers_sig let describe_prefix ppf prefix = if CU.Prefix.is_empty prefix then @@ -489,9 +817,16 @@ let check_pers_struct ~allow_hidden penv f ~loc name = Format.asprintf "%a is inaccessible from %a" CU.print unit describe_prefix prefix + (* The cmi is necessary, otherwise the functor cannot be + generated. Moreover, aliases of functor arguments are forbidden. *) | Illegal_import_of_parameter _ -> assert false | Not_compiled_as_parameter _ -> assert false | Imported_module_has_unset_parameter _ -> assert false + | Imported_module_has_no_such_parameter _ -> assert false + | Not_compiled_as_argument _ -> assert false + | Argument_type_mismatch _ -> assert false + | Inconsistent_global_name_resolution _ -> assert false + | Unbound_module_as_argument_value _ -> assert false in let warn = Warnings.No_cmi_file(name_as_string, Some msg) in Location.prerr_warning loc warn @@ -553,17 +888,12 @@ let parameters {param_imports; _} = let looked_up {persistent_structures; _} modname = Hashtbl.mem persistent_structures modname -let is_imported {imported_units; _} s = - CU.Name.Set.mem s !imported_units - let is_imported_opaque {imported_opaque_units; _} s = CU.Name.Set.mem s !imported_opaque_units let implemented_parameter penv modname = - match - find_import_info_in_cache penv (CU.Name.of_head_of_global_name modname) - with - | Some { imp_arg_for; _ } -> imp_arg_for + match find_name_info_in_cache penv modname with + | Some { pn_arg_for; _ } -> pn_arg_for | None -> None let make_cmi penv modname kind sign alerts = @@ -577,11 +907,20 @@ let make_cmi penv modname kind sign alerts = let params = (* Needs to be consistent with [Translmod] *) parameters penv + |> List.map (global_of_global_name penv ~check:true) in + (* Need to calculate [params] before these since [global_of_global_name] has + side effects *) let crcs = imports penv in + let globals = + Hashtbl.to_seq_values penv.globals + |> Array.of_seq + |> Array.map (fun ({ gn_global; _ }) -> gn_global) + in { cmi_name = modname; cmi_kind = kind; + cmi_globals = globals; cmi_sign = sign; cmi_params = params; cmi_crcs = Array.of_list crcs; @@ -594,16 +933,14 @@ let save_cmi penv psig = let { cmi_name = modname; cmi_kind = kind; - cmi_sign = _; - cmi_crcs = _; cmi_flags = flags; } = cmi in let crc = output_to_file_via_temporary (* see MPR#7472, MPR#4991 *) ~mode: [Open_binary] filename (fun temp_filename oc -> output_cmi temp_filename oc cmi) in - (* Enter signature in consistbl so that imports() - will also return its crc *) + (* Enter signature in consistbl so that imports() and crc_of_unit() will + also return its crc *) let data : Import_info.Intf.Nonalias.Kind.t = match kind with | Normal { cmi_impl } -> Normal cmi_impl @@ -613,9 +950,6 @@ let save_cmi penv psig = ) ~exceptionally:(fun () -> remove_file filename) -(* TODO: These should really have locations in them where possible (adapting - [Typemod]'s [Error] constructor is probably the easiest path) *) - let report_error ppf = let open Format in function @@ -643,19 +977,6 @@ let report_error ppf = filename (Style.as_inline_code CU.print) unit1 (Style.as_inline_code CU.print) unit2 - | Illegal_import_of_parameter(modname, filename) -> - fprintf ppf - "@[The file %a@ contains the interface of a parameter.@ \ - %a is not declared as a parameter for the current unit (-parameter %a).@]" - (Style.as_inline_code Location.print_filename) filename - (Style.as_inline_code Global_module.Name.print) modname - (Style.as_inline_code Global_module.Name.print) modname - | Not_compiled_as_parameter(modname, filename) -> - fprintf ppf - "@[The module %a@ is specified as a parameter, but %a@ \ - was not compiled with -as-parameter.@]" - (Style.as_inline_code Global_module.Name.print) modname - (Style.as_inline_code Location.print_filename) filename | Direct_reference_from_wrong_package(unit, filename, prefix) -> fprintf ppf "@[Invalid reference to %a (in file %s) from %a.@ %s]" @@ -663,23 +984,110 @@ let report_error ppf = filename describe_prefix prefix "Can only access members of this library's package or a containing package" + | Illegal_import_of_parameter(modname, filename) -> + fprintf ppf + "@[The file %a@ contains the interface of a parameter.@ \ + %a@ is not declared as a parameter for the current unit.@]@.\ + @[@{Hint@}: \ + @[Compile the current unit with \ + @{-parameter %a@}.@]@]" + (Style.as_inline_code Location.print_filename) filename + (Style.as_inline_code Global_module.Name.print) modname + Global_module.Name.print modname + | Not_compiled_as_parameter modname -> + fprintf ppf + "@[The module %a@ is a parameter but is not declared as such for the \ + current unit.@]@.\ + @[@{Hint@}: \ + @[Compile the current unit with @{-parameter \ + %a@}.@]@]" + (Style.as_inline_code Global_module.Name.print) modname + Global_module.Name.print modname | Imported_module_has_unset_parameter { imported = modname; parameter = param } -> fprintf ppf "@[The module %a@ is not accessible because it takes %a@ \ as a parameter and the current unit does not.@]@.\ @[@{Hint@}: \ - @[Pass `-parameter %a`@ to add %a@ as a parameter@ \ + @[Pass @{-parameter %a@}@ to add %a@ as a parameter@ \ of the current unit.@]@]" (Style.as_inline_code Global_module.Name.print) modname (Style.as_inline_code Global_module.Name.print) param + Global_module.Name.print param + (Style.as_inline_code Global_module.Name.print) param + | Imported_module_has_no_such_parameter + { valid_parameters; imported = modname; parameter = param; value = _; } -> + let pp_hint ppf () = + match valid_parameters with + | [] -> + fprintf ppf + "Compile %a@ with @{-parameter %a@}@ to make it a \ + parameter." + (Style.as_inline_code CU.Name.print) modname + Global_module.Name.print param + | _ -> + let print_params = + Format.pp_print_list ~pp_sep:Format.pp_print_space + (Style.as_inline_code Global_module.Name.print) + in + fprintf ppf "Parameters for %a:@ @[%a@]" + (Style.as_inline_code CU.Name.print) modname + print_params valid_parameters + in + fprintf ppf + "@[The module %a@ has no parameter %a.@]@.\ + @[@{Hint@}: @[%a@]@]" + (Style.as_inline_code CU.Name.print) modname (Style.as_inline_code Global_module.Name.print) param + pp_hint () + | Not_compiled_as_argument { param; value; filename } -> + fprintf ppf + "@[The module %a@ cannot be used as an argument for parameter \ + %a.@]@.\ + @[@{Hint@}: \ + @[Compile %a@ with @{-as-argument-for %a@}.@]@]" + (Style.as_inline_code Global_module.Name.print) value (Style.as_inline_code Global_module.Name.print) param + (Style.as_inline_code Location.print_filename) filename + Global_module.Name.print param + | Argument_type_mismatch { value; filename; expected; actual; } -> + fprintf ppf + "@[The module %a@ is used as an argument for the parameter %a@ \ + but %a@ is an argument for %a.@]@.\ + @[@{Hint@}: \ + @[%a@ was compiled with \ + @{-as-argument-for %a@}.@]@]" + (Style.as_inline_code Global_module.Name.print) value + (Style.as_inline_code Global_module.Name.print) expected + (Style.as_inline_code Global_module.Name.print) value + (Style.as_inline_code Global_module.Name.print) actual + (Style.as_inline_code Location.print_filename) filename + Global_module.Name.print expected + | Inconsistent_global_name_resolution + { name; old_global; new_global; first_mentioned_by; now_mentioned_by } -> + fprintf ppf + "@[The name %a@ was bound to %a@ by %a@ \ + but it is instead bound to %a@ by %a.@]" + (Style.as_inline_code Global_module.Name.print) name + (Style.as_inline_code Global_module.print) old_global + (Style.as_inline_code Global_module.Name.print) first_mentioned_by + (Style.as_inline_code Global_module.print) new_global + (Style.as_inline_code Global_module.Name.print) now_mentioned_by + | Unbound_module_as_argument_value { instance; value } -> + fprintf ppf + "@[Unbound module %a@ in instance %a@]" + (Style.as_inline_code Global_module.Name.print) value + (Style.as_inline_code Global_module.Name.print) instance let () = Location.register_error_of_exn (function | Error err -> + (* Note that this module don't have location info in its errors, since + (unlike [Env]) it doesn't take [Location.t]s as arguments. However, + [Env] is often able to add location info to our errors by + re-raising them with the [Env.Error_from_persistent_env] + constructor. *) Some (Location.error_of_printer_file report_error err) | _ -> None ) diff --git a/typing/persistent_env.mli b/typing/persistent_env.mli index 4f74888444e..fbaaad39c88 100644 --- a/typing/persistent_env.mli +++ b/typing/persistent_env.mli @@ -16,9 +16,7 @@ open Misc -module Consistbl_data : sig - type t -end +module Consistbl_data = Import_info.Intf.Nonalias.Kind module Consistbl : module type of struct include Consistbl.Make (Compilation_unit.Name) (Consistbl_data) @@ -33,11 +31,38 @@ type error = | Direct_reference_from_wrong_package of Compilation_unit.t * filepath * Compilation_unit.Prefix.t | Illegal_import_of_parameter of Global_module.Name.t * filepath - | Not_compiled_as_parameter of Global_module.Name.t * filepath + | Not_compiled_as_parameter of Global_module.Name.t | Imported_module_has_unset_parameter of { imported : Global_module.Name.t; parameter : Global_module.Name.t; - } + } + | Imported_module_has_no_such_parameter of + { imported : Compilation_unit.Name.t; + valid_parameters : Global_module.Name.t list; + parameter : Global_module.Name.t; + value : Global_module.Name.t; + } + | Not_compiled_as_argument of + { param : Global_module.Name.t; + value : Global_module.Name.t; + filename : filepath; + } + | Argument_type_mismatch of + { value : Global_module.Name.t; + filename : filepath; + expected : Global_module.Name.t; + actual : Global_module.Name.t; + } + | Inconsistent_global_name_resolution of + { name : Global_module.Name.t; + old_global : Global_module.t; + new_global : Global_module.t; + first_mentioned_by : Global_module.Name.t; + now_mentioned_by : Global_module.Name.t; + } + | Unbound_module_as_argument_value of + { instance : Global_module.Name.t; value : Global_module.Name.t; } + exception Error of error @@ -114,10 +139,6 @@ val is_parameter_import : 'a t -> Global_module.Name.t -> bool [penv] (it may have failed) *) val looked_up : 'a t -> Global_module.Name.t -> bool -(* [is_imported penv md] checks if [md] has been successfully - imported in the environment [penv] *) -val is_imported : 'a t -> Compilation_unit.Name.t -> bool - (* [is_imported_opaque penv md] checks if [md] has been imported in [penv] as an opaque module *) val is_imported_opaque : 'a t -> Compilation_unit.Name.t -> bool @@ -126,11 +147,22 @@ val is_imported_opaque : 'a t -> Compilation_unit.Name.t -> bool opaque module *) val register_import_as_opaque : 'a t -> Compilation_unit.Name.t -> unit +(* [local_ident penv md] returns the local identifier generated for [md] if + [md] is either a parameter or a dependency with a parameter. This is used + strictly for code generation - types should always use persistent + [Ident.t]s. *) +val local_ident : 'a t -> Global_module.Name.t -> Ident.t option + (* [implemented_parameter penv md] returns the argument to [-as-argument-for] that [md] was compiled with. *) val implemented_parameter : 'a t -> Global_module.Name.t -> Global_module.Name.t option +val global_of_global_name : 'a t + -> check:bool + -> Global_module.Name.t + -> Global_module.t + val make_cmi : 'a t -> Compilation_unit.Name.t -> Cmi_format.kind @@ -148,10 +180,10 @@ val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c (* may raise Consistbl.Inconsistency *) val import_crcs : 'a t -> source:filepath -> - Import_info.t array -> unit + Import_info.Intf.t array -> unit (* Return the set of compilation units imported, with their CRC *) -val imports : 'a t -> Import_info.t list +val imports : 'a t -> Import_info.Intf.t list (* Return the set of imports represented as runtime parameters. If this module is indeed parameterised (that is, [parameters] returns a non-empty list), it will be compiled as diff --git a/typing/signature_with_global_bindings.ml b/typing/signature_with_global_bindings.ml new file mode 100644 index 00000000000..b596ec139cc --- /dev/null +++ b/typing/signature_with_global_bindings.ml @@ -0,0 +1,79 @@ +[@@@ocaml.warning "+a-9-40-41-42"] + +type t = { + sign : Subst.Lazy.signature; + bound_globals : Global_module.t array; +} + +let read_from_cmi (cmi : Cmi_format.cmi_infos_lazy) = + let sign = + (* Freshen identifiers bound by signature *) + Subst.Lazy.signature Make_local Subst.identity cmi.cmi_sign in + let bound_globals = cmi.cmi_globals in + { sign; bound_globals } + +let array_fold_left_filter_map f init array = + let ans, new_array = Array.fold_left_map f init array in + let new_array = + (* To be replaced with something faster if we need it *) + Array.of_seq (Seq.filter_map (fun a -> a) (Array.to_seq new_array)) + in + ans, new_array + +let subst t (args : (Global_module.Name.t * Global_module.t) list) = + let { sign; bound_globals } = t in + match args with + | [] -> t + | _ -> + (* The global-level substitution *) + let arg_subst = Global_module.Name.Map.of_list args in + (* Take a bound global, substitute arguments into it, then return the + updated global while also adding it to the term-level substitution *) + let add_and_update_binding subst bound_global = + let name = Global_module.to_name bound_global in + if Global_module.Name.Map.mem name arg_subst then + (* This shouldn't happen: only globals with hidden arguments should be + in [bound_globals], and parameters shouldn't have arguments. + Previous code that was meant to handle parameterised parameters + was simply saying [subst, None] here since [add_arg] would handle + adding to [subst] and we can drop the global from [bound_globals] + if we're substituting for it. *) + Misc.fatal_error "Unexpected parameterised parameter" + else + begin + let value, changed = Global_module.subst bound_global arg_subst in + let name_id = Ident.create_global name in + let value_as_name = Global_module.to_name value in + let value_id = Ident.create_global value_as_name in + let subst = + match changed with + | `Changed -> + Subst.add_module name_id (Pident value_id) subst + | `Did_not_change -> + subst + in + let new_bound_global = + if Global_module.is_complete value then + (* No explicit binding for unparameterised or + completely-applied global *) + None + else + Some value + in + subst, new_bound_global + end + in + let subst = Subst.identity in + let subst, bound_globals = + array_fold_left_filter_map add_and_update_binding subst bound_globals + in + (* Add an argument to the substitution. *) + let add_arg subst (name, value) = + let name_id = Ident.create_global name in + let value_as_name = Global_module.to_name value in + let value_id = Ident.create_global value_as_name in + Subst.add_module name_id (Pident value_id) subst + in + let subst = List.fold_left add_arg subst args in + let sign = Subst.Lazy.signature Keep subst sign in + { sign; bound_globals } diff --git a/typing/signature_with_global_bindings.mli b/typing/signature_with_global_bindings.mli new file mode 100644 index 00000000000..27494c9bd62 --- /dev/null +++ b/typing/signature_with_global_bindings.mli @@ -0,0 +1,54 @@ +[@@@ocaml.warning "+a-9-40-41-42"] + +(** The [cmi_sign] and [cmi_globals] fields from a .cmi file, seen as a single + term of the form: + + {v let = in + ... + let = in + sig + ... + end v} + + Note that globals without parameters are understood to be bound but aren't + represented explicitly. *) +type t = private { + sign : Subst.Lazy.signature; + bound_globals : Global_module.t array; +} + +val read_from_cmi : Cmi_format.cmi_infos_lazy -> t + +(** To see how substitution will work on [t], suppose we have something like + {v let X = X in + let Y = Y in + let M = M{X}{Y} in + ... X ... Y ... M ... v} + Now suppose we import this module and pass [A] as the value of [X]. + + 1. We substitute [A] for [X] in the bound global names: + {v let X = A in + let Y = Y in + let M = M[X:A]{Y} in + ... X ... Y ... M ... v} + 2. Now, as usual, to work with the signature, we need to add these bindings + to the environment. However, we can't lift them in this form, as [X] and + [M] may have different bindings in different modules. To achieve + consistency, we alpha-rename to a canonical form: + {v let A = A in + let Y = Y in + let M[X:A] = M[X:A]{Y} + ... A ... Y ... M[X:A] ... v} + + In general, the plan of action is: + + 1. Form a substitution [S] mapping each argument's name to its value + 2. Apply [S] to the RHSes of the global name bindings + 3. For each new binding [L = R'], let [L'] be the [Global_module.to_name] of + [R'], substitute [L'] for [L] in the body, and update the binding to + [L' = R'] + + Note that the argument values themselves won't be returned in the new list + of bound globals, since it's assumed that they are already accounted for in + the environment. *) +val subst : t -> (Global_module.Name.t * Global_module.t) list -> t diff --git a/typing/typemod.ml b/typing/typemod.ml index 7823888ba3a..e8283504f91 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -2535,38 +2535,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env in Mode.Value.submode_exn mode Mode.Value.legacy; - let md = { mod_desc = Tmod_ident (path, lid); - mod_type = Mty_alias path; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } in - let aliasable = not (Env.is_functor_arg path env) in - let shape = - Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path - in - let shape = if alias && aliasable then Shape.alias shape else shape in - let md = - if alias && aliasable then - (Env.add_required_global path env; md) - else begin - let mty = Mtype.find_type_of_module - ~strengthen:sttn ~aliasable env path - in - match mty with - | Mty_alias p1 when not alias -> - let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in - let mty = Includemod.expand_module_alias - ~strengthen:sttn env p1 in - { md with - mod_desc = - Tmod_constraint (md, mty, Tmodtype_implicit, - Tcoerce_alias (env, path, Tcoerce_none)); - mod_type = mty } - | mty -> - { md with mod_type = mty } - end - in - md, shape + type_module_path_aux ~alias sttn env path lid smod | Pmod_structure sstr -> let (str, sg, names, shape, _finalenv) = type_structure funct_body anchor env sstr in @@ -2674,10 +2643,54 @@ and type_module_extension_aux ~alias sttn env smod : Jane_syntax.Module_expr.t -> _ = function | Emod_instance (Imod_instance glob) -> - ignore (alias, sttn); let glob = instance_name ~loc:smod.pmod_loc env glob in - Misc.fatal_errorf "@[Unimplemented: instance identifier@ %a@]" - Global_module.Name.print glob + let path, mode = + Env.lookup_module_instance_path ~load:(not alias) ~loc:smod.pmod_loc + glob env + in + Mode.Value.submode_exn mode Mode.Value.legacy; + let lid = + (* Only used by [untypeast] *) + let name = + Format.asprintf "*instance %a*" Global_module.Name.print glob + in + Lident name |> Location.mknoloc + in + type_module_path_aux ~alias sttn env path lid smod + +and type_module_path_aux ~alias sttn env path lid smod = + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } in + let aliasable = not (Env.is_functor_arg path env) in + let shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let shape = if alias && aliasable then Shape.alias shape else shape in + let md = + if alias && aliasable then + (Env.add_required_global path env; md) + else begin + let mty = Mtype.find_type_of_module + ~strengthen:sttn ~aliasable env path + in + match mty with + | Mty_alias p1 when not alias -> + let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape and type_application loc strengthen funct_body env smod = let rec extract_application funct_body env sargs smod = diff --git a/utils/symbol.ml b/utils/symbol.ml index c8e3781cbf1..6eef6085b35 100644 --- a/utils/symbol.ml +++ b/utils/symbol.ml @@ -68,6 +68,11 @@ let separator () = let this_is_ocamlc () = this_is_ocamlc := true let force_runtime4_symbols () = force_runtime4_symbols := true +let pack_separator = separator +let instance_separator = "___" +let instance_separator_depth_char = '_' +let member_separator = separator + let linkage_name t = t.linkage_name let linkage_name_for_ocamlobjinfo t = @@ -86,17 +91,34 @@ let compilation_unit t = t.compilation_unit [Linkage_name.for_current_unit] *) let linkage_name_for_compilation_unit comp_unit = - let name = CU.Name.to_string (CU.name comp_unit) in - let for_pack_prefix = CU.for_pack_prefix comp_unit in + (* CR-someday lmaurer: If at all possible, just use square brackets instead of + this unholy underscore encoding. For now I'm following the original + practice of avoiding non-identifier characters. *) + let for_pack_prefix, name, flattened_instance_args = CU.flatten comp_unit in + let name = CU.Name.to_string name in let suffix = - if CU.Prefix.is_empty for_pack_prefix then name - else + if not (CU.Prefix.is_empty for_pack_prefix) + then begin + assert (flattened_instance_args = []); let pack_names = CU.Prefix.to_list for_pack_prefix |> List.map CU.Name.to_string in - String.concat (separator ()) (pack_names @ [name]) + String.concat (pack_separator ()) (pack_names @ [name]) + end else begin + let arg_segments = + List.map + (fun (depth, _param, value) -> + let extra_separators = + String.make depth instance_separator_depth_char + in + let value = value |> CU.Name.to_string in + String.concat "" [instance_separator; extra_separators; value]) + flattened_instance_args + in + String.concat "" arg_segments + end in - caml_symbol_prefix ^ suffix + caml_symbol_prefix ^ name ^ suffix |> Linkage_name.of_string let for_predef_ident id = @@ -118,7 +140,7 @@ let for_name compilation_unit name = linkage_name_for_compilation_unit compilation_unit |> Linkage_name.to_string in let linkage_name = - prefix ^ (separator ()) ^ name |> Linkage_name.of_string + prefix ^ (member_separator ()) ^ name |> Linkage_name.of_string in { compilation_unit; linkage_name;