ident: add an explicit scope field

- Ident.create now takes a scope as argument
- added Ident.create_var to use when the scope doesn't matter
- the current_time and the current_level are unrelated as of this
  commit. But one has to remember to bump the level when creating new
  scopes.

asmcomp/afl_instrument.ml

@@ -35,8 +35,8 @@ let rec with_afl_logging b =
        docs/technical_details.txt in afl-fuzz source for for a full
        description of what's going on. *)
     let cur_location = Random.int afl_map_size in
-    let cur_pos = Ident.create "pos" in
+    let cur_pos = Ident.create_var "pos" in
-    let afl_area = Ident.create "shared_mem" in
+    let afl_area = Ident.create_var "shared_mem" in
     let op oper args = Cop (oper, args, Debuginfo.none) in
     Clet(afl_area, op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr],
     Clet(cur_pos,  op Cxor [op (Cload (Word_int, Asttypes.Mutable))

asmcomp/closure.ml

@@ -861,7 +861,7 @@ let rec close fenv cenv = function
       in
       make_const (transl cst)
   | Lfunction _ as funct ->
-      close_one_function fenv cenv (Ident.create "fun") funct
+      close_one_function fenv cenv (Ident.create_var "fun") funct
 
     (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
        when fun_arity > nargs *)
@@ -884,10 +884,10 @@ let rec close fenv cenv = function
       | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
           when nargs < fundesc.fun_arity ->
         let first_args = List.map (fun arg ->
-          (Ident.create "arg", arg) ) uargs in
+          (Ident.create_var "arg", arg) ) uargs in
         let final_args =
           Array.to_list (Array.init (fundesc.fun_arity - nargs)
-                                    (fun _ -> Ident.create "arg")) in
+                                    (fun _ -> Ident.create_var "arg")) in
         let rec iter args body =
           match args with
               [] -> body
