Skip to content

Make file_formats/*.ml build #294

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Jul 16, 2024
Merged

Make file_formats/*.ml build #294

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
9b51f3a
Make file_formats/*.ml build
mshinwell Jul 15, 2024
0b563e0
Review changes
mshinwell Jul 16, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
19 changes: 1 addition & 18 deletions file_formats/cmi_format.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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;
Expand All @@ -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 =
Expand Down
281 changes: 9 additions & 272 deletions file_formats/cmt_format.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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; *)
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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;
Expand Down
Loading