Skip to content

Commit

Permalink
Backport ocaml-flambda/flambda-backend#2029
Browse files Browse the repository at this point in the history
  • Loading branch information
@ncik-roberts
ncik-roberts committed Nov 14, 2023
1 parent 7f37a0e commit e99bf0d
Show file tree
Hide file tree
Showing 3 changed files with 148 additions and 131 deletions.
274 changes: 143 additions & 131 deletions src/ocaml/typing/printtyp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -122,6 +122,7 @@ let () = Env.print_longident := longident
module Out_name = struct
let create x = { printed_name = x }
let print x = x.printed_name
let set out_name x = out_name.printed_name <- x
end

(** Some identifiers may require hiding when printing *)
Expand All @@ -135,6 +136,8 @@ let printing_env = ref Env.empty
cmi present on the file system *)
let in_printing_env f = Env.without_cmis f !printing_env

let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n

type namespace = Shape.Sig_component_kind.t =
| Value
| Type
Expand Down Expand Up @@ -204,32 +207,15 @@ module Conflicts = struct
type explanation =
{ kind: namespace; name:string; root_name:string; location:Location.t}
let explanations = ref M.empty

let add namespace name id =
match Namespace.location (Some namespace) id with
| None -> ()
| Some location ->
let explanation =
{ kind = namespace; location; name; root_name=Ident.name id}
in
explanations := M.add name explanation !explanations

let collect_explanation namespace id ~name =
let collect_explanation namespace n id =
let name = human_unique n id in
let root_name = Ident.name id in
(* if [name] is of the form "root_name/%d", we register both
[id] and the identifier in scope for [root_name].
*)
if root_name <> name && not (M.mem name !explanations) then
begin
add namespace name id;
if not (M.mem root_name !explanations) then
(* lookup the identifier in scope with name [root_name] and
add it too
*)
match Namespace.lookup (Some namespace) root_name with
| Pident root_id -> add namespace root_name root_id
| exception Not_found | _ -> ()
end
if not (M.mem name !explanations) then
match Namespace.location (Some namespace) id with
| None -> ()
| Some location ->
let explanation = { kind = namespace; location; name; root_name } in
explanations := M.add name explanation !explanations

let pp_explanation ppf r=
Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %s@]"
Expand Down Expand Up @@ -301,30 +287,43 @@ module Naming_context = struct
let enabled = ref true
let enable b = enabled := b

(* Names bound in recursive definitions should be considered as bound
in the environment when printing identifiers but not when trying
to find shortest path.
For instance, if we define
[{
module Avoid__me = struct
type t = A
end
type t = X
type u = [` A of t * t ]
module M = struct
type t = A of [ u | `B ]
type r = Avoid__me.t
end
}]
It is is important that in the definition of [t] that the outer type [t] is
printed as [t/2] reserving the name [t] to the type being defined in the
current recursive definition.
Contrarily, in the definition of [r], one should not shorten the
path [Avoid__me.t] to [r] until the end of the definition of [r].
The [bound_in_recursion] bridges the gap between those two slightly different
notions of printing environment.
*)
let bound_in_recursion = ref M.empty
(** Name mapping *)
type mapping =
| Need_unique_name of int Ident.Map.t
(** The same name has already been attributed to multiple types.
The [map] argument contains the specific binding time attributed to each
types.
*)
| Uniquely_associated_to of Ident.t * out_name
(** For now, the name [Ident.name id] has been attributed to [id],
[out_name] is used to expand this name if a conflict arises
at a later point
*)
| Associated_to_pervasives of out_name
(** [Associated_to_pervasives out_name] is used when the item
[Stdlib.$name] has been associated to the name [$name].
Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *)

let hid_start = 0

let add_hid_id id map =
let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in
new_id, Ident.Map.add id new_id map

let find_hid id map =
try Ident.Map.find id map, map with
Not_found -> add_hid_id id map

let pervasives name = "Stdlib." ^ name

let map = Array.make Namespace.size M.empty
let get namespace = map.(Namespace.id namespace)
let set namespace x = map.(Namespace.id namespace) <- x

(* Names used in recursive definitions are not considered when determining
if a name is already attributed in the current environment.
This is a complementary version of hidden_rec_items used by short-path. *)
let protected = ref S.empty

