Skip to content

Commit

Permalink
Unboxed records (ocaml-flambda#3229)
Browse files Browse the repository at this point in the history
  • Loading branch information
@rtjoa
rtjoa authored Dec 5, 2024
1 parent 75bbb0b commit d330dfe
Show file tree
Hide file tree
Showing 100 changed files with 6,951 additions and 722 deletions.
6 changes: 6 additions & 0 deletions chamelon/minimizer/flatteningmodules.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -102,6 +102,12 @@ let rec replace_in_pat : type k. _ -> k general_pattern -> k general_pattern =
(fun (e1, e2, pat) -> (e1, e2, replace_in_pat mod_name pat))
r,
a1 )
| O (Tpat_record_unboxed_product (r, a1)) ->
Tpat_record_unboxed_product
( List.map
(fun (e1, e2, pat) -> (e1, e2, replace_in_pat mod_name pat))
r,
a1 )
| O (Tpat_or (p1, p2, a1)) ->
Tpat_or (replace_in_pat mod_name p1, replace_in_pat mod_name p2, a1)
| O (Tpat_lazy pat) -> Tpat_lazy (replace_in_pat mod_name pat)
Expand Down
13 changes: 13 additions & 0 deletions chamelon/minimizer/removedeadcode.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -85,6 +85,8 @@ let rec var_from_pat pat_desc acc =
(List.map (fun (_, pat, _) -> pat) fields)
| O (Tpat_record (r, _)) ->
List.fold_left (fun l (_, _, pat) -> var_from_pat pat.pat_desc l) acc r
| O (Tpat_record_unboxed_product (r, _)) ->
List.fold_left (fun l (_, _, pat) -> var_from_pat pat.pat_desc l) acc r
| O (Tpat_or (p1, p2, _)) ->
var_from_pat p1.pat_desc (var_from_pat p2.pat_desc acc)
| O (Tpat_lazy pat) -> var_from_pat pat.pat_desc acc
Expand Down Expand Up @@ -150,6 +152,17 @@ let rec rem_in_pat str pat should_remove =
r,
a1 );
}
| O (Tpat_record_unboxed_product (r, a1)) ->
{
pat with
pat_desc =
Tpat_record_unboxed_product
( List.map
(fun (e1, e2, pat) ->
(e1, e2, rem_in_pat str pat should_remove))
r,
a1 );
}
| O (Tpat_or (p1, p2, a1)) ->
let p1 = rem_in_pat str p1 should_remove in
let p2 = rem_in_pat str p2 should_remove in
Expand Down
43 changes: 43 additions & 0 deletions chamelon/minimizer/simplifytypes.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -80,6 +80,27 @@ let remove_cons_mapper (cons_to_rem, cons_typ) =
};
}
:: l
| Tpat_record_unboxed_product (lab_list, flag)
->
let nlab_list =
List.filter
(fun (_, ld, _) ->
ld.lbl_name = cons_to_rem)
lab_list
in
if nlab_list = [] then l
else
{
val_case with
c_lhs =
{
val_case.c_lhs with
pat_desc =
Tpat_record_unboxed_product
(nlab_list, flag);
};
}
:: l
| _ ->
Tast_mapper.default.case mapper val_case
:: l)
Expand Down Expand Up @@ -127,6 +148,28 @@ let remove_cons_mapper (cons_to_rem, cons_typ) =
};
}
:: l
| Tpat_record_unboxed_product (lab_list, flag)
->
let nlab_list =
List.filter
(fun (_, ld, _) ->
ld.lbl_name = cons_to_rem)
lab_list
in
if nlab_list = [] then l
else
{
comp_case with
c_lhs =
as_computation_pattern
{
comp_case.c_lhs with
pat_desc =
Tpat_record_unboxed_product
(nlab_list, flag);
};
}
:: l
| _ ->
Tast_mapper.default.case mapper comp_case
:: l)
Expand Down
70 changes: 40 additions & 30 deletions file_formats/cmt_format.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -167,9 +167,38 @@ let iter_on_occurrences
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 add_label ~namespace 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
Option.iter (fun path -> f ~namespace env path lid) path
in
let iter_field_exps ~namespace exp_env 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 ~namespace exp_env lid label_descr
| Overridden (lid, _) -> add_label ~namespace exp_env lid label_descr
| Kept _ -> ()) fields
in
let iter_field_pats ~namespace pat_env 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 ~namespace pat_env lid label_descr)
fields
in
let with_constraint ~env (_path, _lid, with_constraint) =
match with_constraint with
Expand All @@ -187,24 +216,15 @@ let iter_on_occurrences
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
add_label ~namespace:Label exp_env lid label_desc
| Texp_unboxed_field (_, _, lid, label_desc, _) ->
add_label ~namespace:Unboxed_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
iter_field_exps ~namespace:Label exp_env fields
| Texp_record_unboxed_product { fields ; _ } ->
iter_field_exps ~namespace:Unboxed_label exp_env fields
| Texp_instvar (_self_path, path, name) ->
let lid = { name with txt = Longident.Lident name.txt } in
f ~namespace:Value exp_env path lid
Expand Down Expand Up @@ -257,19 +277,9 @@ let iter_on_occurrences
| 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
iter_field_pats ~namespace:Label pat_env fields
| Tpat_record_unboxed_product (fields, _) ->
iter_field_pats ~namespace:Unboxed_label pat_env fields
| Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _
| Tpat_unboxed_tuple _
| Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _
Expand Down
Loading

0 comments on commit d330dfe

Please sign in to comment.