diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml index 612e4a7cac..e09cbf9ae3 100644 --- a/file_formats/cmi_format.ml +++ b/file_formats/cmi_format.ml @@ -74,7 +74,6 @@ type 'sg cmi_infos_generic = { cmi_flags : flags; } -<<<<<<< HEAD type cmi_infos_lazy = Subst.Lazy.signature cmi_infos_generic type cmi_infos = Types.signature cmi_infos_generic @@ -126,15 +125,9 @@ let input_cmi_lazy ic = header_kind = kind; header_sign = sign; } = (input_value ic : header) in -||||||| 121bedcfd2 -let input_cmi ic = - let (name, sign) = (input_value ic : header) in -======= -let input_cmi ic = - let (name, sign) = (Compression.input_value ic : header) in ->>>>>>> 5.2.0 let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in + (* CR ocaml 5 compressed-marshal mshinwell: upstream uses [Compression] *) { cmi_name = name; cmi_kind = kind; @@ -175,7 +168,6 @@ let read_cmi_lazy filename = let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; -<<<<<<< HEAD let output_int64 oc n = let buf = Bytes.create 8 in Bytes.set_int64_ne buf 0 n; @@ -192,21 +184,12 @@ let output_cmi filename oc cmi = let len = Int64.sub val_pos data_pos in output_int64 oc len; Out_channel.seek oc val_pos; - (* BACKPORT BEGIN *) - (* CR ocaml 5 compressed-marshal mshinwell: - upstream uses [Compression] here *) output_value oc { header_name = cmi.cmi_name; header_kind = cmi.cmi_kind; header_sign = sign; }; - (* BACKPORT END *) -||||||| 121bedcfd2 - Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); -======= - Compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header); ->>>>>>> 5.2.0 flush oc; let crc = Digest.file filename in let my_info = diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index 5074354e8d..d9083326aa 100644 --- a/file_formats/cmt_format.ml +++ b/file_formats/cmt_format.ml @@ -62,14 +62,8 @@ type cmt_infos = { cmt_use_summaries : bool; cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) -<<<<<<< HEAD cmt_ident_occurrences : (Longident.t Location.loc * Shape_reduce.result) array -||||||| 121bedcfd2 -======= - cmt_ident_occurrences : - (Longident.t Location.loc * Shape_reduce.result) list ->>>>>>> 5.2.0 } type error = @@ -150,7 +144,6 @@ let clear_env binary_annots = else binary_annots -<<<<<<< HEAD (* Every typedtree node with a located longident corresponding to user-facing syntax should be indexed. *) let iter_on_occurrences @@ -249,9 +242,10 @@ let iter_on_occurrences | Ttyp_class (path, lid, _typs) -> (* Deprecated syntax to extend a polymorphic variant *) f ~namespace:Type ctyp_env path lid + | Ttyp_open (path, lid, _ct) -> + f ~namespace:Module ctyp_env path lid | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ - | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ - | Ttyp_call_pos -> ()); + | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ | Ttyp_call_pos -> ()); default_iterator.typ sub ct); pat = @@ -389,260 +383,19 @@ let index_occurrences binary_annots = iter_on_annots (iter_on_occurrences ~f) binary_annots; Array.of_list !index -||||||| 121bedcfd2 -======= -(* Every typedtree node with a located longident corresponding to user-facing - syntax should be indexed. *) -let iter_on_occurrences - ~(f : namespace:Shape.Sig_component_kind.t -> - Env.t -> Path.t -> Longident.t Location.loc -> - unit) = - let path_in_type typ name = - match Types.get_desc typ with - | Tconstr (type_path, _, _) -> - Some (Path.Pdot (type_path, name)) - | _ -> None - in - let add_constructor_description env lid = - function - | { Types.cstr_tag = Cstr_extension (path, _); _ } -> - f ~namespace:Extension_constructor env path lid - | { Types.cstr_uid = Predef name; _} -> - let id = List.assoc name Predef.builtin_idents in - f ~namespace:Constructor env (Pident id) lid - | { Types.cstr_res; cstr_name; _ } -> - let path = path_in_type cstr_res cstr_name in - Option.iter (fun path -> f ~namespace:Constructor env path lid) path - in - let add_label env lid { Types.lbl_name; lbl_res; _ } = - let path = path_in_type lbl_res lbl_name in - Option.iter (fun path -> f ~namespace:Label env path lid) path - in - let with_constraint ~env (_path, _lid, with_constraint) = - match with_constraint with - | Twith_module (path', lid') | Twith_modsubst (path', lid') -> - f ~namespace:Module env path' lid' - | _ -> () - in - Tast_iterator.{ default_iterator with - - expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> - (match exp_desc with - | Texp_ident (path, lid, _) -> - f ~namespace:Value exp_env path lid - | Texp_construct (lid, constr_desc, _) -> - add_constructor_description exp_env lid constr_desc - | Texp_field (_, lid, label_desc) - | Texp_setfield (_, lid, label_desc, _) -> - add_label exp_env lid label_desc - | Texp_new (path, lid, _) -> - f ~namespace:Class exp_env path lid - | Texp_record { fields; _ } -> - Array.iter (fun (label_descr, record_label_definition) -> - match record_label_definition with - | Overridden ( - { Location.txt; loc}, - {exp_loc; _}) - when not exp_loc.loc_ghost - && loc.loc_start = exp_loc.loc_start - && loc.loc_end = exp_loc.loc_end -> - (* In the presence of punning we want to index the label - even if it is ghosted *) - let lid = { Location.txt; loc = {loc with loc_ghost = false} } in - add_label exp_env lid label_descr - | Overridden (lid, _) -> add_label exp_env lid label_descr - | Kept _ -> ()) fields - | Texp_instvar (_self_path, path, name) -> - let lid = { name with txt = Longident.Lident name.txt } in - f ~namespace:Value exp_env path lid - | Texp_setinstvar (_self_path, path, name, _) -> - let lid = { name with txt = Longident.Lident name.txt } in - f ~namespace:Value exp_env path lid - | Texp_override (_self_path, modifs) -> - List.iter (fun (id, (name : string Location.loc), _exp) -> - let lid = { name with txt = Longident.Lident name.txt } in - f ~namespace:Value exp_env (Path.Pident id) lid) - modifs - | Texp_extension_constructor (lid, path) -> - f ~namespace:Extension_constructor exp_env path lid - | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ - | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ - | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ - | Texp_send _ - | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ - | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable - | Texp_open _ -> ()); - default_iterator.expr sub e); - - (* Remark: some types get iterated over twice due to how constraints are - encoded in the typedtree. For example, in [let x : t = 42], [t] is - present in both a [Tpat_constraint] and a [Texp_constraint] node) *) - typ = - (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> - (match ctyp_desc with - | Ttyp_constr (path, lid, _ctyps) -> - f ~namespace:Type ctyp_env path lid - | Ttyp_package {pack_path; pack_txt} -> - f ~namespace:Module_type ctyp_env pack_path pack_txt - | Ttyp_class (path, lid, _typs) -> - (* Deprecated syntax to extend a polymorphic variant *) - f ~namespace:Type ctyp_env path lid - | Ttyp_open (path, lid, _ct) -> - f ~namespace:Module ctyp_env path lid - | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ - | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); - default_iterator.typ sub ct); - - pat = - (fun (type a) sub - ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> - (match pat_desc with - | Tpat_construct (lid, constr_desc, _, _) -> - add_constructor_description pat_env lid constr_desc - | Tpat_record (fields, _) -> - List.iter (fun (lid, label_descr, pat) -> - let lid = - let open Location in - (* In the presence of punning we want to index the label - even if it is ghosted *) - if (not pat.pat_loc.loc_ghost - && lid.loc.loc_start = pat.pat_loc.loc_start - && lid.loc.loc_end = pat.pat_loc.loc_end) - then {lid with loc = {lid.loc with loc_ghost = false}} - else lid - in - add_label pat_env lid label_descr) - fields - | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ - | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ - | Tpat_exception _ | Tpat_or _ -> ()); - List.iter (fun (pat_extra, _, _) -> - match pat_extra with - | Tpat_open (path, lid, _) -> - f ~namespace:Module pat_env path lid - | Tpat_type (path, lid) -> - f ~namespace:Type pat_env path lid - | Tpat_constraint _ | Tpat_unpack -> ()) - pat_extra; - default_iterator.pat sub pat); - - binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> - let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in - f ~namespace:Value bop_exp.exp_env bop_op_path lid; - default_iterator.binding_op sub bop); - - module_expr = - (fun sub ({ mod_desc; mod_env; _ } as me) -> - (match mod_desc with - | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid - | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ - | Tmod_constraint _ | Tmod_unpack _ -> ()); - default_iterator.module_expr sub me); - - open_description = - (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> - f ~namespace:Module open_env path lid; - default_iterator.open_description sub od); - - module_type = - (fun sub ({ mty_desc; mty_env; _ } as mty) -> - (match mty_desc with - | Tmty_ident (path, lid) -> - f ~namespace:Module_type mty_env path lid - | Tmty_with (_mty, l) -> - List.iter (with_constraint ~env:mty_env) l - | Tmty_alias (path, lid) -> - f ~namespace:Module mty_env path lid - | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); - default_iterator.module_type sub mty); - - class_expr = - (fun sub ({ cl_desc; cl_env; _} as ce) -> - (match cl_desc with - | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid - | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ - | Tcl_constraint _ | Tcl_open _ -> ()); - default_iterator.class_expr sub ce); - - class_type = - (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> - (match cltyp_desc with - | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid - | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); - default_iterator.class_type sub ct); - - signature_item = - (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> - (match sig_desc with - | Tsig_exception { - tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> - f ~namespace:Extension_constructor sig_env path lid - | Tsig_modsubst { ms_manifest; ms_txt } -> - f ~namespace:Module sig_env ms_manifest ms_txt - | Tsig_typext { tyext_path; tyext_txt } -> - f ~namespace:Type sig_env tyext_path tyext_txt - | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ - | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ - | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ - | Tsig_attribute _ -> ()); - default_iterator.signature_item sub sig_item); - - structure_item = - (fun sub ({ str_desc; str_env; _ } as str_item) -> - (match str_desc with - | Tstr_exception { - tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> - f ~namespace:Extension_constructor str_env path lid - | Tstr_typext { tyext_path; tyext_txt } -> - f ~namespace:Type str_env tyext_path tyext_txt - | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ - | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ - | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ - | Tstr_include _ | Tstr_attribute _ -> ()); - default_iterator.structure_item sub str_item) -} - -let index_declarations binary_annots = - let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in - let f uid fragment = Types.Uid.Tbl.add index uid fragment in - iter_on_annots (iter_on_declarations ~f) binary_annots; - index - -let index_occurrences binary_annots = - let index : (Longident.t Location.loc * Shape_reduce.result) list ref = - ref [] - in - let f ~namespace env path lid = - let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in - if not_ghost lid then - match Env.shape_of_path ~namespace env path with - | exception Not_found -> () - | { uid = Some (Predef _); _ } -> () - | path_shape -> - let result = Shape_reduce.local_reduce_for_uid env path_shape in - index := (lid, result) :: !index - in - iter_on_annots (iter_on_occurrences ~f) binary_annots; - !index - ->>>>>>> 5.2.0 exception Error of error let input_cmt ic = (Compression.input_value ic : cmt_infos) let output_cmt oc cmt = output_string oc Config.cmt_magic_number; -<<<<<<< HEAD (* BACKPORT BEGIN *) (* CR ocaml 5 compressed-marshal mshinwell: - upstream uses [Compression] here *) + upstream uses [Compression] here: + Compression.output_value oc (cmt : cmt_infos) + *) Marshal.(to_channel oc (cmt : cmt_infos) []) (* BACKPORT END *) -||||||| 121bedcfd2 - Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) -======= - Compression.output_value oc (cmt : cmt_infos) ->>>>>>> 5.2.0 let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) @@ -697,7 +450,7 @@ let record_value_dependency vd1 vd2 = if vd1.Types.val_loc <> vd2.Types.val_loc then value_deps := (vd1, vd2) :: !value_deps -let save_cmt target binary_annots initial_env cmi shape = +let save_cmt target cu binary_annots initial_env cmi shape = if !Clflags.binary_annotations && not !Clflags.print_types then begin Misc.output_to_file_via_temporary ~mode:[Open_binary] (Unit_info.Artifact.filename target) @@ -712,7 +465,7 @@ let save_cmt target binary_annots initial_env cmi shape = if !Clflags.store_occurrences then index_occurrences binary_annots else - [] + [| |] in let cmt_annots = clear_env binary_annots in let cmt_uid_to_decl = index_declarations cmt_annots in @@ -727,25 +480,9 @@ let save_cmt target binary_annots initial_env cmi shape = Array.sort compare_imports imports; imports in - let cmt_ident_occurrences = - if !Clflags.store_occurrences then - index_occurrences binary_annots - else - Array.of_list [] - in - let cmt_annots = clear_env binary_annots in - let cmt_uid_to_decl = index_declarations cmt_annots in let cmt = { -<<<<<<< HEAD - cmt_modname = modname; - cmt_annots; -||||||| 121bedcfd2 - cmt_modname = modname; - cmt_annots = clear_env binary_annots; -======= - cmt_modname = Unit_info.Artifact.modname target; + cmt_modname = cu; cmt_annots; ->>>>>>> 5.2.0 cmt_value_dependencies = !value_deps; cmt_comments = Lexer.comments (); cmt_args = Sys.argv;