summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/lambda.ml6
-rw-r--r--bytecomp/matching.ml24
-rw-r--r--bytecomp/simplif.ml2
-rw-r--r--bytecomp/translclass.ml52
-rw-r--r--bytecomp/translcore.ml16
-rw-r--r--bytecomp/translmod.ml14
-rw-r--r--bytecomp/translobj.ml4
-rw-r--r--bytecomp/translprim.ml4
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
View Lorry Controller Status