@@ -899,7 +899,7 @@ let rec close fenv cenv = function
           (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
           @ (List.map (fun arg -> Lvar arg ) final_args)
         in
-        let funct_var = Ident.create "funct" in
+        let funct_var = Ident.create_var "funct" in
         let fenv = Ident.Map.add funct_var fapprox fenv in
         let (new_fun, approx) = close fenv cenv
           (Lfunction{
@@ -923,7 +923,7 @@ let rec close fenv cenv = function
 
       | ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
-          let args = List.map (fun arg -> Ident.create "arg", arg) uargs in
+          let args = List.map (fun arg -> Ident.create_var "arg", arg) uargs in
           let (first_args, rem_args) = split_list fundesc.fun_arity args in
           let first_args = List.map (fun (id, _) -> Uvar id) first_args in
           let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in
@@ -972,7 +972,7 @@ let rec close fenv cenv = function
       then begin
         (* Simple case: only function definitions *)
         let (clos, infos) = close_functions fenv cenv defs in
-        let clos_ident = Ident.create "clos" in
+        let clos_ident = Ident.create_var "clos" in
         let fenv_body =
           List.fold_right
             (fun (id, _pos, approx) fenv -> Ident.Map.add id approx fenv)
@@ -1203,7 +1203,7 @@ and close_functions fenv cenv fun_defs =
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
   let clos_fundef (id, params, body, fundesc, dbg) env_pos =
-    let env_param = Ident.create "env" in
+    let env_param = Ident.create_var "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =

asmcomp/cmmgen.ml

@@ -64,7 +64,7 @@ let bind name arg fn =
     Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _
   | Cblockheader _ -> fn arg
-  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+  | _ -> let id = Ident.create_var name in Clet(id, arg, fn (Cvar id))
 
 let bind_load name arg fn =
   match arg with
@@ -76,7 +76,7 @@ let bind_nonvar name arg fn =
     Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _
   | Cblockheader _ -> fn arg
-  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+  | _ -> let id = Ident.create_var name in Clet(id, arg, fn (Cvar id))
 
 let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
     (* cf. runtime/caml/gc.h *)
@@ -728,7 +728,7 @@ let float_array_set arr ofs newval dbg =
 
 let string_length exp dbg =
   bind "str" exp (fun str ->
-    let tmp_var = Ident.create "tmp" in
+    let tmp_var = Ident.create_var "tmp" in
     Clet(tmp_var,
          Cop(Csubi,
              [Cop(Clsl,
@@ -770,7 +770,7 @@ let make_alloc_generic set_fn dbg tag wordsize args =
   if wordsize <= Config.max_young_wosize then
     Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
   else begin
-    let id = Ident.create "alloc" in
+    let id = Ident.create_var "alloc" in
     let rec fill_fields idx = function
       [] -> Cvar id
     | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1 dbg,
@@ -2664,7 +2664,7 @@ and transl_let env str kind id exp body =
          there may be constant closures inside that need lifting out. *)
       Clet(id, transl env exp, transl env body)
   | Boxed (boxed_number, _false) ->
-      let unboxed_id = Ident.create (Ident.name id) in
+      let unboxed_id = Ident.create_var (Ident.name id) in
       Clet(unboxed_id, transl_unbox_number dbg env boxed_number exp,
            transl (add_unboxed_id id unboxed_id boxed_number env) body)
 
@@ -3127,8 +3127,8 @@ CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
 
 let cache_public_method meths tag cache dbg =
   let raise_num = next_raise_count () in
-  let li = Ident.create "li" and hi = Ident.create "hi"
+  let li = Ident.create_var "li" and hi = Ident.create_var "hi"
-  and mi = Ident.create "mi" and tagged = Ident.create "tagged" in
+  and mi = Ident.create_var "mi" and tagged = Ident.create_var "tagged" in
   Clet (
   li, Cconst_int 3,
   Clet (
@@ -3179,16 +3179,16 @@ let cache_public_method meths tag cache dbg =
 
 let apply_function_body arity =
   let dbg = Debuginfo.none in
-  let arg = Array.make arity (Ident.create "arg") in
+  let arg = Array.make arity (Ident.create_var "arg") in
-  for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
+  for i = 1 to arity - 1 do arg.(i) <- Ident.create_var "arg" done;
-  let clos = Ident.create "clos" in
+  let clos = Ident.create_var "clos" in
   let env = empty_env in
   let rec app_fun clos n =
     if n = arity-1 then
       Cop(Capply typ_val,
           [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg)
     else begin
-      let newclos = Ident.create "clos" in
+      let newclos = Ident.create_var "clos" in
       Clet(newclos,
            Cop(Capply typ_val,
                [get_field env (Cvar clos) 0 dbg; Cvar arg.(n); Cvar clos], dbg),
@@ -3208,14 +3208,14 @@ let apply_function_body arity =
 let send_function arity =
   let dbg = Debuginfo.none in
   let (args, clos', body) = apply_function_body (1+arity) in
-  let cache = Ident.create "cache"
+  let cache = Ident.create_var "cache"
   and obj = List.hd args
-  and tag = Ident.create "tag" in
+  and tag = Ident.create_var "tag" in
   let env = empty_env in
   let clos =
     let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
-    let meths = Ident.create "meths" and cached = Ident.create "cached" in
+    let meths = Ident.create_var "meths" and cached = Ident.create_var "cached" in
-    let real = Ident.create "real" in
+    let real = Ident.create_var "real" in
     let mask = get_field env (Cvar meths) 1 dbg in
     let cached_pos = Cvar cached in
     let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg);
@@ -3267,8 +3267,8 @@ let apply_function arity =
 
 let tuplify_function arity =
   let dbg = Debuginfo.none in
-  let arg = Ident.create "arg" in
+  let arg = Ident.create_var "arg" in
-  let clos = Ident.create "clos" in
+  let clos = Ident.create_var "clos" in
   let env = empty_env in
   let rec access_components i =
     if i >= arity
@@ -3317,8 +3317,8 @@ let tuplify_function arity =
 let max_arity_optimized = 15
 let final_curry_function arity =
   let dbg = Debuginfo.none in
-  let last_arg = Ident.create "arg" in
+  let last_arg = Ident.create_var "arg" in
-  let last_clos = Ident.create "clos" in
+  let last_clos = Ident.create_var "clos" in
   let env = empty_env in
   let rec curry_fun args clos n =
     if n = 0 then
@@ -3329,13 +3329,13 @@ let final_curry_function arity =
     else
       if n = arity - 1 || arity > max_arity_optimized then
         begin
-      let newclos = Ident.create "clos" in
+      let newclos = Ident.create_var "clos" in
       Clet(newclos,
            get_field env (Cvar clos) 3 dbg,
            curry_fun (get_field env (Cvar clos) 2 dbg :: args) newclos (n-1))
         end else
         begin
-          let newclos = Ident.create "clos" in
+          let newclos = Ident.create_var "clos" in
           Clet(newclos,
                get_field env (Cvar clos) 4 dbg,
                curry_fun (get_field env (Cvar clos) 3 dbg :: args)
@@ -3357,7 +3357,7 @@ let rec intermediate_curry_functions arity num =
   else begin
     let name1 = "caml_curry" ^ string_of_int arity in
     let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in
-    let arg = Ident.create "arg" and clos = Ident.create "clos" in
+    let arg = Ident.create_var "arg" and clos = Ident.create_var "clos" in
     Cfunction
      {fun_name = name2;
       fun_args = [arg, typ_val; clos, typ_val];
@@ -3382,7 +3382,7 @@ let rec intermediate_curry_functions arity num =
       (if arity <= max_arity_optimized && arity - num > 2 then
           let rec iter i =
             if i <= arity then
-              let arg = Ident.create (Printf.sprintf "arg%d" i) in
+              let arg = Ident.create_var (Printf.sprintf "arg%d" i) in
               (arg, typ_val) :: iter (i+1)
             else []
           in
@@ -3393,7 +3393,7 @@ let rec intermediate_curry_functions arity num =
                   (get_field env (Cvar clos) 2 dbg) :: args @ [Cvar clos],
                   dbg)
             else
-              let newclos = Ident.create "clos" in
+              let newclos = Ident.create_var "clos" in
               Clet(newclos,
                    get_field env (Cvar clos) 4 dbg,
                    iter (i-1) (get_field env (Cvar clos) 3 dbg :: args) newclos)

asmcomp/flambda_to_clambda.ml

@@ -144,14 +144,14 @@ end = struct
   let ident_for_var_exn t id = Variable.Map.find id t.var
 
   let add_fresh_ident t var =
-    let id = Ident.create (Variable.name var) in
+    let id = Ident.create_var (Variable.name var) in
     id, { t with var = Variable.Map.add var id t.var }
 
   let ident_for_mutable_var_exn t mut_var =
     Mutable_variable.Map.find mut_var t.mutable_var
 
   let add_fresh_mutable_ident t mut_var =
-    let id = Ident.create (Mutable_variable.name mut_var) in
+    let id = Ident.create_var (Mutable_variable.name mut_var) in
     let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
     id, { t with mutable_var; }
 
@@ -466,7 +466,7 @@ and to_clambda_set_of_closures t env
       (({ function_decls; free_vars } : Flambda.set_of_closures)
         as set_of_closures) : Clambda.ulambda =
   let all_functions = Variable.Map.bindings function_decls.funs in
-  let env_var = Ident.create "env" in
+  let env_var = Ident.create_var "env" in
   let to_clambda_function
         (closure_id, (function_decl : Flambda.function_declaration))
         : Clambda.ufunction =

asmcomp/selectgen.ml

@@ -928,7 +928,7 @@ method private emit_parts (env:environment) ~effects_after exp =
           Some (Ctuple [], env)
         else begin
           (* The normal case *)
-          let id = Ident.create "bind" in
+          let id = Ident.create_var "bind" in
           if all_regs_anonymous r then
             (* r is an anonymous, unshared register; use it directly *)
             Some (Cvar id, env_add id r env)
@@ -1201,7 +1201,7 @@ method emit_fundecl f =
     if not Config.spacetime then None, env
     else begin
       let reg = self#regs_for typ_int in
-      let node_hole = Ident.create "spacetime_node_hole" in
+      let node_hole = Ident.create_var "spacetime_node_hole" in
       Some (node_hole, reg), env_add node_hole reg env
     end
   in

asmcomp/spacetime_profiling.ml

@@ -18,8 +18,8 @@ let index_within_node = ref node_num_header_words
    when not using Spacetime profiling.  (This could cause stamps to differ
    between bytecode and native .cmis when no .mli is present, e.g.
    arch.ml.) *)
-let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create "dummy")))
+let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create_var "dummy")))
-let spacetime_node_ident = ref (lazy (Ident.create "dummy"))
+let spacetime_node_ident = ref (lazy (Ident.create_var "dummy"))
 let current_function_label = ref ""
 let direct_tail_call_point_indexes = ref []
 
@@ -55,15 +55,15 @@ let reset ~spacetime_node_ident:ident ~function_label =
   reverse_shape := []
 
 let code_for_function_prologue ~function_name ~node_hole =
-  let node = Ident.create "node" in
+  let node = Ident.create_var "node" in
-  let new_node = Ident.create "new_node" in
+  let new_node = Ident.create_var "new_node" in
-  let must_allocate_node = Ident.create "must_allocate_node" in
+  let must_allocate_node = Ident.create_var "must_allocate_node" in
-  let is_new_node = Ident.create "is_new_node" in
+  let is_new_node = Ident.create_var "is_new_node" in
   let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
   let dbg = Debuginfo.none in
   let open Cmm in
   let initialize_direct_tail_call_points_and_return_node =
-    let new_node_encoded = Ident.create "new_node_encoded" in
+    let new_node_encoded = Ident.create_var "new_node_encoded" in
     (* The callee node pointers within direct tail call points must initially
        point back at the start of the current node and be marked as per
        [Encode_tail_caller_node] in the runtime. *)
@@ -88,7 +88,7 @@ let code_for_function_prologue ~function_name ~node_hole =
         Cop (Cor, [Cvar new_node; Cconst_int 1], dbg),
         body)
   in
-  let pc = Ident.create "pc" in
+  let pc = Ident.create_var "pc" in
   Clet (node, Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
     Clet (must_allocate_node,
       Cop (Cand, [Cvar node; Cconst_int 1], dbg),
@@ -115,10 +115,10 @@ let code_for_function_prologue ~function_name ~node_hole =
 
 let code_for_blockheader ~value's_header ~node ~dbg =
   let num_words = Nativeint.shift_right_logical value's_header 10 in
-  let existing_profinfo = Ident.create "existing_profinfo" in
+  let existing_profinfo = Ident.create_var "existing_profinfo" in
-  let existing_count = Ident.create "existing_count" in
+  let existing_count = Ident.create_var "existing_count" in
-  let profinfo = Ident.create "profinfo" in
+  let profinfo = Ident.create_var "profinfo" in
-  let address_of_profinfo = Ident.create "address_of_profinfo" in
+  let address_of_profinfo = Ident.create_var "address_of_profinfo" in
   let label = Cmm.new_label () in
   let index_within_node =
     next_index_within_node ~part_of_shape:Mach.Allocation_point ~label
@@ -216,7 +216,7 @@ let code_for_call ~node ~callee ~is_tail ~label =
         index_within_node::!direct_tail_call_point_indexes
     | Direct _ | Indirect _ -> ()
   end;
-  let place_within_node = Ident.create "place_within_node" in
+  let place_within_node = Ident.create_var "place_within_node" in
   let dbg = Debuginfo.none in
   let open Cmm in
   Clet (place_within_node,
@@ -227,8 +227,8 @@ let code_for_call ~node ~callee ~is_tail ~label =
     match callee with
     | Direct _callee ->
       if Config.enable_call_counts then begin
-        let count_addr = Ident.create "call_count_addr" in
+        let count_addr = Ident.create_var "call_count_addr" in
-        let count = Ident.create "call_count" in
+        let count = Ident.create_var "call_count" in
         Clet (count_addr,
           Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg),
           Clet (count,
@@ -276,7 +276,7 @@ class virtual instruction_selection = object (self)
       ~label_after =
     (* [callee] is a pseudoregister, so we have to bind it in the environment
        and reference the variable to which it is bound. *)
-    let callee_ident = Ident.create "callee" in
+    let callee_ident = Ident.create_var "callee" in
     let env = Selectgen.env_add callee_ident [| callee |] env in
     let instrumentation =
       code_for_call
@@ -424,7 +424,7 @@ class virtual instruction_selection = object (self)
   method! emit_fundecl f =
     if Config.spacetime then begin
       disable_instrumentation <- false;
-      let node = Ident.create "spacetime_node" in
+      let node = Ident.create_var "spacetime_node" in
       reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name
     end;
     super#emit_fundecl f

asmcomp/strmatch.ml

@@ -67,8 +67,8 @@ module Make(I:I) = struct
 
 (* Utilities *)
 
-  let gen_cell_id () = Ident.create "cell"
+  let gen_cell_id () = Ident.create_var "cell"
-  let gen_size_id () = Ident.create "size"
+  let gen_size_id () = Ident.create_var "size"
 
   let mk_let_cell id str ind body =
     let dbg = Debuginfo.none in

bytecomp/lambda.ml

@@ -437,7 +437,9 @@ let make_key e =
 let name_lambda strict arg fn =
   match arg with
     Lvar id -> fn id
-  | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id)
+  | _ ->
+      let id = Ident.create_var "let" in
+      Llet(strict, Pgenval, id, arg, fn id)
 
 let name_lambda_list args fn =
   let rec name_list names = function
@@ -445,7 +447,7 @@ let name_lambda_list args fn =
   | (Lvar _ as arg) :: rem ->
       name_list (arg :: names) rem
   | arg :: rem ->
-      let id = Ident.create "let" in
+      let id = Ident.create_var "let" in
       Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
   name_list [] args
 

bytecomp/matching.ml

@@ -694,7 +694,7 @@ let mk_alpha_env arg aliases ids =
         | Some v -> v
         | _      -> raise Cannot_flatten
       else
-        Ident.create (Ident.name id))
+        Ident.create_var (Ident.name id))
     ids
 
 let rec explode_or_pat arg patl mk_action rem vars aliases = function
@@ -1510,9 +1510,9 @@ let code_force_lazy =
 *)
 
 let inline_lazy_force_cond arg loc =
-  let idarg = Ident.create "lzarg" in
+  let idarg = Ident.create_var "lzarg" in
   let varg = Lvar idarg in
-  let tag = Ident.create "tag" in
+  let tag = Ident.create_var "tag" in
   let force_fun = Lazy.force code_force_lazy_block in
   Llet(Strict, Pgenval, idarg, arg,
        Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
@@ -1537,7 +1537,7 @@ let inline_lazy_force_cond arg loc =
                   varg))))
 
 let inline_lazy_force_switch arg loc =
-  let idarg = Ident.create "lzarg" in
+  let idarg = Ident.create_var "lzarg" in
   let varg = Lvar idarg in
   let force_fun = Lazy.force code_force_lazy_block in
   Llet(Strict, Pgenval, idarg, arg,
@@ -1756,7 +1756,7 @@ let prim_string_compare =
 let bind_sw arg k = match arg with
 | Lvar _ -> k arg
 | _ ->
-    let id = Ident.create "switch" in
+    let id = Ident.create_var "switch" in
     Llet (Strict,Pgenval,id,arg,k (Lvar id))
 
 
@@ -1949,7 +1949,7 @@ module SArg = struct
     let newvar,newarg = match arg with
     | Lvar v -> v,arg
     | _      ->
-        let newvar = Ident.create "switcher" in
+        let newvar = Ident.create_var "switcher" in
         newvar,Lvar newvar in
     bind Alias newvar arg (body newarg)
   let make_const i = Lconst (Const_base (Const_int i))
@@ -2353,7 +2353,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
         match nonconsts with
           [] -> default
         | _ ->
-            let tag = Ident.create "tag" in
+            let tag = Ident.create_var "tag" in
             let tests =
               List.fold_right
                 (fun (path, act) rem ->
@@ -2439,7 +2439,7 @@ let call_switcher_variant_constant loc fail arg int_lambda_list =
 
 
 let call_switcher_variant_constr loc fail arg int_lambda_list =
-  let v = Ident.create "variant" in
+  let v = Ident.create_var "variant" in
   Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
        call_switcher loc
          fail (Lvar v) min_int max_int int_lambda_list)
@@ -2501,7 +2501,7 @@ let combine_array loc arg kind partial ctx def
     (len_lambda_list, total1, _pats)  =
   let fail, local_jumps = mk_failaction_neg partial  ctx def in
   let lambda1 =
-    let newvar = Ident.create "len" in
+    let newvar = Ident.create_var "len" in
     let switch =
       call_switcher loc
         fail (Lvar newvar)
@@ -2704,7 +2704,7 @@ let rec name_pattern default = function
       | Tpat_alias(_, id, _) -> id
       | _ -> name_pattern default rem
       end
-  | _ -> Ident.create default
+  | _ -> Ident.create_var default
 
 let arg_to_var arg cls = match arg with
 | Lvar v -> v,arg
@@ -3198,7 +3198,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
       let next, nexts = split_precompile None pm1 in
 
       let size = List.length paraml
-      and idl = List.map (fun _ -> Ident.create "*match*") paraml in
+      and idl = List.map (fun _ -> Ident.create_var "*match*") paraml in
       let args =  List.map (fun id -> Lvar id, Alias) idl in
 
       let flat_next = flatten_precompiled size args next
@@ -3235,7 +3235,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
 
 let param_to_var param = match param with
 | Lvar v -> v,None
-| _ -> Ident.create "*match*",Some param
+| _ -> Ident.create_var "*match*",Some param
 
 let bind_opt (v,eo) k = match eo with
 | None -> k

bytecomp/simplif.ml

@@ -663,7 +663,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~body ~attr ~loc =
         let fv = Lambda.free_variables body in
         List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map;
 
-        let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
+        let inner_id = Ident.create_var (Ident.name fun_id ^ "_inner") in
         let map_param p = try List.assoc p map with Not_found -> p in
         let args = List.map (fun p -> Lvar (map_param p)) params in
         let wrapper_body =

bytecomp/translclass.ml

@@ -96,7 +96,7 @@ let bind_super tbl (vals, meths) cl_init =
        meths cl_init)
 
 let create_object cl obj init =
-  let obj' = Ident.create "self" in
+  let obj' = Ident.create_var "self" in
   let (inh_init, obj_init, has_init) = init obj' in
   if obj_init = lambda_unit then
     (inh_init,
@@ -117,7 +117,7 @@ let name_pattern default p =
   match p.pat_desc with
   | Tpat_var (id, _) -> id
   | Tpat_alias(_, id, _) -> id
-  | _ -> Ident.create default
+  | _ -> Ident.create_var default
 
 let normalize_cl_path cl path =
   Env.normalize_path (Some cl.cl_loc) cl.cl_env path
@@ -125,7 +125,7 @@ let normalize_cl_path cl path =
 let rec build_object_init cl_table obj params inh_init obj_init cl =
   match cl.cl_desc with
     Tcl_ident ( path, _, _) ->
-      let obj_init = Ident.create "obj_init" in
+      let obj_init = Ident.create_var "obj_init" in
       let envs, inh_init = inh_init in
       let env =
         match envs with None -> []
@@ -202,8 +202,8 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
     Tcl_let (_rec_flag, _defs, vals, cl) ->
       build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
   | _ ->
-      let self = Ident.create "self" in
+      let self = Ident.create_var "self" in
-      let env = Ident.create "env" in
+      let env = Ident.create_var "env" in
       let obj = if ids = [] then lambda_unit else Lvar self in
       let envs = if top then None else Some env in
       let ((_,inh_init), obj_init) =
@@ -223,7 +223,7 @@ let bind_methods tbl meths vals cl_init =
   let len = List.length methl and nvals = List.length vals in
   if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
   if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
-  let ids = Ident.create "ids" in
+  let ids = Ident.create_var "ids" in
   let i = ref (len + nvals) in
   let getter, names =
     if nvals = 0 then "get_method_labels", [] else
@@ -303,7 +303,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
                 let met_code =
                   if !Clflags.native_code && List.length met_code = 1 then
                     (* Force correct naming of method for profiles *)
-                    let met = Ident.create ("method_" ^ name.txt) in
+                    let met = Ident.create_var ("method_" ^ name.txt) in
                     [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
                   else met_code
                 in
@@ -351,7 +351,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
         Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
           assert (Path.same (normalize_cl_path cl path) path');
           let lpath = transl_normal_path path' in
-          let inh = Ident.create "inh"
+          let inh = Ident.create_var "inh"
           and ofs = List.length vals + 1
           and valids, methids = super in
           let cl_init =
@@ -464,8 +464,8 @@ let rec transl_class_rebind_0 self obj_init cl vf =
 
 let transl_class_rebind cl vf =
   try
-    let obj_init = Ident.create "obj_init"
+    let obj_init = Ident.create_var "obj_init"
-    and self = Ident.create "self" in
+    and self = Ident.create_var "self" in
     let obj_init0 =
       lapply {ap_should_be_tailcall=false;
               ap_loc=Location.none;
@@ -478,11 +478,11 @@ let transl_class_rebind cl vf =
     let id = (obj_init' = lfunction [self] obj_init0) in
     if id then transl_normal_path path else
 
-    let cla = Ident.create "class"
+    let cla = Ident.create_var "class"
-    and new_init = Ident.create "new_init"
+    and new_init = Ident.create_var "new_init"
-    and env_init = Ident.create "env_init"
+    and env_init = Ident.create_var "env_init"
-    and table = Ident.create "table"
+    and table = Ident.create_var "table"
-    and envs = Ident.create "envs" in
+    and envs = Ident.create_var "envs" in
     Llet(
     Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
     Llet(
@@ -660,12 +660,12 @@ let transl_class ids cl_id pub_meths cl vflag =
   if rebind <> lambda_unit then rebind else
 
   (* Prepare for heavy environment handling *)
-  let tables = Ident.create (Ident.name cl_id ^ "_tables") in
+  let tables = Ident.create_var (Ident.name cl_id ^ "_tables") in
   let (top_env, req) = oo_add_class tables in
   let top = not req in
   let cl_env, llets = build_class_lets cl in
   let new_ids = if top then [] else Env.diff top_env cl_env in
-  let env2 = Ident.create "env" in
+  let env2 = Ident.create_var "env" in
   let meth_ids = get_class_meths cl in
   let subst env lam i0 new_ids' =
     let fv = free_variables lam in
@@ -693,7 +693,7 @@ let transl_class ids cl_id pub_meths cl vflag =
   let no_env_update _ _ env = env in
   let msubst arr = function
       Lfunction {kind = Curried; params = self :: args; body} ->
-        let env = Ident.create "env" in
+        let env = Ident.create_var "env" in
         let body' =
           if new_ids = [] then body else
           Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
@@ -714,7 +714,7 @@ let transl_class ids cl_id pub_meths cl vflag =
       | _ -> assert false
   in
   let new_ids_init = ref [] in
-  let env1 = Ident.create "env" and env1' = Ident.create "env'" in
+  let env1 = Ident.create_var "env" and env1' = Ident.create_var "env'" in
   let copy_env self =
     if top then lambda_unit else
     Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
@@ -731,7 +731,7 @@ let transl_class ids cl_id pub_meths cl vflag =
   in
 
   (* Now we start compiling the class *)
-  let cla = Ident.create "class" in
+  let cla = Ident.create_var "class" in
   let (inh_init, obj_init) =
     build_object_init_0 cla [] cl copy_env subst_env top ids in
   let inh_init' = List.rev inh_init in
@@ -739,10 +739,10 @@ let transl_class ids cl_id pub_meths cl vflag =
     build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
   in
   assert (inh_init' = []);
-  let table = Ident.create "table"
+  let table = Ident.create_var "table"
-  and class_init = Ident.create (Ident.name cl_id ^ "_init")
+  and class_init = Ident.create_var (Ident.name cl_id ^ "_init")
-  and env_init = Ident.create "env_init"
+  and env_init = Ident.create_var "env_init"
-  and obj_init = Ident.create "obj_init" in
+  and obj_init = Ident.create_var "obj_init" in
   let pub_meths =
     List.sort
       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
@@ -800,8 +800,8 @@ let transl_class ids cl_id pub_meths cl vflag =
   if top then llets (lbody_virt lambda_unit) else
 
   (* Now for the hard stuff: prepare for table caching *)
-  let envs = Ident.create "envs"
+  let envs = Ident.create_var "envs"
-  and cached = Ident.create "cached" in
+  and cached = Ident.create_var "cached" in
   let lenvs =
     if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
     then lambda_unit

bytecomp/translcore.ml

@@ -436,7 +436,7 @@ and transl_exp0 e =
   | Texp_setinstvar(path_self, path, _, expr) ->
       transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
   | Texp_override(path_self, modifs) ->
-      let cpy = Ident.create "copy" in
+      let cpy = Ident.create_var "copy" in
       Llet(Strict, Pgenval, cpy,
            Lapply{ap_should_be_tailcall=false;
                   ap_loc=Location.none;
@@ -502,7 +502,7 @@ and transl_exp0 e =
          transl_exp e
       | `Other ->
          (* other cases compile to a lazy block holding a function *)
-         let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
+         let fn = Lfunction {kind = Curried; params= [Ident.create_var "param"];
                              attr = default_function_attribute;
                              loc = e.exp_loc;
                              body = transl_exp e} in
@@ -510,7 +510,7 @@ and transl_exp0 e =
       end
   | Texp_object (cs, meths) ->
       let cty = cs.cstr_type in
-      let cl = Ident.create "class" in
+      let cl = Ident.create_var "class" in
       !transl_object cl meths
         { cl_desc = Tcl_structure cs;
           cl_loc = e.exp_loc;
@@ -590,7 +590,7 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
           match lam with
             Lvar _ | Lconst _ -> lam
           | _ ->
-              let id = Ident.create name in
+              let id = Ident.create_var name in
               defs := (id, lam) :: !defs;
               Lvar id
         in
@@ -601,7 +601,7 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
           if args = [] then lam else lapply lam (List.rev_map fst args) in
         let handle = protect "func" lam
         and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
-        and id_arg = Ident.create "param" in
+        and id_arg = Ident.create_var "param" in
         let body =
           match build_apply handle ((Lvar id_arg, optional)::args') l with
             Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
@@ -646,7 +646,7 @@ and transl_function loc untuplify_fn repr partial param cases =
             (fun {c_lhs; c_guard; c_rhs} ->
               (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
             cases in
-        let params = List.map (fun _ -> Ident.create "param") pl in
+        let params = List.map (fun _ -> Ident.create_var "param") pl in
         ((Tupled, params),
          Matching.for_tupled_function loc params
            (transl_tupled_cases pats_expr_list) partial)
@@ -718,7 +718,7 @@ and transl_record loc env fields repres opt_init_expr =
   then begin
     (* Allocate new record with given fields (and remaining fields
        taken from init_expr if any *)
-    let init_id = Ident.create "init" in
+    let init_id = Ident.create_var "init" in
     let lv =
       Array.mapi
         (fun i (_, definition) ->
@@ -781,7 +781,7 @@ and transl_record loc env fields repres opt_init_expr =
   end else begin
     (* Take a shallow copy of the init record, then mutate the fields
        of the copy *)
-    let copy_id = Ident.create "newrecord" in
+    let copy_id = Ident.create_var "newrecord" in
     let update_field cont (lbl, definition) =
       match definition with
       | Kept _type -> cont

bytecomp/translmod.ml

@@ -74,7 +74,7 @@ let rec apply_coercion loc strict restr arg =
         in
         wrap_id_pos_list loc id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
-      let param = Ident.create "funarg" in
+      let param = Ident.create_var "funarg" in
       let carg = apply_coercion loc Alias cc_arg (Lvar param) in
       apply_coercion_result loc strict arg [param] [carg] cc_res
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
@@ -89,7 +89,7 @@ and apply_coercion_field loc get_field (pos, cc) =
 and apply_coercion_result loc strict funct params args cc_res =
   match cc_res with
   | Tcoerce_functor(cc_arg, cc_res) ->
-    let param = Ident.create "funarg" in
+    let param = Ident.create_var "funarg" in
     let arg = apply_coercion loc Alias cc_arg (Lvar param) in
     apply_coercion_result loc strict funct
       (param :: params) (arg :: args) cc_res
@@ -117,7 +117,7 @@ and wrap_id_pos_list loc id_pos_list get_field lam =
   let (lam,s) =
     List.fold_left (fun (lam, s) (id',pos,c) ->
       if Ident.Set.mem id' fv then
-        let id'' = Ident.create (Ident.name id') in
+        let id'' = Ident.create_var (Ident.name id') in
         (Llet(Alias, Pgenval, id'',
              apply_coercion loc Alias c (get_field pos),lam),
          Ident.Map.add id' id'' s)
@@ -622,7 +622,7 @@ and transl_structure loc fields cc rootpath final_env = function
       | Tstr_include incl ->
           let ids = bound_value_identifiers incl.incl_type in
           let modl = incl.incl_mod in
-          let mid = Ident.create "include" in
+          let mid = Ident.create_var "include" in
           let rec rebind_idents pos newfields = function
               [] ->
                 transl_structure loc newfields cc rootpath final_env rem
@@ -1008,7 +1008,7 @@ let transl_store_structure glob map prims str =
         | Tstr_include incl ->
             let ids = bound_value_identifiers incl.incl_type in
             let modl = incl.incl_mod in
-            let mid = Ident.create "include" in
+            let mid = Ident.create_var "include" in
             let loc = incl.incl_loc in
             let rec store_idents pos = function
                 [] -> transl_store rootpath (add_idents true ids subst) rem
@@ -1236,7 +1236,7 @@ let transl_toplevel_item item =
   | Tstr_include incl ->
       let ids = bound_value_identifiers incl.incl_type in
       let modl = incl.incl_mod in
-      let mid = Ident.create "include" in
+      let mid = Ident.create_var "include" in
       let rec set_idents pos = function
         [] ->
           lambda_unit
@@ -1330,7 +1330,7 @@ let transl_store_package component_names target_name coercion =
               List.map get_component component_names,
               Location.none)
       in
-      let blk = Ident.create "block" in
+      let blk = Ident.create_var "block" in
       (List.length pos_cc_list,
        Llet (Strict, Pgenval, blk,
              apply_coercion Location.none Strict coercion components,

bytecomp/translobj.ml

@@ -37,7 +37,7 @@ let share c =
       begin try
         Lvar (Hashtbl.find consts c)
       with Not_found ->
-        let id = Ident.create "shared" in
+        let id = Ident.create_var "shared" in
         Hashtbl.add consts c id;
         Lvar id
       end
@@ -112,7 +112,7 @@ let transl_label_init_general f =
 
 let transl_label_init_flambda f =
   assert(Config.flambda);
-  let method_cache_id = Ident.create "method_cache" in
+  let method_cache_id = Ident.create_var "method_cache" in
   method_cache := Lvar method_cache_id;
   (* Calling f (usually Translmod.transl_struct) requires the
      method_cache variable to be initialised to be able to generate

bytecomp/translprim.ml

@@ -668,7 +668,7 @@ let lambda_of_prim prim_name prim loc args arg_exps =
       in
       Lprim(Praise kind, [arg], loc)
   | Raise_with_backtrace, [exn; bt] ->
-      let vexn = Ident.create "exn" in
+      let vexn = Ident.create_var "exn" in
       let raise_arg =
         match arg_exps with
         | None -> Lvar vexn
@@ -725,7 +725,7 @@ let transl_primitive loc p env ty path =
     | Some prim -> prim
   in
   let rec make_params n =
-    if n <= 0 then [] else Ident.create "prim" :: make_params (n-1)
+    if n <= 0 then [] else Ident.create_var "prim" :: make_params (n-1)
   in
   let params = make_params p.prim_arity in
   let args = List.map (fun id -> Lvar id) params in

debugger/eval.ml

@@ -37,7 +37,10 @@ type error =
 exception Error of error
 
 let abstract_type =
-  Btype.newgenty (Tconstr (Pident (Ident.create "<abstr>"), [], ref Mnil))
+  Btype.newgenty (
+    Tconstr
+      (Pident (Ident.create ~scope:Btype.lowest_level "<abstr>"), [], ref Mnil)
+  )
 
 let rec path event = function
     Pident id ->

debugger/loadprinter.ml

@@ -115,7 +115,6 @@ let match_printer_type desc typename =
       Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
     with Not_found ->
       raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in
-  Ctype.init_def(Ident.current_time());
   Ctype.begin_def();
   let ty_arg = Ctype.newvar() in
   Ctype.unify Env.empty

middle_end/closure_conversion_aux.ml

@@ -98,7 +98,7 @@ module Function_decls = struct
         ~attr ~loc =
       let let_rec_ident =
         match let_rec_ident with
-        | None -> Ident.create "unnamed_function"
+        | None -> Ident.create_var "unnamed_function"
         | Some let_rec_ident -> let_rec_ident
       in
       { let_rec_ident;

ocamldoc/odoc_name.ml

@@ -231,7 +231,7 @@ let to_path n =
     List.fold_left
       (fun acc_opt -> fun s ->
         match acc_opt with
-          None -> Some (Path.Pident (Ident.create s))
+          None -> Some (Path.Pident (Ident.create_var s))
         | Some acc -> Some (Path.Pdot (acc, s, 0)))
       None
       (Str.split (Str.regexp "\\.") n)

testsuite/tests/basic-more/morematch.compilers.reference

@@ -1,7 +1,3 @@
-File "morematch.ml", line 1050, characters 8-65:
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a case that is not matched:
-(A `D|B (`B, (`A|`C)))
 File "morematch.ml", line 67, characters 2-5:
 Warning 12: this sub-pattern is unused.
 File "morematch.ml", line 68, characters 2-3:
@@ -24,6 +20,10 @@ File "morematch.ml", line 455, characters 7-8:
 Warning 12: this sub-pattern is unused.
 File "morematch.ml", line 456, characters 2-7:
 Warning 11: this match case is unused.
+File "morematch.ml", line 1050, characters 8-65:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A `D|B (`B, (`A|`C)))
 File "morematch.ml", line 1084, characters 5-51:
 Warning 11: this match case is unused.
 File "morematch.ml", line 1086, characters 5-51:

testsuite/tests/warnings/w01.compilers.reference

@@ -9,7 +9,7 @@ Here is an example of a case that is not matched:
 0
 File "w01.ml", line 35, characters 0-1:
 Warning 10: this expression should have type unit.
-File "w01.ml", line 19, characters 8-9:
-Warning 27: unused variable y.
 File "w01.ml", line 42, characters 2-3:
 Warning 11: this match case is unused.
+File "w01.ml", line 19, characters 8-9:
+Warning 27: unused variable y.

testsuite/tools/parsecmmaux.ml

@@ -29,7 +29,7 @@ let ident_name s =
   | n -> String.sub s 0 n
 
 let bind_ident s =
-  let id = Ident.create (ident_name s) in
+  let id = Ident.create_var (ident_name s) in
   Hashtbl.add tbl_ident s id;
   id
 

toplevel/genprintval.ml

@@ -133,22 +133,22 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                                      O.t -> Outcometree.out_value) gen_printer)
 
     let printers = ref ([
-      ( Pident(Ident.create "print_int"),
+      ( Pident(Ident.create_var "print_int"),
         Simple (Predef.type_int,
                 (fun x -> Oval_int (O.obj x : int))) );
-      ( Pident(Ident.create "print_float"),
+      ( Pident(Ident.create_var "print_float"),
         Simple (Predef.type_float,
                 (fun x -> Oval_float (O.obj x : float))) );
-      ( Pident(Ident.create "print_char"),
+      ( Pident(Ident.create_var "print_char"),
         Simple (Predef.type_char,
                 (fun x -> Oval_char (O.obj x : char))) );
-      ( Pident(Ident.create "print_int32"),
+      ( Pident(Ident.create_var "print_int32"),
         Simple (Predef.type_int32,
                 (fun x -> Oval_int32 (O.obj x : int32))) );
-      ( Pident(Ident.create "print_nativeint"),
+      ( Pident(Ident.create_var "print_nativeint"),
         Simple (Predef.type_nativeint,
                 (fun x -> Oval_nativeint (O.obj x : nativeint))) );
-      ( Pident(Ident.create "print_int64"),
+      ( Pident(Ident.create_var "print_int64"),
         Simple (Predef.type_int64,
                 (fun x -> Oval_int64 (O.obj x : int64)) ))
     ] : (Path.t * printer) list)
@@ -222,7 +222,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
     (* An abstract type *)
 
     let abstract_type =
-      Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))
+      let scope = Ctype.get_current_level () in
+      let id = Ident.create ~scope "abstract" in
+      let ty = Ctype.newty (Tconstr (Pident id, [], ref Mnil)) in
+      Ctype.init_def (scope + 1);
+      ty
 
     (* The main printing function *)
 

toplevel/opttopdirs.ml

@@ -117,7 +117,6 @@ let match_printer_type ppf desc typename =
     with Not_found ->
       fprintf ppf "Cannot find type Topdirs.%s.@." typename;
       raise Exit in
-  Ctype.init_def(Ident.current_time());
   Ctype.begin_def();
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env

toplevel/topdirs.ml

@@ -318,7 +318,6 @@ let match_generic_printer_type desc path args printer_type =
 let match_printer_type ppf desc =
   let printer_type_new = printer_type ppf "printer_type_new" in
   let printer_type_old = printer_type ppf "printer_type_old" in
-  Ctype.init_def(Ident.current_time());
   try
     (match_simple_printer_type desc printer_type_new, false)
   with Ctype.Unify _ ->

typing/ctype.ml

@@ -658,16 +658,6 @@ let forward_try_expand_once = (* Forward declaration *)
    Lower the levels of a type (assume [level] is not
    [generic_level]).
 *)
-(*
-    The level of a type constructor must be greater than its binding
-    time. That way, a type constructor cannot escape the scope of its
-    definition, as would be the case in
-      let x = ref []
-      module M = struct type t let _ = (x : t list ref) end
-    (without this constraint, the type system would actually be unsound.)
-*)
-let get_path_scope p =
-  Path.binding_time p
 
 let rec normalize_package_path env p =
   let t =
@@ -719,6 +709,14 @@ let update_scope scope ty =
     if ty.level < scope then raise (Unify [(ty, newvar2 ty.level)]);
     set_scope ty (Some scope)
 
+(* Note: the level of a type constructor must be greater than its binding
+    time. That way, a type constructor cannot escape the scope of its
+    definition, as would be the case in
+      let x = ref []
+      module M = struct type t let _ = (x : t list ref) end
+    (without this constraint, the type system would actually be unsound.)
+*)
+
 let rec update_level env level expand ty =
   let ty = repr ty in
   if ty.level > level then begin
@@ -727,7 +725,7 @@ let rec update_level env level expand ty =
     | None -> ()
     end;
     match ty.desc with
-      Tconstr(p, _tl, _abbrev) when level < get_path_scope p ->
+      Tconstr(p, _tl, _abbrev) when level < Path.scope p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
           link_type ty (!forward_try_expand_once env ty);
@@ -743,19 +741,19 @@ let rec update_level env level expand ty =
           set_level ty level;
           iter_type_expr (update_level env level expand) ty
         end
-    | Tpackage (p, nl, tl) when level < Path.binding_time p ->
+    | Tpackage (p, nl, tl) when level < Path.scope p ->
         let p' = normalize_package_path env p in
         if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
         log_type ty; ty.desc <- Tpackage (p', nl, tl);
         update_level env level expand ty
     | Tobject(_, ({contents=Some(p, _tl)} as nm))
-      when level < get_path_scope p ->
+      when level < Path.scope p ->
         set_name nm None;
         update_level env level expand ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
-        | Some (p, _tl) when level < get_path_scope p ->
+        | Some (p, _tl) when level < Path.scope p ->
             log_type ty;
             ty.desc <- Tvariant {row with row_name = None}
         | _ -> ()
@@ -1132,7 +1130,10 @@ let instance_constructor ?in_pattern cstr =
       let process existential =
         let decl = new_declaration (Some expansion_scope) None in
         let name = existential_name cstr existential in
-        let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+        let path =
+          Path.Pident
+            (Ident.create ~scope:expansion_scope (get_new_abstract_name name))
+        in
         let new_env = Env.add_local_type path decl !env in
         env := new_env;
         let to_unify = newty (Tconstr (path,[],ref Mnil)) in
@@ -1919,19 +1920,30 @@ let deep_occur t0 ty =
       information is indeed lost, but it probably does not worth it.
 *)
 
+let gadt_equations_level = ref None
+
+let get_gadt_equations_level () =
+  match !gadt_equations_level with
+  | None -> assert false
+  | Some x -> x
+
+
 (* a local constraint can be added only if the rhs
    of the constraint does not contain any Tvars.
    They need to be removed using this function *)
 let reify env t =
+  let fresh_constr_scope = get_gadt_equations_level () in
   let create_fresh_constr lev name =
     let name = match name with Some s -> "$'"^s | _ -> "$" in
-    let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+    let path =
-    let binding_time = Ident.current_time () in
+      Path.Pident
-    let decl = new_declaration (Some binding_time) None in
+        (Ident.create ~scope:fresh_constr_scope (get_new_abstract_name name))
+    in
+    let decl = new_declaration (Some fresh_constr_scope) None in
     let new_env = Env.add_local_type path decl !env in
     let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
     env := new_env;
-    t, binding_time
+    t
   in
   let visited = ref TypeSet.empty in
   let rec iterator ty =
@@ -1940,9 +1952,9 @@ let reify env t =
       visited := TypeSet.add ty !visited;
       match ty.desc with
         Tvar o ->
-          let t, binding_time = create_fresh_constr ty.level o in
+          let t = create_fresh_constr ty.level o in
           link_type ty t;
-          if ty.level < binding_time then
+          if ty.level < fresh_constr_scope then
             raise (Unify [t, newvar2 ty.level])
       | Tvariant r ->
           let r = row_repr r in
@@ -1951,11 +1963,11 @@ let reify env t =
             let m = r.row_more in
             match m.desc with
               Tvar o ->
-                let t, binding_time = create_fresh_constr m.level o in
+                let t = create_fresh_constr m.level o in
                 let row =
                   {r with row_fields=[]; row_fixed=true; row_more = t} in
                 link_type m (newty2 m.level (Tvariant row));
-                if m.level < binding_time then
+                if m.level < fresh_constr_scope then
                   raise (Unify [t, newvar2 m.level])
             | _ -> assert false
           end;
@@ -2226,20 +2238,13 @@ let find_expansion_scope env path =
   | Some x -> x
   | None -> assert false
 
-let gadt_equations_level = ref None
-
-let get_gadt_equations_level () =
-  match !gadt_equations_level with
-  | None -> assert false
-  | Some x -> x
-
 let add_gadt_equation env source destination =
   (* Format.eprintf "@[add_gadt_equation %s %a@]@."
     (Path.name source) !Btype.print_raw destination; *)
   if local_non_recursive_abbrev !env source destination then begin
     let destination = duplicate_type destination in
     let expansion_scope =
-      max (Path.binding_time source) (get_gadt_equations_level ())
+      max (Path.scope source) (get_gadt_equations_level ())
     in
     let decl = new_declaration (Some expansion_scope) (Some destination) in
     env := Env.add_local_type source decl !env;
@@ -2280,7 +2285,18 @@ let nondep_instance env level id ty =
 (* Find the type paths nl1 in the module type mty2, and add them to the
    list (nl2, tl2). raise Not_found if impossible *)
 let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
-  let id2 = Ident.create "Pkg" in
+  (* This is morally WRONG: we're adding a (dummy) module without a scope in the
+     environment. However no operation which cares about levels/scopes is going
+     to happen while this module exists.
+     The only operations that happen are:
+     - Env.lookup_type
+     - Env.find_type
+     - nondep_instance
+     None of which check the scope.
+
+     It'd be nice if we avoided creating such temporary dummy modules and broken
+     environments though. *)
+  let id2 = Ident.create_var "Pkg" in
   let env' = Env.add_module id2 mty2 env in
   let rec complete nl1 ntl2 =
     match nl1, ntl2 with
@@ -2508,7 +2524,7 @@ and unify3 env t1 t1' t2 t2' =
         when is_instantiable !env path && is_instantiable !env path'
         && !generate_equations ->
           let source, destination =
-            if get_path_scope path > get_path_scope path'
+            if Path.scope path > Path.scope path'
             then  path , t2'
             else  path', t1'
           in
@@ -2960,7 +2976,7 @@ let filter_self_method env lab priv meths ty =
   try
     Meths.find lab !meths
   with Not_found ->
-    let pair = (Ident.create lab, ty') in
+    let pair = (Ident.create_var lab, ty') in
     meths := Meths.add lab pair !meths;
     pair
 

typing/env.ml

@@ -1958,22 +1958,22 @@ let add_local_type path info env =
 
 (* Insertion of bindings by name *)
 
-let enter store_fun name data env =
+let enter scope store_fun name data env =
-  let id = Ident.create name in (id, store_fun id data env)
+  let id = Ident.create ~scope name in (id, store_fun id data env)
 
-let enter_value ?check = enter (store_value ?check)
+let enter_value ?check = enter 0 (store_value ?check)
-and enter_type = enter (store_type ~check:true)
+and enter_type ~scope = enter scope (store_type ~check:true)
-and enter_extension = enter (store_extension ~check:true)
+and enter_extension ~scope = enter scope (store_extension ~check:true)
 and enter_module_declaration ?arg id md env =
   add_module_declaration ?arg ~check:true id md env
   (* let (id, env) = enter store_module name md env in
   (id, add_functor_arg ?arg id env) *)
-and enter_modtype = enter store_modtype
+and enter_modtype ~scope = enter scope store_modtype
-and enter_class = enter store_class
+and enter_class ~scope = enter scope store_class
-and enter_cltype = enter store_cltype
+and enter_cltype ~scope = enter scope store_cltype
 
-let enter_module ?arg s mty env =
+let enter_module ~scope ?arg s mty env =
-  let id = Ident.create s in
+  let id = Ident.create ~scope s in
   (id, enter_module_declaration ?arg id (md mty) env)
 
 (* Insertion of all components of a signature *)

typing/env.mli

@@ -188,14 +188,18 @@ val open_pers_signature: string -> t -> t
 val enter_value:
     ?check:(string -> Warnings.t) ->
     string -> value_description -> t -> Ident.t * t
-val enter_type: string -> type_declaration -> t -> Ident.t * t
+val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
-val enter_extension: string -> extension_constructor -> t -> Ident.t * t
+val enter_extension:
-val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t
+  scope:int -> string -> extension_constructor -> t -> Ident.t * t
+val enter_module:
+  scope:int -> ?arg:bool -> string -> module_type -> t -> Ident.t * t
 val enter_module_declaration:
     ?arg:bool -> Ident.t -> module_declaration -> t -> t
-val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t
+val enter_modtype:
-val enter_class: string -> class_declaration -> t -> Ident.t * t
+  scope:int -> string -> modtype_declaration -> t -> Ident.t * t
-val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t
+val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t
+val enter_cltype:
+  scope:int -> string -> class_type_declaration -> t -> Ident.t * t
 
 (* Initialize the cache of in-core module interfaces. *)
 val reset_cache: unit -> unit

typing/ident.ml

@@ -15,7 +15,7 @@
 
 open Format
 
-type t = { stamp: int; name: string; flags: int }
+type t = { stamp: int; name: string; flags: int; scope: int }
 
 let global_flag = 1
 let predef_exn_flag = 2
@@ -24,24 +24,28 @@ let predef_exn_flag = 2
 
 let currentstamp = ref 0
 
-let create s =
+let create ~scope s =
   incr currentstamp;
-  { name = s; stamp = !currentstamp; flags = 0 }
+  { name = s; stamp = !currentstamp; flags = 0; scope }
 
 let create_hidden s =
-  { name = s; stamp = -1; flags = 0 }
+  { name = s; stamp = -1; flags = 0; scope = -1 }
+
+let create_var s =
+  incr currentstamp;
+  { name = s; stamp = !currentstamp; flags = 0; scope = -1 }
 
 let create_predef_exn s =
   incr currentstamp;
   { name = s; stamp = !currentstamp;
-    flags = predef_exn_flag lor global_flag }
+    flags = predef_exn_flag lor global_flag; scope = 0 }
 
 let create_persistent s =
-  { name = s; stamp = 0; flags = global_flag }
+  { name = s; stamp = 0; flags = global_flag; scope = 0 }
 
 let rename i =
   incr currentstamp;
-  { i with stamp = !currentstamp }
+  { i with stamp = !currentstamp; scope = 0 }
 
 let name i = i.name
 
@@ -63,10 +67,11 @@ let same i1 i2 = i1 = i2
 
 let compare i1 i2 = Stdlib.compare i1 i2
 
-let binding_time i = i.stamp
+let stamp i = i.stamp
+let scope i = i.scope
 
-let current_time() = !currentstamp
+let current_stamp () = !currentstamp
-let set_current_time t = currentstamp := max !currentstamp t
+let bump_stamp_counter t = currentstamp := max !currentstamp t
 
 let reinit_level = ref (-1)
 

typing/ident.mli

@@ -25,7 +25,8 @@ include Identifiable.S with type t := t
 *)
 
 
-val create: string -> t
+val create: scope:int -> string -> t
+val create_var: string -> t
 val create_persistent: string -> t
 val create_predef_exn: string -> t
 val rename: t -> t
@@ -50,9 +51,11 @@ val create_hidden: string -> t
 val global: t -> bool
 val is_predef_exn: t -> bool
 
-val binding_time: t -> int
+val stamp: t -> int
-val current_time: unit -> int
+val scope: t -> int
-val set_current_time: int -> unit
+
+val current_stamp: unit -> int
+val bump_stamp_counter: int -> unit
 val reinit: unit -> unit
 
 type 'a tbl

typing/parmatch.ml

@@ -34,7 +34,7 @@ let omega = make_pat Tpat_any Ctype.none Env.empty
 
 let extra_pat =
   make_pat
-    (Tpat_var (Ident.create "+", mknoloc "+"))
+    (Tpat_var (Ident.create_var "+", mknoloc "+"))
     Ctype.none Env.empty
 
 let rec omegas i =
@@ -974,7 +974,7 @@ let some_private_tag = "<some private tag>"
 let build_other ext env = match env with
 | ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
         (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
-        make_pat (Tpat_var (Ident.create "*extension*",
+        make_pat (Tpat_var (Ident.create_var "*extension*",
                             {lid with txt="*extension*"})) Ctype.none Env.empty
 | ({pat_desc = Tpat_construct _} as p,_) :: _ ->
     begin match ext with

typing/path.ml

@@ -53,10 +53,10 @@ let exists_free ids p =
   | None -> false
   | _ -> true
 
-let rec binding_time = function
+let rec scope = function
-    Pident id -> Ident.binding_time id
+    Pident id -> Ident.scope id
-  | Pdot(p, _s, _pos) -> binding_time p
+  | Pdot(p, _s, _pos) -> scope p
-  | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
+  | Papply(p1, p2) -> max (scope p1) (scope p2)
 
 let kfalse _ = false
 

typing/path.mli

@@ -24,7 +24,7 @@ val same: t -> t -> bool
 val compare: t -> t -> int
 val find_free_opt: Ident.t list -> t -> Ident.t option
 val exists_free: Ident.t list -> t -> bool
-val binding_time: t -> int
+val scope: t -> int
 val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
 
 val nopos: int

typing/predef.ml

@@ -26,7 +26,7 @@ let wrap create s =
   builtin_idents := (s, id) :: !builtin_idents;
   id
 
-let ident_create = wrap Ident.create
+let ident_create = wrap (Ident.create ~scope:lowest_level)
 let ident_create_predef_exn = wrap Ident.create_predef_exn
 
 let ident_int = ident_create "int"
@@ -250,5 +250,5 @@ let builtin_values =
    be defined in this file (above!) without breaking .cmi
    compatibility. *)
 
-let _ = Ident.set_current_time 999
+let _ = Ident.bump_stamp_counter 999
 let builtin_idents = List.rev !builtin_idents

typing/printtyp.ml

@@ -1388,7 +1388,7 @@ let rec tree_of_class_type sch params =
        if is_optional l then
          match (repr ty).desc with
          | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
-         | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
+         | _ -> newconstr (Path.Pident(Ident.create_hidden "<hidden>")) []
        else ty in
       let tr = tree_of_typexp sch ty in
       Octy_arrow (lab, tr, tree_of_class_type sch params cty)
@@ -1793,13 +1793,13 @@ let explanation env unif t3 t4 : (Format.formatter -> unit) option =
       Some (fun ppf ->
         fprintf ppf "@,Self type cannot escape its class")
   | Tconstr (p, _, _), Tvar _
-    when unif && t4.level < Path.binding_time p ->
+    when unif && t4.level < Path.scope p ->
       Some (fun ppf ->
         fprintf ppf
           "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
           path p)
   | Tvar _, Tconstr (p, _, _)
-    when unif && t3.level < Path.binding_time p ->
+    when unif && t3.level < Path.scope p ->
       Some (fun ppf ->
         fprintf ppf
           "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"

typing/typeclass.ml

@@ -100,7 +100,8 @@ let dummy_method = Btype.dummy_method
    Path associated to the temporary class type of a class being typed
    (its constructor is not available).
 *)
-let unbound_class = Path.Pident (Ident.create "*undef*")
+let unbound_class =
+  Path.Pident (Ident.create ~scope:Btype.lowest_level "*undef*")
 
 
                 (************************************)
@@ -236,7 +237,8 @@ let rc node =
 (* Enter a value in the method environment only *)
 let enter_met_env ?check loc lab kind ty val_env met_env par_env =
   let (id, val_env) =
-    Env.enter_value lab {val_type = ty;
+    Env.enter_value lab
+      {val_type = ty;
        val_kind = Val_unbound Val_unbound_instance_variable;
        val_attributes = [];
        Types.val_loc = loc} val_env
@@ -606,7 +608,7 @@ and class_field_aux self_loc cl_num self_type meths vars
       in
       (* Inherited concrete methods *)
       let inh_meths =
-        Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
+        Concr.fold (fun lab rem -> (lab, Ident.create_var lab)::rem)
           cl_sig.csig_concr []
       in
       (* Super *)
@@ -1181,7 +1183,7 @@ and class_expr_aux cl_num val_env met_env scl =
                 Types.val_loc = vd.Types.val_loc;
                }
              in
-             let id' = Ident.create (Ident.name id) in
+             let id' = Ident.create_var (Ident.name id) in
              ((id', expr)
               :: vals,
               Env.add_value id' desc met_env))
@@ -1718,15 +1720,18 @@ let check_coercions env
 (*******************************)
 
 let type_classes define_class approx kind env cls =
+  let scope = Ctype.get_current_level () in
   let cls =
     List.map
       (function cl ->
          (cl,
-          Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt,
+          Ident.create ~scope cl.pci_name.txt,
-          Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt)))
+          Ident.create ~scope cl.pci_name.txt,
+          Ident.create ~scope cl.pci_name.txt,
+          Ident.create ~scope ("#" ^ cl.pci_name.txt)))
       cls
   in
-  Ctype.init_def (Ident.current_time ());
+  Ctype.init_def (scope + 1);
   Ctype.begin_class_def ();
   let (res, env) =
     List.fold_left (initial_env define_class approx) ([], env) cls

typing/typecore.ml

@@ -491,7 +491,7 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
   if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
       !pattern_variables
   then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
-  let id = Ident.create name.txt in
+  let id = Ident.create_var name.txt in
   pattern_variables :=
     {pv_id = id;
      pv_type = ty;
@@ -1122,7 +1122,9 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
   | Ppat_var name ->
       let ty = instance expected_ty in
       let id = (* PR#7330 *)
-        if name.txt = "*extension*" then Ident.create name.txt else
+        if name.txt = "*extension*" then
+          Ident.create_var name.txt
+        else
           enter_variable loc name ty sp.ppat_attributes
       in
       rp k {
@@ -1622,7 +1624,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
          let check s =
            if pv_as_var then Warnings.Unused_var s
            else Warnings.Unused_var_strict s in
-         let id' = Ident.create (Ident.name pv_id) in
+         let id' = Ident.create_var (Ident.name pv_id) in
          ((id', pv_id, pv_type)::pv,
           Env.add_value id' {val_type = pv_type;
                              val_kind = Val_ivar (Immutable, cl_num);
@@ -2110,7 +2112,7 @@ let proper_exp_loc exp =
 (* To find reasonable names for let-bound and lambda-bound idents *)
 
 let rec name_pattern default = function
-    [] -> Ident.create default
+    [] -> Ident.create_var default
   | p :: rem ->
     match p.pat_desc with
       Tpat_var (id, _) -> id
@@ -2692,7 +2694,7 @@ and type_expect_
           (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
       let id, new_env =
         match param.ppat_desc with
-        | Ppat_any -> Ident.create "_for", env
+        | Ppat_any -> Ident.create_var "_for", env
         | Ppat_var {txt} ->
             Env.enter_value txt {val_type = instance Predef.type_int;
                                  val_attributes = [];
@@ -3010,12 +3012,12 @@ and type_expect_
       let ty = newvar() in
       (* remember original level *)
       begin_def ();
-      Ident.set_current_time ty.level;
       let context = Typetexp.narrow () in
       let modl = !type_module env smodl in
       Mtype.lower_nongen ty.level modl.mod_type;
-      let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
+      let scope = get_current_level () in
-      Ctype.init_def(Ident.current_time());
+      let (id, new_env) = Env.enter_module ~scope name.txt modl.mod_type env in
+      init_def (scope + 1);
       Typetexp.widen context;
       (* ideally, we should catch Expr_type_clash errors
          in type_expect triggered by escaping identifiers from the local module
@@ -3143,9 +3145,9 @@ and type_expect_
         type_unboxed = unboxed_false_default_false;
       }
       in
-      Ident.set_current_time ty.level;
+      let scope = get_current_level () in
-      let (id, new_env) = Env.enter_type name decl env in
+      let (id, new_env) = Env.enter_type ~scope name decl env in
-      Ctype.init_def(Ident.current_time());
+      Ctype.init_def (scope + 1);
 
       let body = type_exp new_env sbody in
       (* Replace every instance of this type constructor in the resulting
@@ -3661,7 +3663,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
       if args = [] then texp else
       (* eta-expand to avoid side effects *)
       let var_pair name ty =
-        let id = Ident.create name in
+        let id = Ident.create_var name in
         {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
          pat_attributes = [];
          pat_loc = Location.none; pat_env = env},
@@ -4044,16 +4046,9 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
     | _ -> true
   in
   let outer_level = get_current_level () in
-  let init_env () =
-    (* raise level for existentials *)
-    begin_def ();
-    Ident.set_current_time (get_current_level ());
-    let lev = Ident.current_time () in
-    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
-    lev
-  in
   let lev =
-    if may_contain_gadts then init_env () else get_current_level ()
+    if may_contain_gadts then begin_def ();
+    get_current_level ()
   in
   let take_partial_instance =
     if !Clflags.principal || erase_either
@@ -4191,11 +4186,7 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
     let ty_res' = instance ty_res in
     List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
   end;
-  let do_init = does_contain_gadt || needs_exhaust_check in
+  let do_init = may_contain_gadts || needs_exhaust_check in
-  let lev =
-    (* if [may_contain_gadt] then [init_env] was already called, no need to do
-       it again. *)
-    if do_init && not may_contain_gadts then init_env () else lev in
   let ty_arg_check =
     if do_init then
       (* Hack: use for_saving to copy variables too *)
@@ -4211,25 +4202,23 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
     else
       Partial
   in
-  let unused_check do_init =
+  let unused_check delayed =
-    let lev =
-      if do_init then init_env () else get_current_level ()
-    in
     List.iter (fun { typed_pat; branch_env; _ } ->
       check_absent_variant branch_env typed_pat
     ) half_typed_cases;
+    if delayed then (begin_def (); init_def lev);
     check_unused ~lev env ty_arg_check val_cases ;
     check_unused ~lev env Predef.type_exn exn_cases ;
-    if do_init then end_def ();
+    if delayed then end_def ();
     Parmatch.check_ambiguous_bindings val_cases ;
     Parmatch.check_ambiguous_bindings exn_cases
   in
-  if contains_polyvars || do_init then
+  if contains_polyvars then
-    add_delayed_check (fun () -> unused_check do_init)
+    add_delayed_check (fun () -> unused_check true)
   else
-    unused_check false;
     (* Check for unused cases, do not delay because of gadts *)
-  if do_init then begin
+    unused_check false;
+  if may_contain_gadts then begin
     end_def ();
     (* Ensure that existential types do not escape *)
     unify_exp_types loc env (instance ty_res) (newvar ()) ;

typing/typedecl.ml

@@ -235,7 +235,8 @@ let transl_labels env closed lbls =
       (fun () ->
          let arg = Ast_helper.Typ.force_poly arg in
          let cty = transl_simple_type env closed arg in
-         {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut;
+         {ld_id = Ident.create_var name.txt;
+          ld_name = name; ld_mutable = mut;
           ld_type = cty; ld_loc = loc; ld_attributes = attrs}
       )
   in
@@ -447,7 +448,7 @@ let transl_declaration env sdecl id =
            > (Config.max_tag + 1) then
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
         let make_cstr scstr =
-          let name = Ident.create scstr.pcd_name.txt in
+          let name = Ident.create_var scstr.pcd_name.txt in
           let targs, tret_type, args, ret_type, cstr_params =
             make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
@@ -1278,8 +1279,9 @@ let transl_type_decl env rec_flag sdecl_list =
   in
 
   (* Create identifiers. *)
+  let scope = Ctype.get_current_level () in
   let id_list =
-    List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list
+    List.map (fun sdecl -> Ident.create ~scope sdecl.ptype_name.txt) sdecl_list
   in
   (*
      Since we've introduced fresh idents, make sure the definition
@@ -1287,7 +1289,7 @@ let transl_type_decl env rec_flag sdecl_list =
      passing one of the recursively-defined type constrs as argument
      to an abbreviation may fail.
   *)
-  Ctype.init_def(Ident.current_time());
+  Ctype.init_def(scope + 1);
   Ctype.begin_def();
   (* Enter types. *)
   let temp_env =
@@ -1408,7 +1410,7 @@ let transl_type_decl env rec_flag sdecl_list =
 
 let transl_extension_constructor env type_path type_params
                                  typext_params priv sext =
-  let id = Ident.create sext.pext_name.txt in
+  let id = Ident.create_var sext.pext_name.txt in
   let args, ret_type, kind =
     match sext.pext_kind with
       Pext_decl(sargs, sret_type) ->
@@ -1935,9 +1937,10 @@ let abstract_type_decl arity =
   decl
 
 let approx_type_decl sdecl_list =
+  let scope = Ctype.get_current_level () in
   List.map
     (fun sdecl ->
-      (Ident.create sdecl.ptype_name.txt,
+      (Ident.create ~scope sdecl.ptype_name.txt,
        abstract_type_decl (List.length sdecl.ptype_params)))
     sdecl_list
 

typing/typemod.ml

@@ -470,7 +470,9 @@ let merge_constraint initial_env remove_aliases loc sg constr =
             type_immediate = false;
             type_unboxed = unboxed_false_default_false;
           }
-        and id_row = Ident.create (s^"#row") in
+        and id_row = Ident.create ~scope:(Ctype.get_current_level ())
+                       (s^"#row")
+        in
         let initial_env =
           Env.add_type ~check:false id_row decl_row initial_env
         in
@@ -663,7 +665,9 @@ let rec approx_modtype env smty =
   | Pmty_functor(param, sarg, sres) ->
       let arg = may_map (approx_modtype env) sarg in
       let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
-      let (id, newenv) = Env.enter_module ~arg:true param.txt rarg env in
+      let (id, newenv) =
+        Env.enter_module ~scope:(Ctype.get_current_level ()) ~arg:true param.txt
+          rarg env in
       let res = approx_modtype newenv sres in
       Mty_functor(id, arg, res)
   | Pmty_with(sbody, constraints) ->
@@ -705,7 +709,8 @@ and approx_sig env ssg =
           map_rec_type ~rec_flag
             (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
       | Psig_module pmd ->
-          let id = Ident.create pmd.pmd_name.txt in
+          let id = Ident.create ~scope:(Ctype.get_current_level ())
+                    pmd.pmd_name.txt in
           let md = approx_module_declaration env pmd in
           let newenv = Env.enter_module_declaration id md env in
           Sig_module(id, md, Trec_not) :: approx_sig newenv srem
@@ -713,7 +718,8 @@ and approx_sig env ssg =
           let decls =
             List.map
               (fun pmd ->
-                 (Ident.create pmd.pmd_name.txt,
+                 (Ident.create ~scope:(Ctype.get_current_level ())
+                    pmd.pmd_name.txt,
                   approx_module_declaration env pmd)
               )
               sdecls
@@ -727,7 +733,10 @@ and approx_sig env ssg =
                   (approx_sig newenv srem)
       | Psig_modtype d ->
           let info = approx_modtype_info env d in
-          let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
+          let (id, newenv) =
+            Env.enter_modtype ~scope:(Ctype.get_current_level ())
+              d.pmtd_name.txt info env
+          in
           Sig_modtype(id, info) :: approx_sig newenv srem
       | Psig_open sod ->
           let (_path, mty, _od) = type_open env sod in
@@ -962,9 +971,11 @@ and transl_modtype_aux env smty =
   | Pmty_functor(param, sarg, sres) ->
       let arg = Misc.may_map (transl_modtype_functor_arg env) sarg in
       let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
+      let scope = Ctype.get_current_level () in
       let (id, newenv) =
-        Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in
+        Env.enter_module ~scope ~arg:true param.txt (Btype.default_mty ty_arg)
-      Ctype.init_def(Ident.current_time()); (* PR#6513 *)
+          env in
+      Ctype.init_def (scope + 1); (* PR#6513 *)
       let res = transl_modtype newenv sres in
       mkmty (Tmty_functor (id, param, arg, res))
       (Mty_functor(id, ty_arg, res.mty_type)) env loc
@@ -996,7 +1007,7 @@ and transl_signature env sg =
   let names = new_names () in
   let to_be_removed = ref Ident.Map.empty in
   let rec transl_sig env sg =
-    Ctype.init_def(Ident.current_time());
+    Ctype.init_def (Ctype.get_current_level() + 1);
     match sg with
       [] -> [], [], env
     | item :: srem ->
@@ -1048,7 +1059,8 @@ and transl_signature env sg =
                        Text_exception) :: rem,
             final_env
         | Psig_module pmd ->
-            let id = Ident.create pmd.pmd_name.txt in
+            let id = Ident.create ~scope:(Ctype.get_current_level ())
+                       pmd.pmd_name.txt in
             check_module names pmd.pmd_name.loc id to_be_removed;
             let tmty =
               Builtin_attributes.warning_scope pmd.pmd_attributes
@@ -1202,7 +1214,9 @@ and transl_modtype_decl_aux to_be_removed names env
      mtd_loc=pmtd_loc;
     }
   in
-  let (id, newenv) = Env.enter_modtype pmtd_name.txt decl env in
+  let (id, newenv) =
+    Env.enter_modtype ~scope:(Ctype.get_current_level ()) pmtd_name.txt decl env
+  in
   check_modtype names pmtd_loc id to_be_removed;
   let mtd =
     {
@@ -1238,7 +1252,8 @@ and transl_recmodule_modtypes env sdecls =
         (id, Types.{md_type = mty.mty_type;
                     md_loc = mty.mty_loc;
                     md_attributes = mty.mty_attributes})) in
-  let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in
+  let scope = Ctype.get_current_level () in
+  let ids = List.map (fun x -> Ident.create ~scope x.pmd_name.txt) sdecls in
   let approx_env =
     (*
        cf #5965
@@ -1248,12 +1263,12 @@ and transl_recmodule_modtypes env sdecls =
     *)
     List.fold_left
       (fun env id ->
-         let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in
+         let dummy = Mty_ident (Path.Pident (Ident.create ~scope "#recmod#")) in
          Env.add_module ~arg:true id dummy env
       )
       env ids
   in
-  Ctype.init_def(Ident.current_time()); (* PR#7082 *)
+  Ctype.init_def(scope + 1); (* PR#7082 *)
   let init =
     List.map2
       (fun id pmd ->
@@ -1566,10 +1581,13 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
   | Pmod_functor(name, smty, sbody) ->
       let mty = may_map (transl_modtype_functor_arg env) smty in
       let ty_arg = Misc.may_map (fun m -> m.mty_type) mty in
+      let scope = Ctype.get_current_level () in
       let (id, newenv), funct_body =
-        match ty_arg with None -> (Ident.create "*", env), false
+        match ty_arg with
-        | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in
+        | None -> (Ident.create ~scope "*", env), false
-      Ctype.init_def(Ident.current_time()); (* PR#6981 *)
+        | Some mty -> Env.enter_module ~scope ~arg:true name.txt mty env, true
+      in
+      Ctype.init_def(scope + 1); (* PR#6981 *)
       let body = type_module sttn funct_body None newenv sbody in
       rm { mod_desc = Tmod_functor(id, name, mty, body);
            mod_type = Mty_functor(id, ty_arg, body.mod_type);
@@ -1762,7 +1780,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                    pmb_loc;
                   } ->
-        let id = Ident.create name.txt in (* create early for PR#6752 *)
+        let scope = Ctype.get_current_level () in
+        let id = Ident.create ~scope name.txt in (* create early for PR#6752 *)
         check_module names pmb_loc id to_be_removed;
         let modl =
           Builtin_attributes.warning_scope attrs
@@ -1778,7 +1797,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           }
         in
         (*prerr_endline (Ident.unique_toplevel_name id);*)
-        Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type;
+        Mtype.lower_nongen (scope - 1) md.md_type;
         let newenv = Env.enter_module_declaration id md env in
         Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
                      mb_attributes=attrs;  mb_loc=pmb_loc;
@@ -1950,7 +1969,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         Tstr_attribute x, [], env
   in
   let rec type_struct env sstr =
-    Ctype.init_def(Ident.current_time());
+    Ctype.init_def(Ctype.get_current_level () + 1);
     match sstr with
     | [] -> ([], [], env)
     | pstr :: srem ->
@@ -2030,12 +2049,11 @@ let type_module_type_of env smod =
 let type_package env m p nl =
   (* Same as Pexp_letmodule *)
   (* remember original level *)
-  let lv = Ctype.get_current_level () in
   Ctype.begin_def ();
-  Ident.set_current_time lv;
   let context = Typetexp.narrow () in
   let modl = type_module env m in
-  Ctype.init_def(Ident.current_time());
+  let scope = Ctype.get_current_level () + 1 in
+  Ctype.init_def scope;
   Typetexp.widen context;
   let (mp, env) =
     match modl.mod_desc with
@@ -2043,7 +2061,7 @@ let type_package env m p nl =
     | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
         -> (mp, env)  (* PR#6982 *)
     | _ ->
-      let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
+      let (id, new_env) = Env.enter_module ~scope ~arg:true "%M" modl.mod_type env in
       (Pident id, new_env)
   in
   let rec mkpath mp = function
@@ -2172,7 +2190,7 @@ let rec package_signatures subst = function
   | (name, sg) :: rem ->
       let sg' = Subst.signature subst sg in
       let oldid = Ident.create_persistent name
-      and newid = Ident.create name in
+      and newid = Ident.create_var name in
       Sig_module(newid, {md_type=Mty_signature sg';
                          md_attributes=[];
                          md_loc=Location.none;