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
goldfirere committed Dec 13, 2024
1 parent 9b9be72 commit 05c3424
Show file tree
Hide file tree
Showing 13 changed files with 224 additions and 307 deletions.
63 changes: 24 additions & 39 deletions lambda/matching.ml
View file
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 @@ -1910,9 +1908,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 @@ -1928,12 +1924,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 @@ -1955,8 +1950,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 @@ -1967,15 +1960,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 @@ -2297,7 +2290,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 Down Expand Up @@ -2331,12 +2324,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 @@ -2347,21 +2337,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 @@ -2388,7 +2378,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 All @@ -2410,9 +2400,7 @@ let get_expr_args_record_unboxed_product ~scopes head
in
let lbl_layouts =
Array.map (fun lbl ->
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
Typeopt.layout_of_sort lbl.lbl_loc lbl_sort
Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort
) all_labels
|> Array.to_list
in
Expand All @@ -2421,8 +2409,7 @@ let get_expr_args_record_unboxed_product ~scopes head
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 access = if Array.length all_labels = 1 then
arg (* erase singleton unboxed records before lambda *)
else
Expand All @@ -2436,10 +2423,8 @@ let get_expr_args_record_unboxed_product ~scopes head
else
Alias
in
let sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let sort = Jkind.Sort.default_for_transl_and_get sort in
let layout = Typeopt.layout_of_sort lbl.lbl_loc sort in
(access, str, sort, layout) :: make_args (pos + 1)
let layout = Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort in
(access, str, lbl.lbl_sort, layout) :: make_args (pos + 1)
in
make_args 0

Expand Down
50 changes: 13 additions & 37 deletions lambda/translcore.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -527,11 +527,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 @@ -647,9 +643,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 @@ -707,11 +701,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
| Texp_unboxed_field(arg, arg_sort, _id, lbl, _) ->
begin match lbl.lbl_repres with
| Record_unboxed_product ->
let lbl_layout l =
let lbl_sort = Jkind.sort_of_jkind l.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
layout e.exp_env l.lbl_loc lbl_sort l.lbl_arg
in
let lbl_layout l = layout e.exp_env l.lbl_loc l.lbl_sort l.lbl_arg in
let layouts = Array.to_list (Array.map lbl_layout lbl.lbl_all) in
let arg_sort = Jkind.Sort.default_for_transl_and_get arg_sort in
let targ = transl_exp ~scopes arg_sort arg in
Expand All @@ -727,9 +717,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 @@ -767,7 +755,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 @@ -1888,9 +1876,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 @@ -1937,7 +1923,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 @@ -1955,15 +1941,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 @@ -2019,8 +1999,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 Expand Up @@ -2115,11 +2095,9 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr =
let shape =
Array.map
(fun (lbl, definition) ->
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, _) -> layout env lbl.lbl_loc lbl_sort typ
| Overridden (_lid, expr) -> layout_exp lbl_sort expr)
| Kept (typ, _mut, _) -> layout env lbl.lbl_loc lbl.lbl_sort typ
| Overridden (_lid, expr) -> layout_exp lbl.lbl_sort expr)
fields
|> Array.to_list
in
Expand All @@ -2131,9 +2109,7 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr =
let access = Punboxed_product_field (i, shape) in
Lprim (access, [Lvar init_id], of_location ~scopes loc)
| Overridden (_lid, expr) ->
let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in
transl_exp ~scopes lbl_sort expr)
transl_exp ~scopes lbl.lbl_sort expr)
fields
|> Array.to_list
in
Expand Down
2 changes: 1 addition & 1 deletion ocamldoc/odoc_sig.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -496,7 +496,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
28 changes: 10 additions & 18 deletions toplevel/genprintval.ml
View file
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 @@ -574,12 +566,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 @@ -619,17 +611,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
ty_list lbl_list pos obj =
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)
and v =
match get_and_default_jkind_for_printing ld_jkind with
match print_sort ld_sort with
| Print_as msg -> Oval_stuff msg
| Print_as_value ->
match lbl_list with
Expand Down Expand Up @@ -737,8 +729,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
Loading

0 comments on commit 05c3424

Please sign in to comment.