Skip to content

Commit

Permalink
Refactor type_descriptions in the typing env
Browse files Browse the repository at this point in the history 
For new datatype definitions the typer records "declarations",
which are mostly direct information obtained from the program source,
and "descriptions", which contains lower-level, computed information
on data representation (constructor tags, record field offsets).

Before this PR, the type used to define datatype descriptions was

   type type_descriptions =
     constructor_description list * label_description list

which basically assumes that a datatype may have both constructors and labels, which is nonsensical.

The current refactoring uses a variant instead of a product here,
following the existing structure of the 'type_kind' field of
declarations. This avoids having to use empty lists in impossible
configurations, and makes the code less surprising.
  • Loading branch information
Nicolas Chataing committed May 6, 2021
1 parent 6275c0c commit 3cccfa5
Show file tree
Hide file tree
Showing 9 changed files with 174 additions and 127 deletions.
4 changes: 4 additions & 0 deletions Changes
View file
Expand Up @@ -334,6 +334,10 @@ Working version
- #8936: Per-function environment for Emit
(Greta Yorsh, review by Vincent Laviron and Florian Angeletti)

- #10307: Refactor type_description in the typing env
(Nicolas Chataing, review by Takafumi Saikawa, Florian Angeletti and Thomas
Refis)

### Build system:

- #9191, #10091, #10182: take the LDFLAGS variable into account, except on
Expand Down
2 changes: 1 addition & 1 deletion ocamldoc/odoc_sig.mli
View file
Expand Up @@ -164,7 +164,7 @@ module Analyser :
by associating the comment found in the parsetree of each constructor/field, if any.*)
val get_type_kind :
Odoc_env.env -> (string * Odoc_types.info option) list ->
Types.type_kind -> Odoc_type.type_kind
Types.type_decl_kind -> Odoc_type.type_kind

(** This function converts a [Types.constructor_arguments] into a
[Odoc_type.constructor_args], by associating the comment found
Expand Down
2 changes: 1 addition & 1 deletion typing/btype.ml
View file
Expand Up @@ -348,7 +348,7 @@ type type_iterators =
it_functor_param: type_iterators -> functor_parameter -> unit;
it_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> unit;
it_type_kind: type_iterators -> type_decl_kind -> unit;
it_do_type_expr: type_iterators -> type_expr -> unit;
it_type_expr: type_iterators -> type_expr -> unit;
it_path: Path.t -> unit; }
Expand Down
4 changes: 2 additions & 2 deletions typing/btype.mli
View file
Expand Up @@ -127,7 +127,7 @@ type type_iterators =
it_functor_param: type_iterators -> functor_parameter -> unit;
it_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> unit;
it_type_kind: type_iterators -> type_decl_kind -> unit;
it_do_type_expr: type_iterators -> type_expr -> unit;
it_type_expr: type_iterators -> type_expr -> unit;
it_path: Path.t -> unit; }
Expand Down Expand Up @@ -268,7 +268,7 @@ val set_commu: commutable ref -> commutable -> unit
(**** Forward declarations ****)
val print_raw: (Format.formatter -> type_expr -> unit) ref

val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit)
val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit)

val iter_type_expr_cstr_args: (type_expr -> unit) ->
(constructor_arguments -> unit)
Expand Down
241 changes: 140 additions & 101 deletions typing/env.ml
View file
Expand Up @@ -479,8 +479,10 @@ module IdTbl =

end

type type_descriptions =
constructor_description list * label_description list
type type_descr_kind =
(label_description, constructor_description) type_kind

type type_descriptions = type_descr_kind

let in_signature_flag = 0x01

Expand Down Expand Up @@ -1083,27 +1085,39 @@ let type_of_cstr path = function
let labels =
List.map snd (Datarepr.labels_of_type path decl)
in
{ tda_declaration = decl; tda_descriptions = ([], labels) }
| _ ->
assert false
begin match decl.type_kind with
| Type_record (_, repr) ->
{
tda_declaration = decl;
tda_descriptions = Type_record (labels, repr);
}
| _ -> assert false
end
| _ -> assert false

let find_type_full path env =
let find_type_data path env =
match Path.constructor_typath path with
| Regular p -> begin
match Path.Map.find p env.local_constraints with
| decl ->
{ tda_declaration = decl; tda_descriptions = [], [] }
{ tda_declaration = decl; tda_descriptions = Type_abstract }
| exception Not_found -> find_type_full p env
end
| Cstr (ty_path, s) ->
(* This case corresponds to an inlined record *)
let tda =
try find_type_full ty_path env
with Not_found -> assert false
in
let (cstrs, _) = tda.tda_descriptions in
let cstr =
try List.find (fun cstr -> cstr.cstr_name = s) cstrs
with Not_found -> assert false
begin match tda.tda_descriptions with
| Type_variant cstrs -> begin
try
List.find (fun cstr -> cstr.cstr_name = s) cstrs
with Not_found -> assert false
end
| Type_record _ | Type_abstract | Type_open -> assert false
end
in
type_of_cstr path cstr
| LocalExt id ->
Expand All @@ -1127,9 +1141,9 @@ let find_type_full path env =
| _ -> assert false

