Skip to content

Commit

Permalink
Use const sorts in variant/record representations
Browse files Browse the repository at this point in the history
  • Loading branch information
goldfirere committed Nov 12, 2024
1 parent fbeb158 commit ab43d23
Show file tree
Hide file tree
Showing 13 changed files with 202 additions and 268 deletions.
50 changes: 20 additions & 30 deletions lambda/matching.ml
Original file line number Diff line number Diff line change
Expand Up @@ -104,17 +104,15 @@ exception Error of Location.t * error

let dbg = false

let jkind_layout_default_to_value_and_check_not_void loc jkind =
let rec contains_void : Jkind.Layout.Const.t -> bool = function
| Any -> false
let sort_check_not_void loc sort =
let rec contains_void : Jkind.Sort.Const.t -> bool = function
| Base Void -> true
| Base (Value | Float64 | Float32 | Word | Bits32 | Bits64 | Vec128) -> false
| Product [] ->
Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void"
| Product ts -> List.exists contains_void ts
Misc.fatal_error "nil in sort_check_not_void"
| Product ss -> List.exists contains_void ss
in
let layout = Jkind.get_layout_defaulting_to_value jkind in
if contains_void layout then
if contains_void sort then
raise (Error (loc, Void_layout))
;;

Expand Down Expand Up @@ -1877,9 +1875,7 @@ let get_pat_args_constr p rem =
match p with
| { pat_desc = Tpat_construct (_, {cstr_args}, args, _) } ->
List.iter2
(fun { ca_jkind } arg ->
jkind_layout_default_to_value_and_check_not_void
arg.pat_loc ca_jkind)
(fun { ca_sort } arg -> sort_check_not_void arg.pat_loc ca_sort)
cstr_args args;
(* CR layouts v5: This sanity check will have to go (or be replaced with a
void-specific check) when we have other non-value sorts *)
Expand All @@ -1895,12 +1891,11 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
let loc = head_loc ~scopes head in
(* CR layouts v5: This sanity check should be removed or changed to
specifically check for void when we add other non-value sorts. *)
List.iter (fun { ca_jkind } ->
jkind_layout_default_to_value_and_check_not_void head.pat_loc ca_jkind)
List.iter (fun { ca_sort } -> sort_check_not_void head.pat_loc ca_sort)
cstr.cstr_args;
let ubr = Translmode.transl_unique_barrier (head.pat_unique_barrier) in
let sem = add_barrier_to_read ubr Reads_agree in
let make_field_access binding_kind jkind ~field ~pos =
let make_field_access binding_kind sort ~field ~pos =
let prim =
match cstr.cstr_shape with
| Constructor_uniform_value -> Pfield (pos, Pointer, sem)
Expand All @@ -1922,8 +1917,6 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
let shape = Lambda.transl_mixed_product_shape shape in
Pmixedfield (pos, read, shape, sem)
in
let sort = Jkind.sort_of_jkind jkind in
let sort = Jkind.Sort.default_for_transl_and_get sort in
let layout = Typeopt.layout_of_sort head.pat_loc sort in
(Lprim (prim, [ arg ], loc), binding_kind, sort, layout)
in
Expand All @@ -1934,15 +1927,15 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
match cstr.cstr_repr with
| Variant_boxed _ ->
List.mapi
(fun i { ca_jkind } ->
make_field_access str ca_jkind ~field:i ~pos:i)
(fun i { ca_sort } ->
make_field_access str ca_sort ~field:i ~pos:i)
cstr.cstr_args
@ rem
| Variant_unboxed -> (arg, str, sort, layout) :: rem
| Variant_extensible ->
List.mapi
(fun i { ca_jkind } ->
make_field_access str ca_jkind ~field:i ~pos:(i+1))
(fun i { ca_sort } ->
make_field_access str ca_sort ~field:i ~pos:(i+1))
cstr.cstr_args
@ rem

