Skip to content

Commit 43d83a6

Browse files
goldfireregoldfirere
committed
Prevent possibility of forgetting to re-widen
Previously, there were separate narrow () and widen () functions that had to operate as pairs. This commit changes to use a bracketing style that means we can't forget to widen once we narrow.
1 parent 2f3dd34 commit 43d83a6

6 files changed

Lines changed: 78 additions & 86 deletions

File tree

‎typing/typeclass.ml‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1376,14 +1376,14 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
13761376
}
13771377
| Pcl_constraint (scl', scty) ->
13781378
Ctype.begin_class_def ();
1379-
Typetexp.narrow ();
1380-
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
1381-
complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
1382-
Typetexp.widen ();
1383-
Typetexp.narrow ();
1384-
let clty = class_type val_env virt self_scope scty in
1385-
complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
1386-
Typetexp.widen ();
1379+
let cl = Typetexp.narrow_in (fun () ->
1380+
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
1381+
complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
1382+
cl) in
1383+
let clty = Typetexp.narrow_in (fun () ->
1384+
let clty = class_type val_env virt self_scope scty in
1385+
complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
1386+
clty) in
13871387
Ctype.end_def ();
13881388

13891389
Ctype.limited_generalize_class_type

‎typing/typecore.ml‎

Lines changed: 51 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -4674,29 +4674,30 @@ and type_expect_
46744674
let ty = newvar() in
46754675
(* remember original level *)
46764676
begin_def ();
4677-
Typetexp.narrow ();
4678-
let modl, md_shape = !type_module env smodl in
4679-
Mtype.lower_nongen (get_level ty) modl.mod_type;
4680-
let pres =
4681-
match modl.mod_type with
4682-
| Mty_alias _ -> Mp_absent
4683-
| _ -> Mp_present
4684-
in
4685-
let scope = create_scope () in
4686-
let md =
4687-
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
4688-
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
4689-
in
4690-
let (id, new_env) =
4691-
match name.txt with
4692-
| None -> None, env
4693-
| Some name ->
4694-
let id, env =
4695-
Env.enter_module_declaration ~scope ~shape:md_shape name pres md env
4696-
in
4697-
Some id, env
4698-
in
4699-
Typetexp.widen ();
4677+
let modl, pres, id, new_env = Typetexp.narrow_in begin fun () ->
4678+
let modl, md_shape = !type_module env smodl in
4679+
Mtype.lower_nongen (get_level ty) modl.mod_type;
4680+
let pres =
4681+
match modl.mod_type with
4682+
| Mty_alias _ -> Mp_absent
4683+
| _ -> Mp_present
4684+
in
4685+
let scope = create_scope () in
4686+
let md =
4687+
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
4688+
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
4689+
in
4690+
let (id, new_env) =
4691+
match name.txt with
4692+
| None -> None, env
4693+
| Some name ->
4694+
let id, env =
4695+
Env.enter_module_declaration ~scope ~shape:md_shape name pres md env
4696+
in
4697+
Some id, env
4698+
in
4699+
modl, pres, id, new_env
4700+
end in
47004701
(* ideally, we should catch Expr_type_clash errors
47014702
in type_expect triggered by escaping identifiers from the local module
47024703
and refine them into Scoping_let_module errors
@@ -6075,33 +6076,33 @@ and type_unpacks ?(in_function : (Location.t * type_expr * bool) option)
60756076
let extended_env, tunpacks =
60766077
List.fold_left (fun (env, tunpacks) unpack ->
60776078
begin_def ();
6078-
Typetexp.narrow ();
6079-
let modl, md_shape =
6080-
!type_module env
6081-
Ast_helper.(
6082-
Mod.unpack ~loc:unpack.tu_loc
6083-
(Exp.ident ~loc:unpack.tu_name.loc
6084-
(mkloc (Longident.Lident unpack.tu_name.txt)
6085-
unpack.tu_name.loc)))
6086-
in
6087-
Mtype.lower_nongen (get_level ty) modl.mod_type;
6088-
let pres =
6089-
match modl.mod_type with
6090-
| Mty_alias _ -> Mp_absent
6091-
| _ -> Mp_present
6092-
in
6093-
let scope = create_scope () in
6094-
let md =
6095-
{ md_type = modl.mod_type; md_attributes = [];
6096-
md_loc = unpack.tu_name.loc;
6097-
md_uid = unpack.tu_uid; }
6098-
in
6099-
let (id, env) =
6100-
Env.enter_module_declaration ~scope ~shape:md_shape
6101-
unpack.tu_name.txt pres md env
6102-
in
6103-
Typetexp.widen ();
6104-
env, (id, unpack.tu_name, pres, modl) :: tunpacks
6079+
Typetexp.narrow_in begin fun () ->
6080+
let modl, md_shape =
6081+
!type_module env
6082+
Ast_helper.(
6083+
Mod.unpack ~loc:unpack.tu_loc
6084+
(Exp.ident ~loc:unpack.tu_name.loc
6085+
(mkloc (Longident.Lident unpack.tu_name.txt)
6086+
unpack.tu_name.loc)))
6087+
in
6088+
Mtype.lower_nongen (get_level ty) modl.mod_type;
6089+
let pres =
6090+
match modl.mod_type with
6091+
| Mty_alias _ -> Mp_absent
6092+
| _ -> Mp_present
6093+
in
6094+
let scope = create_scope () in
6095+
let md =
6096+
{ md_type = modl.mod_type; md_attributes = [];
6097+
md_loc = unpack.tu_name.loc;
6098+
md_uid = unpack.tu_uid; }
6099+
in
6100+
let (id, env) =
6101+
Env.enter_module_declaration ~scope ~shape:md_shape
6102+
unpack.tu_name.txt pres md env
6103+
in
6104+
env, (id, unpack.tu_name, pres, modl) :: tunpacks
6105+
end
61056106
) (env, []) unpacks
61066107
in
61076108
(* ideally, we should catch Expr_type_clash errors

‎typing/typedecl.ml‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -293,10 +293,9 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
293293
transl_constructor_arguments env None true sargs
294294
in
295295
targs, None, args, None
296-
| Some sret_type ->
297-
(* if it's a generalized constructor we must first narrow and
298-
then widen so as to not introduce any new constraints *)
299-
narrow ();
296+
| Some sret_type -> narrow_in begin fun () ->
297+
(* if it's a generalized constructor we must work in a narrowed
298+
context so as to not introduce any new constraints *)
300299
reset_type_variables ();
301300
let univars, closed =
302301
match svars with
@@ -337,8 +336,8 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
337336
Btype.iter_type_expr_cstr_args set_level args;
338337
set_level ret_type;
339338
end;
340-
widen ();
341339
targs, Some tret_type, args, Some ret_type
340+
end
342341

343342
let transl_declaration env sdecl (id, uid) =
344343
(* Bind type parameters *)

‎typing/typemod.ml‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -3037,10 +3037,11 @@ let type_package env m p fl =
30373037
(* Same as Pexp_letmodule *)
30383038
(* remember original level *)
30393039
Ctype.begin_def ();
3040-
Typetexp.narrow ();
3041-
let modl, _mod_shape = type_module env m in
3042-
let scope = Ctype.create_scope () in
3043-
Typetexp.widen ();
3040+
let modl, scope = Typetexp.narrow_in begin fun () ->
3041+
let modl, _mod_shape = type_module env m in
3042+
let scope = Ctype.create_scope () in
3043+
modl, scope
3044+
end in
30443045
let fl', env =
30453046
match fl with
30463047
| [] -> [], env

‎typing/typetexp.ml‎

Lines changed: 8 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -98,20 +98,13 @@ let reset_type_variables () =
9898
Ctype.reset_reified_var_counter ();
9999
type_variables := TyVarMap.empty
100100

101-
include (struct
102-
let type_variable_stack = Stack.create ()
103-
104-
let narrow () =
105-
Stack.push (increase_global_level (), !type_variables) type_variable_stack
106-
let widen () =
107-
let gl, tv = Stack.pop type_variable_stack in
108-
restore_global_level gl;
109-
type_variables := tv
110-
end : sig
111-
val narrow : unit -> unit
112-
val widen : unit -> unit
113-
end
114-
)
101+
let narrow_in f =
102+
let old_gl = increase_global_level () in
103+
let old_tv = !type_variables in
104+
let result = f () in
105+
restore_global_level old_gl;
106+
type_variables := old_tv;
107+
result
115108

116109
let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
117110

@@ -557,9 +550,7 @@ and transl_type_aux env policy mode styp =
557550
ctyp (Ttyp_poly (vars, cty)) ty'
558551
| Ptyp_package (p, l) ->
559552
let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
560-
narrow ();
561-
let mty = !transl_modtype env mty in
562-
widen ();
553+
let mty = narrow_in (fun () -> !transl_modtype env mty) in
563554
let ptys = List.map (fun (s, pty) ->
564555
s, transl_type env policy Alloc_mode.Global pty
565556
) l in

‎typing/typetexp.mli‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -53,8 +53,8 @@ val transl_type_param:
5353

5454
val get_alloc_mode : Parsetree.core_type -> alloc_mode_const
5555

56-
val narrow: unit -> unit
57-
val widen: unit -> unit
56+
val narrow_in: (unit -> 'a) -> 'a
57+
(* Evaluate in a narrowed type-variable scope *)
5858

5959
exception Already_bound
6060

0 commit comments

Comments
 (0)