diff options
39 files changed, 338 insertions, 289 deletions
diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml index d3d371cf92..b8bd6d98ef 100644 --- a/asmcomp/afl_instrument.ml +++ b/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 afl_area = Ident.create "shared_mem" in + let cur_pos = Ident.create_var "pos" 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)) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 9061293869..7f75152258 100644 --- a/asmcomp/closure.ml +++ b/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 = diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index aa049d7327..d99b67edbe 100644 --- a/asmcomp/cmmgen.ml +++ b/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" - and mi = Ident.create "mi" and tagged = Ident.create "tagged" in + let li = Ident.create_var "li" and hi = Ident.create_var "hi" + 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 - for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; - let clos = Ident.create "clos" in + let arg = Array.make arity (Ident.create_var "arg") in + for i = 1 to arity - 1 do arg.(i) <- Ident.create_var "arg" done; + 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 real = Ident.create "real" in + let meths = Ident.create_var "meths" and cached = Ident.create_var "cached" 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 clos = Ident.create "clos" in + let arg = Ident.create_var "arg" 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_clos = Ident.create "clos" in + let last_arg = Ident.create_var "arg" 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) diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml index bc50949ebf..ed93f5934a 100644 --- a/asmcomp/flambda_to_clambda.ml +++ b/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 = diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 9201d99883..8ba39744fd 100644 --- a/asmcomp/selectgen.ml +++ b/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 diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml index b118e6a46d..d206b1c0da 100644 --- a/asmcomp/spacetime_profiling.ml +++ b/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_ident = ref (lazy (Ident.create "dummy")) +let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create_var "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 new_node = Ident.create "new_node" in - let must_allocate_node = Ident.create "must_allocate_node" in - let is_new_node = Ident.create "is_new_node" in + let node = Ident.create_var "node" in + let new_node = Ident.create_var "new_node" in + let must_allocate_node = Ident.create_var "must_allocate_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_count = Ident.create "existing_count" in - let profinfo = Ident.create "profinfo" in - let address_of_profinfo = Ident.create "address_of_profinfo" in + let existing_profinfo = Ident.create_var "existing_profinfo" in + let existing_count = Ident.create_var "existing_count" in + let profinfo = Ident.create_var "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 = Ident.create "call_count" in + let count_addr = Ident.create_var "call_count_addr" 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 diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 3a60f2419d..6900e0dbc9 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -67,8 +67,8 @@ module Make(I:I) = struct (* Utilities *) - let gen_cell_id () = Ident.create "cell" - let gen_size_id () = Ident.create "size" + let gen_cell_id () = Ident.create_var "cell" + let gen_size_id () = Ident.create_var "size" let mk_let_cell id str ind body = let dbg = Debuginfo.none in 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 diff --git a/debugger/eval.ml b/debugger/eval.ml index e6baa80b47..7190209d85 100644 --- a/debugger/eval.ml +++ b/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 -> diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index c0f1797755..ab35575164 100644 --- a/debugger/loadprinter.ml +++ b/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 diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml index 1a066d0b65..da9bea4b8d 100644 --- a/middle_end/closure_conversion_aux.ml +++ b/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; diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index 7e8d938e21..c0018a981b 100644 --- a/ocamldoc/odoc_name.ml +++ b/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) diff --git a/testsuite/tests/basic-more/morematch.compilers.reference b/testsuite/tests/basic-more/morematch.compilers.reference index 7f077dd6ff..1de3c274a3 100644 --- a/testsuite/tests/basic-more/morematch.compilers.reference +++ b/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: diff --git a/testsuite/tests/warnings/w01.compilers.reference b/testsuite/tests/warnings/w01.compilers.reference index ea21e869f5..3c43b9c534 100644 --- a/testsuite/tests/warnings/w01.compilers.reference +++ b/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. diff --git a/testsuite/tools/parsecmmaux.ml b/testsuite/tools/parsecmmaux.ml index 0d4f525178..698ddb376c 100644 --- a/testsuite/tools/parsecmmaux.ml +++ b/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 diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index d8e5572e1b..3dbc3c40d2 100644 --- a/toplevel/genprintval.ml +++ b/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 *) diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index ff13350090..f8355b3efb 100644 --- a/toplevel/opttopdirs.ml +++ b/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 diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 1c629b7fec..69fb6d5391 100644 --- a/toplevel/topdirs.ml +++ b/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 _ -> diff --git a/typing/ctype.ml b/typing/ctype.ml index ee41568c15..e4fdf86b6b 100644 --- a/typing/ctype.ml +++ b/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 binding_time = Ident.current_time () in - let decl = new_declaration (Some binding_time) None in + let path = + Path.Pident + (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 diff --git a/typing/env.ml b/typing/env.ml index 951a71af68..5a872b28a5 100644 --- a/typing/env.ml +++ b/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 id = Ident.create name in (id, store_fun id data env) +let enter scope store_fun name data env = + let id = Ident.create ~scope name in (id, store_fun id data env) -let enter_value ?check = enter (store_value ?check) -and enter_type = enter (store_type ~check:true) -and enter_extension = enter (store_extension ~check:true) +let enter_value ?check = enter 0 (store_value ?check) +and enter_type ~scope = enter scope (store_type ~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_class = enter store_class -and enter_cltype = enter store_cltype +and enter_modtype ~scope = enter scope store_modtype +and enter_class ~scope = enter scope store_class +and enter_cltype ~scope = enter scope store_cltype -let enter_module ?arg s mty env = - let id = Ident.create s in +let enter_module ~scope ?arg s mty env = + let id = Ident.create ~scope s in (id, enter_module_declaration ?arg id (md mty) env) (* Insertion of all components of a signature *) diff --git a/typing/env.mli b/typing/env.mli index 25effc3ab8..3d6dea2986 100644 --- a/typing/env.mli +++ b/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_extension: string -> extension_constructor -> t -> Ident.t * t -val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t +val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t +val enter_extension: + 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_class: string -> class_declaration -> t -> Ident.t * t -val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t +val enter_modtype: + scope:int -> string -> modtype_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 diff --git a/typing/ident.ml b/typing/ident.ml index 550d0ac691..39a0318a9f 100644 --- a/typing/ident.ml +++ b/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 set_current_time t = currentstamp := max !currentstamp t +let current_stamp () = !currentstamp +let bump_stamp_counter t = currentstamp := max !currentstamp t let reinit_level = ref (-1) diff --git a/typing/ident.mli b/typing/ident.mli index 40db52210f..62e1a5fdda 100644 --- a/typing/ident.mli +++ b/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 current_time: unit -> int -val set_current_time: int -> unit +val stamp: t -> int +val scope: t -> int + +val current_stamp: unit -> int +val bump_stamp_counter: int -> unit val reinit: unit -> unit type 'a tbl diff --git a/typing/parmatch.ml b/typing/parmatch.ml index c7ffba145c..d05fefe5a2 100644 --- a/typing/parmatch.ml +++ b/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 diff --git a/typing/path.ml b/typing/path.ml index a029d92175..4fdbeac3f5 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -53,10 +53,10 @@ let exists_free ids p = | None -> false | _ -> true -let rec binding_time = function - Pident id -> Ident.binding_time id - | Pdot(p, _s, _pos) -> binding_time p - | Papply(p1, p2) -> max (binding_time p1) (binding_time p2) +let rec scope = function + Pident id -> Ident.scope id + | Pdot(p, _s, _pos) -> scope p + | Papply(p1, p2) -> max (scope p1) (scope p2) let kfalse _ = false diff --git a/typing/path.mli b/typing/path.mli index 46549571dc..ea78fb0bd2 100644 --- a/typing/path.mli +++ b/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 diff --git a/typing/predef.ml b/typing/predef.ml index d7dce933f6..29f2759c3e 100644 --- a/typing/predef.ml +++ b/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 diff --git a/typing/printtyp.ml b/typing/printtyp.ml index fc27d01c8d..3177b00e7d 100644 --- a/typing/printtyp.ml +++ b/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@]" diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 4e70b0f357..ec8b4f2e4b 100644 --- a/typing/typeclass.ml +++ b/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,10 +237,11 @@ 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; - val_kind = Val_unbound Val_unbound_instance_variable; - val_attributes = []; - Types.val_loc = loc} val_env + Env.enter_value lab + {val_type = ty; + val_kind = Val_unbound Val_unbound_instance_variable; + val_attributes = []; + Types.val_loc = loc} val_env in (id, val_env, Env.add_value ?check id {val_type = ty; val_kind = kind; @@ -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 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, + 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 diff --git a/typing/typecore.ml b/typing/typecore.ml index a77d6e310d..fbc69ed01e 100644 --- a/typing/typecore.ml +++ b/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,8 +1122,10 @@ 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 - enter_variable loc name ty sp.ppat_attributes + if name.txt = "*extension*" then + Ident.create_var name.txt + else + enter_variable loc name ty sp.ppat_attributes in rp k { pat_desc = Tpat_var (id, name); @@ -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 - Ctype.init_def(Ident.current_time()); + let scope = get_current_level () in + 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 (id, new_env) = Env.enter_type name decl env in - Ctype.init_def(Ident.current_time()); + let scope = get_current_level () in + let (id, new_env) = Env.enter_type ~scope name decl env in + 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 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 do_init = may_contain_gadts || needs_exhaust_check 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 lev = - if do_init then init_env () else get_current_level () - in + let unused_check delayed = 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 - add_delayed_check (fun () -> unused_check do_init) + if contains_polyvars then + add_delayed_check (fun () -> unused_check true) else + (* Check for unused cases, do not delay because of gadts *) unused_check false; - (* Check for unused cases, do not delay because of gadts *) - if do_init then begin + if may_contain_gadts then begin end_def (); (* Ensure that existential types do not escape *) unify_exp_types loc env (instance ty_res) (newvar ()) ; diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 60b9b46e02..cfb875e403 100644 --- a/typing/typedecl.ml +++ b/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 diff --git a/typing/typemod.ml b/typing/typemod.ml index 2d134d7f88..987e1ebbcb 100644 --- a/typing/typemod.ml +++ b/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 - Ctype.init_def(Ident.current_time()); (* PR#6513 *) + Env.enter_module ~scope ~arg:true param.txt (Btype.default_mty ty_arg) + 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 - | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in - Ctype.init_def(Ident.current_time()); (* PR#6981 *) + match ty_arg with + | None -> (Ident.create ~scope "*", env), false + | 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; |