Expand Down Expand Up @@ -2264,7 +2257,7 @@ let record_matching_line num_fields lbl_pat_list =
List.iter (fun (_, lbl, pat) ->
(* CR layouts v5: This void sanity check can be removed when we add proper
void support (or whenever we remove `lbl_pos_void`) *)
jkind_layout_default_to_value_and_check_not_void pat.pat_loc lbl.lbl_jkind;
sort_check_not_void pat.pat_loc lbl.lbl_sort;
patv.(lbl.lbl_pos) <- pat)
lbl_pat_list;
Array.to_list patv
Expand All @@ -2291,12 +2284,9 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
rem
else
let lbl = all_labels.(pos) in
jkind_layout_default_to_value_and_check_not_void
head.pat_loc lbl.lbl_jkind;
sort_check_not_void head.pat_loc lbl.lbl_sort;
let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl_sort in
let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort in
let sem =
if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree
in
Expand All @@ -2307,21 +2297,21 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
| Record_boxed _
| Record_inlined (_, Constructor_uniform_value, Variant_boxed _) ->
Lprim (Pfield (lbl.lbl_pos, ptr, sem), [ arg ], loc),
lbl_sort, lbl_layout
lbl.lbl_sort, lbl_layout
| Record_unboxed
| Record_inlined (_, _, Variant_unboxed) -> arg, sort, layout
| Record_float ->
(* TODO: could optimise to Alloc_local sometimes *)
Lprim (Pfloatfield (lbl.lbl_pos, sem, alloc_heap), [ arg ], loc),
(* Here we are projecting a boxed float from a float record. *)
lbl_sort, lbl_layout
lbl.lbl_sort, lbl_layout
| Record_ufloat ->
Lprim (Pufloatfield (lbl.lbl_pos, sem), [ arg ], loc),
(* Here we are projecting an unboxed float from a float record. *)
lbl_sort, lbl_layout
lbl.lbl_sort, lbl_layout
| Record_inlined (_, Constructor_uniform_value, Variant_extensible) ->
Lprim (Pfield (lbl.lbl_pos + 1, ptr, sem), [ arg ], loc),
lbl_sort, lbl_layout
lbl.lbl_sort, lbl_layout
| Record_inlined (_, Constructor_mixed _, Variant_extensible) ->
(* CR layouts v5.9: support this *)
fatal_error
Expand All @@ -2348,7 +2338,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
{ value_prefix_len; flat_suffix }
in
Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [ arg ], loc),
lbl_sort, lbl_layout
lbl.lbl_sort, lbl_layout
in
let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in
let str = add_barrier_to_let_kind ubr str in
Expand Down
34 changes: 9 additions & 25 deletions lambda/translcore.ml
Original file line number Diff line number Diff line change
Expand Up @@ -525,11 +525,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
of_location ~scopes e.exp_loc)
| Texp_construct(_, cstr, args, alloc_mode) ->
let args_with_sorts =
List.map2 (fun { ca_jkind } e ->
let sort = Jkind.sort_of_jkind ca_jkind in
let sort = Jkind.Sort.default_for_transl_and_get sort in
e, sort)
cstr.cstr_args args
List.map2 (fun { ca_sort } e -> e, ca_sort) cstr.cstr_args args
in
let ll =
List.map (fun (e, sort) -> transl_exp ~scopes sort e) args_with_sorts
Expand Down Expand Up @@ -641,9 +637,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree
in
let sem = add_barrier_to_read (transl_unique_barrier ubr) sem in
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
check_record_field_sort id.loc lbl_sort;
check_record_field_sort id.loc lbl.lbl_sort;
begin match lbl.lbl_repres with
Record_boxed _
| Record_inlined (_, Constructor_uniform_value, Variant_boxed _) ->
Expand Down Expand Up @@ -703,9 +697,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
representability on construction, [sort_of_jkind] will be unsafe here.
Probably we should add a sort to `Texp_setfield` in the typed tree,
then. *)
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
check_record_field_sort id.loc lbl_sort;
check_record_field_sort id.loc lbl.lbl_sort;
let mode =
Assignment (transl_modify_mode arg_mode)
in
Expand Down Expand Up @@ -743,7 +735,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
end
in
Lprim(access, [transl_exp ~scopes Jkind.Sort.Const.for_record arg;
transl_exp ~scopes lbl_sort newval],
transl_exp ~scopes lbl.lbl_sort newval],
of_location ~scopes e.exp_loc)
| Texp_array (amut, element_sort, expr_list, alloc_mode) ->
let mode = transl_alloc_mode alloc_mode in
Expand Down Expand Up @@ -1842,9 +1834,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
let copy_id = Ident.create_local "newrecord" in
let update_field cont (lbl, definition) =
(* CR layouts v5: allow more unboxed types here. *)
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
check_record_field_sort lbl.lbl_loc lbl_sort;
check_record_field_sort lbl.lbl_loc lbl.lbl_sort;
match definition with
| Kept _ -> cont
| Overridden (_lid, expr) ->
Expand Down Expand Up @@ -1891,7 +1881,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
end
in
Lsequence(Lprim(upd, [Lvar copy_id;
transl_exp ~scopes lbl_sort expr],
transl_exp ~scopes lbl.lbl_sort expr],
of_location ~scopes loc),
cont)
in
Expand All @@ -1909,15 +1899,9 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
let lv =
Array.mapi
(fun i (lbl, definition) ->
(* CR layouts v2.5: When we allow `any` in record fields and check
representability on construction, [sort_of_layout] will be unsafe
here. Probably we should add sorts to record construction in the
typed tree, then. *)
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
match definition with
| Kept (typ, mut, _) ->
let field_layout = layout env lbl.lbl_loc lbl_sort typ in
let field_layout = layout env lbl.lbl_loc lbl.lbl_sort typ in
let sem =
if Types.is_mutable mut then Reads_vary else Reads_agree
in
Expand Down Expand Up @@ -1973,8 +1957,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
of_location ~scopes loc),
field_layout
| Overridden (_lid, expr) ->
let field_layout = layout_exp lbl_sort expr in
transl_exp ~scopes lbl_sort expr, field_layout)
let field_layout = layout_exp lbl.lbl_sort expr in
transl_exp ~scopes lbl.lbl_sort expr, field_layout)
fields
in
let ll, shape = List.split (Array.to_list lv) in
Expand Down
2 changes: 1 addition & 1 deletion ocamldoc/odoc_sig.ml
Original file line number Diff line number Diff line change
Expand Up @@ -493,7 +493,7 @@ module Analyser =
{ Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
get_field env comments @@
{Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Value.Const.id;
ld_jkind=Jkind.Builtin.any ~why:Dummy_jkind (* ignored *);
ld_sort=Jkind.Sort.Const.void (* ignored *);
ld_type=ld_type.Typedtree.ctyp_type;
ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
let open Typedtree in
Expand Down
22 changes: 7 additions & 15 deletions toplevel/genprintval.ml
Original file line number Diff line number Diff line change
Expand Up @@ -249,16 +249,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
| Print_as_value (* can interpret as a value and print *)
| Print_as of string (* can't print *)

let get_and_default_jkind_for_printing jkind =
let layout = Jkind.get_layout_defaulting_to_value jkind in
match layout with
(* CR layouts v3.0: [Value_or_null] should probably require special
printing to avoid descending into NULL. (This module uses
lots of unsafe Obj features.)
*)
let print_sort : Jkind.Sort.Const.t -> _ = function
| Base Value -> Print_as_value
| Base Void -> Print_as "<void>"
| Any -> Print_as "<any>"
| Base (Float64 | Float32 | Bits32 | Bits64 | Vec128 | Word) -> Print_as "<abstr>"
| Product _ -> Print_as "<unboxed product>"

Expand Down Expand Up @@ -457,9 +450,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
instantiate_types env type_params ty_list l in
let ty_args =
List.map2
(fun { ca_jkind } ty_arg ->
(ty_arg,
get_and_default_jkind_for_printing ca_jkind)
(fun { ca_sort } ty_arg ->
(ty_arg, print_sort ca_sort)
) l ty_args
in
tree_of_constr_with_args (tree_of_constr env path)
Expand Down Expand Up @@ -564,12 +556,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
lbl_list pos obj rep =
let rec tree_of_fields first pos = function
| [] -> []
| {ld_id; ld_type; ld_jkind} :: remainder ->
| {ld_id; ld_type; ld_sort} :: remainder ->
let ty_arg = instantiate_type env type_params ty_list ld_type in
let name = Ident.name ld_id in
(* PR#5722: print full module path only
for first record field *)
let is_void = Jkind.is_void_defaulting ld_jkind in
let is_void = Jkind.Sort.Const.(equal void ld_sort) in
let lid =
if first then tree_of_label env path (Out_name.create name)
else Oide_ident (Out_name.create name)
Expand Down Expand Up @@ -699,8 +691,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
| _ -> assert false
in
let args = instantiate_types env type_params ty_list cstr.cstr_args in
let args = List.map2 (fun { ca_jkind } arg ->
(arg, get_and_default_jkind_for_printing ca_jkind))
let args = List.map2 (fun { ca_sort } arg ->
(arg, print_sort ca_sort))
cstr.cstr_args args
in
tree_of_constr_with_args
Expand Down
22 changes: 11 additions & 11 deletions typing/datarepr.ml
Original file line number Diff line number Diff line change
Expand Up @@ -70,7 +70,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep =
in
let type_params = TypeSet.elements arg_vars_set in
let arity = List.length type_params in
let is_void_label lbl = Jkind.is_void_defaulting lbl.ld_jkind in
let is_void_label lbl = Jkind.Sort.Const.(equal void lbl.ld_sort) in
let jkind =
Jkind.for_boxed_record ~all_void:(List.for_all is_void_label lbls)
in
Expand All @@ -97,7 +97,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep =
[
{
ca_type = newgenconstr path type_params;
ca_jkind = jkind;
ca_sort = Jkind.Sort.Const.value;
ca_modalities = Mode.Modality.Value.Const.id;
ca_loc = Location.none
}
Expand All @@ -112,19 +112,19 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep =
| Variant_boxed x, _ -> x
| Variant_unboxed, [{ cd_args }] ->
begin match cd_args with
| Cstr_tuple [{ ca_jkind = jkind }]
| Cstr_record [{ ld_jkind = jkind }] ->
[| Constructor_uniform_value, [| jkind |] |]
| Cstr_tuple [{ ca_sort = sort }]
| Cstr_record [{ ld_sort = sort }] ->
[| Constructor_uniform_value, [| sort |] |]
| _ -> Misc.fatal_error "Multiple arguments in [@@unboxed] variant"
end
| _ -> Misc.fatal_error "Multiple constructors in [@@unboxed] variant"
in
let all_void jkinds = Array.for_all Jkind.is_void_defaulting jkinds in
let all_void sorts = Array.for_all Jkind.Sort.Const.(equal void) sorts in
let num_consts = ref 0 and num_nonconsts = ref 0 in
let cstr_constant =
Array.map
(fun (_, jkinds) ->
let all_void = all_void jkinds in
(fun (_, sorts) ->
let all_void = all_void sorts in
if all_void then incr num_consts else incr num_nonconsts;
all_void)
cstr_shapes_and_arg_jkinds
Expand Down Expand Up @@ -213,7 +213,7 @@ let none =
let dummy_label =
{ lbl_name = ""; lbl_res = none; lbl_arg = none;
lbl_mut = Immutable; lbl_modalities = Mode.Modality.Value.Const.id;
lbl_jkind = Jkind.Builtin.any ~why:Dummy_jkind;
lbl_sort = Jkind.Sort.Const.void;
lbl_num = -1; lbl_pos = -1; lbl_all = [||];
lbl_repres = Record_unboxed;
lbl_private = Public;
Expand All @@ -227,14 +227,14 @@ let label_descrs ty_res lbls repres priv =
let rec describe_labels num pos = function
[] -> []
| l :: rest ->
let is_void = Jkind.is_void_defaulting l.ld_jkind in
let is_void = Jkind.Sort.Const.(equal void l.ld_sort) in
let lbl =
{ lbl_name = Ident.name l.ld_id;
lbl_res = ty_res;
lbl_arg = l.ld_type;
lbl_mut = l.ld_mutable;
lbl_modalities = l.ld_modalities;
lbl_jkind = l.ld_jkind;
lbl_sort = l.ld_sort;
lbl_pos = if is_void then lbl_pos_void else pos;
lbl_num = num;
lbl_all = all_labels;
Expand Down
Loading

0 comments on commit ab43d23

Please sign in to comment.