(* When dealing with functor arguments, identity becomes fuzzy because the same
syntactic argument may be represented by different identifiers during the
Expand All @@ -336,68 +335,90 @@ let with_arg id f =
let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy

let with_hidden ids f =
let update m id = M.add (Ident.name id.ident) id.ident m in
let updated = List.fold_left update !bound_in_recursion ids in
protect_refs [ R(bound_in_recursion, updated )] f

let human_id id index =
(* The identifier with index [k] is the (k+1)-th most recent identifier in
the printing environment. We print them as [name/(k+1)] except for [k=0]
which is printed as [name] rather than [name/1].
*)
if index = 0 then
Ident.name id
else
let ordinal = index + 1 in
String.concat "/" [Ident.name id; string_of_int ordinal]

let indexed_name namespace id =
let find namespace id env = match namespace with
| Type -> Env.find_type_index id env
| Module -> Env.find_module_index id env
| Module_type -> Env.find_modtype_index id env
| Class -> Env.find_class_index id env
| Class_type-> Env.find_cltype_index id env
| Value | Extension_constructor -> None
in
let index =
match M.find_opt (Ident.name id) !bound_in_recursion with
| Some rec_bound_id ->
(* the identifier name appears in the current group of recursive
definition *)
if Ident.same rec_bound_id id then
Some 0
else
(* the current recursive definition shadows one more time the
previously existing identifier with the same name *)
Option.map succ (in_printing_env (find namespace id))
| None ->
in_printing_env (find namespace id)
in
let index =
(* If [index] is [None] at this point, it might indicate that
the identifier id is not defined in the environment, while there
are other identifiers in scope that share the same name.
Currently, this kind of partially incoherent environment happens
within functor error messages where the left and right hand side
have a different views of the environment at the source level.
Printing the source-level by using a default index of `0`
seems like a reasonable compromise in this situation however.*)
Option.value index ~default:0
in
human_id id index
let update m id = S.add (Ident.name id.ident) m in
protect_refs [ R(protected, List.fold_left update !protected ids)] f

let ident_name namespace id =
let pervasives_name namespace name =
match namespace, !enabled with
| None, _ | _, true -> Out_name.create name
| Some namespace, false ->
match M.find name (get namespace) with
| Associated_to_pervasives r -> r
| Need_unique_name _ -> Out_name.create (pervasives name)
| Uniquely_associated_to (id',r) ->
let hid, map = add_hid_id id' Ident.Map.empty in
Out_name.set r (human_unique hid id');
Conflicts.collect_explanation namespace hid id';
set namespace @@ M.add name (Need_unique_name map) (get namespace);
Out_name.create (pervasives name)
| exception Not_found ->
let r = Out_name.create name in
set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
r

(** Lookup for preexisting named item within the current {!printing_env} *)
let env_ident namespace name =
if S.mem name !protected then None else
match Namespace.lookup namespace name with
| Pident id -> Some id
| _ -> None
| exception Not_found -> None

(** Associate a name to the identifier [id] within [namespace] *)
let ident_name_simple namespace id =
match namespace, !enabled with
| None, _ | _, false -> Out_name.create (Ident.name id)
| Some namespace, true ->
if fuzzy_id namespace id then Out_name.create (Ident.name id)
else
let name = indexed_name namespace id in
Conflicts.collect_explanation namespace id ~name;
Out_name.create name
if fuzzy_id namespace id then Out_name.create (Ident.name id)
else
let name = Ident.name id in
match M.find name (get namespace) with
| Uniquely_associated_to (id',r) when Ident.same id id' ->
r
| Need_unique_name map ->
let hid, m = find_hid id map in
Conflicts.collect_explanation namespace hid id;
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| Uniquely_associated_to (id',r) ->
let hid', m = find_hid id' Ident.Map.empty in
let hid, m = find_hid id m in
Out_name.set r (human_unique hid' id');
List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id)
[id, hid; id', hid' ];
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| Associated_to_pervasives r ->
Out_name.set r ("Stdlib." ^ Out_name.print r);
let hid, m = find_hid id Ident.Map.empty in
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| exception Not_found ->
let r = Out_name.create name in
set namespace
@@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
r

(** Same as {!ident_name_simple} but lookup to existing named identifiers
in the current {!printing_env} *)
let ident_name namespace id =
begin match env_ident namespace (Ident.name id) with
| Some id' -> ignore (ident_name_simple namespace id')
| None -> ()
end;
ident_name_simple namespace id

let reset () =
Array.iteri ( fun i _ -> map.(i) <- M.empty ) map

let with_ctx f =
let old = Array.copy map in
try_finally f
~always:(fun () -> Array.blit old 0 map 0 (Array.length map))

end
let ident_name = Naming_context.ident_name
let reset_naming_context = Naming_context.reset

let ident ppf id = pp_print_string ppf
(Out_name.print (Naming_context.ident_name None id))
Expand All @@ -410,11 +431,11 @@ let namespaced_ident namespace id =

let ident_stdlib = Ident.create_persistent "Stdlib"

let non_shadowed_stdlib namespace = function
let non_shadowed_pervasive = function
| Pdot(Pident id, s) as path ->
Ident.same id ident_stdlib &&
(match Namespace.lookup namespace s with
| path' -> Path.same path path'
(match in_printing_env (Env.find_type_by_name (Lident s)) with
| (path', _) -> Path.same path path'
| exception Not_found -> true)
| _ -> false

Expand Down Expand Up @@ -497,20 +518,15 @@ let rec rewrite_double_underscore_longidents env (l : Longident.t) =
else
l

let rec tree_of_path ?(disambiguation=true) namespace p =
let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in
let namespace = if disambiguation then namespace else None in
match p with
let rec tree_of_path namespace = function
| Pident id ->
Oide_ident (ident_name namespace id)
| Pdot(_, s) as path when non_shadowed_stdlib namespace path ->
Oide_ident (Out_name.create s)
| Pdot(_, s) as path when non_shadowed_pervasive path ->
Oide_ident (Naming_context.pervasives_name namespace s)
| Pdot(p, s) ->
Oide_dot (tree_of_path (Some Module) p, s)
| Papply(p1, p2) ->
let t1 = tree_of_path (Some Module) p1 in
let t2 = tree_of_path (Some Module) p2 in
Oide_apply (t1, t2)
Oide_apply (tree_of_path (Some Module) p1, tree_of_path (Some Module) p2)
| Pextra_ty (p, extra) -> begin
(* inline record types are syntactically prevented from escaping their
binding scope, and are never shown to users. *)
Expand All @@ -521,9 +537,8 @@ let rec tree_of_path ?(disambiguation=true) namespace p =
tree_of_path None p
end

let tree_of_path ?disambiguation namespace p =
tree_of_path ?disambiguation namespace
(rewrite_double_underscore_paths !printing_env p)
let tree_of_path namespace p =
tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)

let path ppf p =
!Oprint.out_ident ppf (tree_of_path None p)
Expand All @@ -532,6 +547,7 @@ let string_of_path p =
Format.asprintf "%a" path p

let strings_of_paths namespace p =
reset_naming_context ();
let trees = List.map (tree_of_path namespace) p in
List.map (Format.asprintf "%a" !Oprint.out_ident) trees

Expand Down Expand Up @@ -687,7 +703,7 @@ let set_printing_env env =
else env

let wrap_printing_env env f =
set_printing_env (Env.update_short_paths env);
set_printing_env (Env.update_short_paths env); reset_naming_context ();
try_finally f ~always:(fun () -> set_printing_env Env.empty)

let wrap_printing_env ?error:_ env f =
Expand Down Expand Up @@ -748,13 +764,6 @@ let best_class_type_path_simple p =
then p
else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p

(* When building a tree for a best type path, we should not disambiguate
identifiers whenever the short-path algorithm detected a better path than
the original one.*)
let tree_of_best_type_path p p' =
if Path.same p p' then tree_of_path (Some Type) p'
else tree_of_path ~disambiguation:false None p'

(* Print a type expression *)

let proxy ty = Transient_expr.repr (proxy ty)
Expand Down Expand Up @@ -1127,7 +1136,7 @@ let reset_except_context () =
Names.reset_names (); reset_loop_marks ()

let reset () =
Conflicts.reset ();
reset_naming_context (); Conflicts.reset ();
reset_except_context ()

let prepare_for_printing tyl =
Expand Down Expand Up @@ -1361,7 +1370,7 @@ and tree_of_typobject mode fi nm =
| Some (p, _ty :: tyl) ->
let args = tree_of_typlist mode tyl in
let p' = best_type_path_simple p in
Otyp_class (tree_of_best_type_path p p', args)
Otyp_class (tree_of_path (Some Type) p', args)
| _ ->
fatal_error "Printtyp.tree_of_typobject"
end
Expand Down Expand Up @@ -2216,7 +2225,8 @@ and tree_of_signature_rec ?abbrev ?max_items env' sg =
| Some _ | None ->
let env = !printing_env in
let env', group_trees =
trees_of_recursive_sigitem_group ?abbrev env group
Naming_context.with_ctx
(fun () -> trees_of_recursive_sigitem_group ?abbrev env group)
in
set_printing_env env';
let max_items, group_trees = match max_items with
Expand Down Expand Up @@ -2309,6 +2319,7 @@ let modtype_declaration id ppf decl =

let print_items showval env x =
Names.refresh_weak();
reset_naming_context ();
Conflicts.reset ();
let extend_val env (sigitem,outcome) = outcome, showval env sigitem in
let post_process (env,l) = List.map (extend_val env) l in
Expand All @@ -2326,6 +2337,7 @@ let signature ppf sg =
let printed_signature sourcefile ppf sg =
(* we are tracking any collision event for warning 63 *)
Conflicts.reset ();
reset_naming_context ();
let t = tree_of_signature sg in
if Warnings.(is_active @@ Erroneous_printed_signature "")
&& Conflicts.exists ()
Expand Down
Loading

0 comments on commit e99bf0d

Please sign in to comment.