let find_type p env =
(find_type_full p env).tda_declaration
(find_type_data p env).tda_declaration
let find_type_descrs p env =
(find_type_full p env).tda_descriptions
(find_type_data p env).tda_descriptions

let rec find_module_address path env =
match path with
Expand Down Expand Up @@ -1655,29 +1669,41 @@ let rec components_of_module_maker
let final_decl = Subst.type_declaration prefixing_sub fresh_decl in
Btype.set_row_name final_decl
(Subst.type_path prefixing_sub (Path.Pident id));
let constructors =
List.map snd
(Datarepr.constructors_of_type ~current_unit:(get_unit_name ())
path final_decl)
let descrs =
match decl.type_kind with
| Type_variant _ ->
let cstrs = List.map snd
(Datarepr.constructors_of_type path final_decl
~current_unit:(get_unit_name ()))
in
List.iter
(fun descr ->
let cda = {
cda_description = descr;
cda_address = None }
in
c.comp_constrs <-
add_to_tbl descr.cstr_name cda c.comp_constrs
) cstrs;
Type_variant cstrs
| Type_record (_, repr) ->
let lbls = List.map snd
(Datarepr.labels_of_type path final_decl)
in
List.iter
(fun descr ->
c.comp_labels <-
add_to_tbl descr.lbl_name descr c.comp_labels)
lbls;
Type_record (lbls, repr)
| Type_abstract -> Type_abstract
| Type_open -> Type_open
in
let labels =
List.map snd (Datarepr.labels_of_type path final_decl) in
let tda =
{ tda_declaration = final_decl;
tda_descriptions = (constructors, labels); }
tda_descriptions = descrs; }
in
c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types;
List.iter
(fun descr ->
let cda = { cda_description = descr; cda_address = None } in
c.comp_constrs <-
add_to_tbl descr.cstr_name cda c.comp_constrs)
constructors;
List.iter
(fun descr ->
c.comp_labels <-
add_to_tbl descr.lbl_name descr c.comp_labels)
labels;
env := store_type_infos id fresh_decl !env
| Sig_typext(id, ext, _, _) ->
let ext' = Subst.extension_constructor sub ext in
Expand Down Expand Up @@ -1812,77 +1838,88 @@ and store_type ~check id info env =
(fun s -> Warnings.Unused_type_declaration s)
!type_declarations;
let path = Pident id in
let constructors =
Datarepr.constructors_of_type path info
~current_unit:(get_unit_name ())
let descrs, env =
match info.type_kind with
| Type_variant _ ->
let constructors = Datarepr.constructors_of_type path info
~current_unit:(get_unit_name ())
in
if check && not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_constructor ("", Unused))
then begin
let ty_name = Ident.name id in
let priv = info.type_private in
List.iter
begin fun (_, cstr) ->
let name = cstr.cstr_name in
let loc = cstr.cstr_loc in
let k = cstr.cstr_uid in
if not (Types.Uid.Tbl.mem !used_constructors k) then
let used = constructor_usages () in
Types.Uid.Tbl.add !used_constructors k
(add_constructor_usage used);
if not (ty_name = "" || ty_name.[0] = '_')
then !add_delayed_check_forward
(fun () ->
Option.iter
(fun complaint ->
if not (is_in_signature env) then
Location.prerr_warning loc
(Warnings.Unused_constructor(name, complaint)))
(constructor_usage_complaint ~rebind:false priv used))
end
constructors
end;
Type_variant (List.map snd constructors),
{ env with
constrs =
List.fold_right
(fun (id, descr) constrs ->
let cda = { cda_description = descr; cda_address = None } in
TycompTbl.add id cda constrs)
constructors env.constrs;
}
| Type_record (_, repr) ->
let labels = Datarepr.labels_of_type path info in
if check && not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_field ("", Unused))
then begin
let ty_name = Ident.name id in
let priv = info.type_private in
List.iter
begin fun (_, lbl) ->
let name = lbl.lbl_name in
let loc = lbl.lbl_loc in
let mut = lbl.lbl_mut in
let k = lbl.lbl_uid in
if not (Types.Uid.Tbl.mem !used_labels k) then
let used = label_usages () in
Types.Uid.Tbl.add !used_labels k
(add_label_usage used);
if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_')
then !add_delayed_check_forward
(fun () ->
Option.iter
(fun complaint ->
if not (is_in_signature env) then
Location.prerr_warning
loc (Warnings.Unused_field(name, complaint)))
(label_usage_complaint priv mut used))
end
labels
end;
Type_record (List.map snd labels, repr),
{ env with
labels =
List.fold_right
(fun (id, descr) labels -> TycompTbl.add id descr labels)
labels env.labels;
}
| Type_abstract -> Type_abstract, env
| Type_open -> Type_open, env
in
let labels = Datarepr.labels_of_type path info in
let descrs = (List.map snd constructors, List.map snd labels) in
let tda = { tda_declaration = info; tda_descriptions = descrs } in
if check && not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_constructor ("", Unused))
then begin
let ty_name = Ident.name id in
let priv = info.type_private in
List.iter
begin fun (_, cstr) ->
let name = cstr.cstr_name in
let loc = cstr.cstr_loc in
let k = cstr.cstr_uid in
if not (Types.Uid.Tbl.mem !used_constructors k) then
let used = constructor_usages () in
Types.Uid.Tbl.add !used_constructors k
(add_constructor_usage used);
if not (ty_name = "" || ty_name.[0] = '_')
then !add_delayed_check_forward
(fun () ->
Option.iter
(fun complaint ->
if not (is_in_signature env) then
Location.prerr_warning loc
(Warnings.Unused_constructor(name, complaint)))
(constructor_usage_complaint ~rebind:false priv used))
end
constructors
end;
if check && not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_field ("", Unused))
then begin
let ty_name = Ident.name id in
let priv = info.type_private in
List.iter
begin fun (_, lbl) ->
let name = lbl.lbl_name in
let loc = lbl.lbl_loc in
let mut = lbl.lbl_mut in
let k = lbl.lbl_uid in
if not (Types.Uid.Tbl.mem !used_labels k) then
let used = label_usages () in
Types.Uid.Tbl.add !used_labels k
(add_label_usage used);
if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_')
then !add_delayed_check_forward
(fun () ->
Option.iter
(fun complaint ->
if not (is_in_signature env) then
Location.prerr_warning
loc (Warnings.Unused_field(name, complaint)))
(label_usage_complaint priv mut used))
end
labels
end;
{ env with
constrs =
List.fold_right
(fun (id, descr) constrs ->
let cda = { cda_description = descr; cda_address = None } in
TycompTbl.add id cda constrs)
constructors env.constrs;
labels =
List.fold_right
(fun (id, descr) labels -> TycompTbl.add id descr labels)
labels env.labels;
types = IdTbl.add id tda env.types;
summary = Env_type(env.summary, id, info) }

