diff --git a/.depend b/.depend index 487599130..22aecafee 100644 --- a/.depend +++ b/.depend @@ -5743,6 +5743,7 @@ driver/compenv.cmx : \ driver/compenv.cmi : \ utils/clflags.cmi driver/compile.cmo : \ + typing/typedtree.cmi \ lambda/translmod.cmi \ lambda/simplif.cmi \ utils/profile.cmi \ @@ -5756,6 +5757,7 @@ driver/compile.cmo : \ bytecomp/bytegen.cmi \ driver/compile.cmi driver/compile.cmx : \ + typing/typedtree.cmx \ lambda/translmod.cmx \ lambda/simplif.cmx \ utils/profile.cmx \ @@ -5934,6 +5936,7 @@ driver/makedepend.cmx : \ driver/makedepend.cmi driver/makedepend.cmi : driver/optcompile.cmo : \ + typing/typedtree.cmi \ lambda/translmod.cmi \ lambda/simplif.cmi \ utils/profile.cmi \ @@ -5949,6 +5952,7 @@ driver/optcompile.cmo : \ asmcomp/asmgen.cmi \ driver/optcompile.cmi driver/optcompile.cmx : \ + typing/typedtree.cmx \ lambda/translmod.cmx \ lambda/simplif.cmx \ utils/profile.cmx \ diff --git a/driver/compile.ml b/driver/compile.ml index ead460368..7a88388c3 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -27,8 +27,8 @@ let interface ~source_file ~output_prefix = (** Bytecode compilation backend for .ml files. *) -let to_bytecode i (typedtree, coercion) = - (typedtree, coercion) +let to_bytecode i Typedtree.{structure; coercion; _} = + (structure, coercion) |> Profile.(record transl) (Translmod.transl_implementation i.module_name) |> Profile.(record ~accumulate:true generate) diff --git a/driver/compile.mli b/driver/compile.mli index 968955762..ec54f0708 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -25,7 +25,7 @@ val implementation: val to_bytecode : Compile_common.info -> - Typedtree.structure * Typedtree.module_coercion -> + Typedtree.implementation -> Instruct.instruction list * Ident.Set.t (** [to_bytecode info typed] takes a typechecked implementation and returns its bytecode. diff --git a/driver/compile_common.mli b/driver/compile_common.mli index b43125d6d..c2f29cbe3 100644 --- a/driver/compile_common.mli +++ b/driver/compile_common.mli @@ -68,17 +68,14 @@ val interface : info -> unit val parse_impl : info -> Parsetree.structure (** [parse_impl info] parses an implementation (usually an [.ml] file). *) -val typecheck_impl : - info -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion +val typecheck_impl : info -> Parsetree.structure -> Typedtree.implementation (** [typecheck_impl info parsetree] typechecks an implementation and returns - the typedtree of the associated module, along with a coercion against - its public interface. + the typedtree of the associated module, its public interface, and a + coercion against that public interface. *) val implementation : - info -> - backend:(info -> Typedtree.structure * Typedtree.module_coercion -> unit) -> - unit + info -> backend:(info -> Typedtree.implementation -> unit) -> unit (** The complete compilation pipeline for implementations. *) (** {2 Build artifacts} *) diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 693a35f48..51fc23cfb 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -31,14 +31,14 @@ let (|>>) (x, y) f = (x, f y) (** Native compilation backend for .ml files. *) -let flambda i backend typed = +let flambda i backend Typedtree.{structure; coercion; _} = if !Clflags.classic_inlining then begin Clflags.default_simplify_rounds := 1; Clflags.use_inlining_arguments_set Clflags.classic_arguments; Clflags.unbox_free_vars_of_closures := false; Clflags.unbox_specialised_args := false end; - typed + (structure, coercion) |> Profile.(record transl) (Translmod.transl_implementation_flambda i.module_name) |> Profile.(record generate) @@ -66,9 +66,9 @@ let flambda i backend typed = program); Compilenv.save_unit_info (cmx i)) -let clambda i backend typed = +let clambda i backend Typedtree.{structure; coercion; _} = Clflags.use_inlining_arguments_set Clflags.classic_arguments; - typed + (structure, coercion) |> Profile.(record transl) (Translmod.transl_store_implementation i.module_name) |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program diff --git a/driver/optcompile.mli b/driver/optcompile.mli index f04e75e62..8f4a3127a 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -27,7 +27,7 @@ val implementation: val clambda : Compile_common.info -> (module Backend_intf.S) -> - Typedtree.structure * Typedtree.module_coercion -> unit + Typedtree.implementation -> unit (** [clambda info typed] applies the regular compilation pipeline to the given typechecked implementation and outputs the resulting files. *) @@ -35,7 +35,7 @@ val clambda : val flambda : Compile_common.info -> (module Backend_intf.S) -> - Typedtree.structure * Typedtree.module_coercion -> unit + Typedtree.implementation -> unit (** [flambda info backend typed] applies the Flambda compilation pipeline to the given typechecked implementation and outputs the resulting files. *) diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 79eda876f..f9ec3cb69 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -151,7 +151,8 @@ let process_file sourcefile = match parsetree_typedtree_opt with None -> None - | Some (parsetree, typedtree) -> + | Some (parsetree, Typedtree.{structure; coercion; _}) -> + let typedtree = (structure, coercion) in let file_module = Ast_analyser.analyse_typed_tree file input_file parsetree typedtree in diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 15aa09728..ccf93f1b7 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -942,4 +942,5 @@ let interface ppf x = list 0 signature_item ppf x.sig_items;; let implementation ppf x = list 0 structure_item ppf x.str_items;; -let implementation_with_coercion ppf (x, _) = implementation ppf x +let implementation_with_coercion ppf Typedtree.{structure; _} = + implementation ppf structure diff --git a/typing/printtyped.mli b/typing/printtyped.mli index ded42bb32..538a3faae 100644 --- a/typing/printtyped.mli +++ b/typing/printtyped.mli @@ -20,4 +20,4 @@ val interface : formatter -> signature -> unit;; val implementation : formatter -> structure -> unit;; val implementation_with_coercion : - formatter -> (structure * module_coercion) -> unit;; + formatter -> Typedtree.implementation -> unit;; diff --git a/typing/typedtree.ml b/typing/typedtree.ml index ca81b0f05..4015ed8e1 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -613,6 +613,13 @@ and 'a class_infos = ci_attributes: attribute list; } +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature +} + + (* Auxiliary functions over the a.s.t. *) let as_computation_pattern (p : pattern) : computation general_pattern = diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 1323505cd..33cb0591c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -752,6 +752,21 @@ and 'a class_infos = ci_attributes: attributes; } +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature +} +(** A typechecked implementation including its module structure, its exported + signature, and a coercion of the module against that signature. + + If an .mli file is present, the signature will come from that file and be + the exported signature of the module. + + If there isn't one, the signature will be inferred from the module + structure. +*) + (* Auxiliary functions over the a.s.t. *) (** [as_computation_pattern p] is a computation pattern with description diff --git a/typing/typemod.ml b/typing/typemod.ml index b2daa008d..649ad11e8 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -2631,7 +2631,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (Printtyp.printed_signature sourcefile) simple_sg ); gen_annot outputprefix sourcefile (Cmt_format.Implementation str); - (str, Tcoerce_none) (* result is ignored by Compile.implementation *) + { structure = str; + coercion = Tcoerce_none; + signature = simple_sg + } (* result is ignored by Compile.implementation *) end else begin let sourceintf = Filename.remove_extension sourcefile ^ !Config.interface_suffix in @@ -2655,7 +2658,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename annots (Some sourcefile) initial_env None; gen_annot outputprefix sourcefile annots; - (str, coercion) + { structure = str; + coercion; + signature = dclsig + } end else begin let coercion = Includemod.compunit initial_env ~mark:Mark_positive @@ -2679,7 +2685,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = annots (Some sourcefile) initial_env (Some cmi); gen_annot outputprefix sourcefile annots end; - (str, coercion) + { structure = str; + coercion; + signature = simple_sg + } end end ) diff --git a/typing/typemod.mli b/typing/typemod.mli index c24aa5e2a..87ebd8f1f 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -38,8 +38,8 @@ val type_toplevel_phrase: Env.t -> Parsetree.structure -> Typedtree.structure * Types.signature * Signature_names.t * Env.t val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion + string -> string -> string -> Env.t -> + Parsetree.structure -> Typedtree.implementation val type_interface: Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: diff --git a/typing/untypeast.ml b/typing/untypeast.ml index dc36aaf43..1ff4ae6d2 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -605,7 +605,7 @@ let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter = | Unit -> Unit | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype) -let module_type sub mty = +let module_type (sub : mapper) mty = let loc = sub.location sub mty.mty_loc in let attrs = sub.attributes sub mty.mty_attributes in let desc = match mty.mty_desc with @@ -633,7 +633,7 @@ let with_constraint sub (_path, lid, cstr) = | Twith_modsubst (_path, lid2) -> Pwith_modsubst (map_loc sub lid, map_loc sub lid2) -let module_expr sub mexpr = +let module_expr (sub : mapper) mexpr = let loc = sub.location sub mexpr.mod_loc in let attrs = sub.attributes sub mexpr.mod_attributes in match mexpr.mod_desc with @@ -882,10 +882,10 @@ let default_mapper = object_field = object_field ; } -let untype_structure ?(mapper=default_mapper) structure = +let untype_structure ?(mapper : mapper = default_mapper) structure = mapper.structure mapper structure -let untype_signature ?(mapper=default_mapper) signature = +let untype_signature ?(mapper : mapper = default_mapper) signature = mapper.signature mapper signature let untype_expression ?(mapper=default_mapper) expression =