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.

8 files changed, 62 insertions, 60 deletions

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 77c865abce..a7ca014b33 100644
--- a/bytecomp/lambda.ml
+++ b/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
 
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 722d23a3cb..fb360c4ee1 100644
--- a/bytecomp/matching.ml
+++ b/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
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 114c941564..9c61fbb396 100644
--- a/bytecomp/simplif.ml
+++ b/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 =
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index a8cfdd2aea..df83e1dc3a 100644
--- a/bytecomp/translclass.ml
+++ b/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 env = Ident.create "env" in
+      let self = Ident.create_var "self" 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"
-    and self = Ident.create "self" in
+    let obj_init = Ident.create_var "obj_init"
+    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"
-    and new_init = Ident.create "new_init"
-    and env_init = Ident.create "env_init"
-    and table = Ident.create "table"
-    and envs = Ident.create "envs" in
+    let cla = Ident.create_var "class"
+    and new_init = Ident.create_var "new_init"
+    and env_init = Ident.create_var "env_init"
+    and table = Ident.create_var "table"
+    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"
-  and class_init = Ident.create (Ident.name cl_id ^ "_init")
-  and env_init = Ident.create "env_init"
-  and obj_init = Ident.create "obj_init" in
+  let table = Ident.create_var "table"
+  and class_init = Ident.create_var (Ident.name cl_id ^ "_init")
+  and env_init = Ident.create_var "env_init"
+  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"
-  and cached = Ident.create "cached" in
+  let envs = Ident.create_var "envs"
+  and cached = Ident.create_var "cached" in
   let lenvs =
     if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
     then lambda_unit
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 043d7171c5..67f297a3c0 100644
--- a/bytecomp/translcore.ml
+++ b/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
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 2f716f8caf..b68c826e5e 100644
--- a/bytecomp/translmod.ml
+++ b/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,
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 23b4c461dc..61e56cdbd5 100644
--- a/bytecomp/translobj.ml
+++ b/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
diff --git a/bytecomp/translprim.ml b/bytecomp/translprim.ml
index 02adbe8b8e..c727f63be0 100644
--- a/bytecomp/translprim.ml
+++ b/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