Expand All @@ -1892,7 +1929,7 @@ and store_type_infos id info env =
manifest-ness of the type. Used in components_of_module to
keep track of type abbreviations (e.g. type t = float) in the
computation of label representations. *)
let tda = { tda_declaration = info; tda_descriptions = [], [] } in
let tda = { tda_declaration = info; tda_descriptions = Type_abstract } in
{ env with
types = IdTbl.add id tda env.types;
summary = Env_type(env.summary, id, info) }
Expand Down Expand Up @@ -2882,7 +2919,8 @@ let lookup_label ~errors ~use ~loc usage lid env =
let lookup_all_labels_from_type ~use ~loc usage ty_path env =
match find_type_descrs ty_path env with
| exception Not_found -> []
| (_, lbls) ->
| Type_variant _ | Type_abstract | Type_open -> []
| Type_record (lbls, _) ->
List.map
(fun lbl ->
let use_fun () = use_label ~use ~loc usage env lbl in
Expand All @@ -2903,7 +2941,8 @@ let lookup_constructor ~errors ~use ~loc usage lid env =
let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
match find_type_descrs ty_path env with
| exception Not_found -> []
| (cstrs, _) ->
| Type_record _ | Type_abstract | Type_open -> []
| Type_variant cstrs ->
List.map
(fun cstr ->
let use_fun () =
Expand Down
7 changes: 5 additions & 2 deletions typing/env.mli
View file
Expand Up @@ -57,8 +57,11 @@ val initial_safe_string: t
val initial_unsafe_string: t
val diff: t -> t -> Ident.t list

type type_descriptions =
constructor_description list * label_description list
type type_descr_kind =
(label_description, constructor_description) type_kind

(* alias for compatibility *)
type type_descriptions = type_descr_kind

(* For short-paths *)
type iter_cont
Expand Down

0 comments on commit 3cccfa5

Please sign in to comment.