summaryrefslogtreecommitdiffstats
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/lambda.ml13
-rw-r--r--bytecomp/lambda.mli5
-rw-r--r--bytecomp/matching.ml6
-rw-r--r--bytecomp/printlambda.ml7
-rw-r--r--bytecomp/translclass.ml22
-rw-r--r--bytecomp/translcore.ml20
-rw-r--r--bytecomp/translmod.ml120
-rw-r--r--bytecomp/translobj.ml9
8 files changed, 134 insertions, 68 deletions
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index b64dee2ac..aa56c31fa 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -258,10 +258,10 @@ and sameswitch sw1 sw2 =
| (Some a1, Some a2) -> same a1 a2
| _ -> false)
-let name_lambda arg fn =
+let name_lambda strict arg fn =
match arg with
Lvar id -> fn id
- | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id)
+ | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id)
let name_lambda_list args fn =
let rec name_list names = function
@@ -383,14 +383,19 @@ let rec patch_guarded patch = function
(* Translate an access path *)
-let rec transl_path = function
+let rec transl_normal_path = function
Pident id ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
| Pdot(p, s, pos) ->
- Lprim(Pfield pos, [transl_path p])
+ Lprim(Pfield pos, [transl_normal_path p])
| Papply(p1, p2) ->
fatal_error "Lambda.transl_path"
+(* Translation of value identifiers *)
+
+let transl_path ?(loc=Location.none) env path =
+ transl_normal_path (Env.normalize_path (Some loc) env path)
+
(* Compile a sequence of expressions *)
let rec make_sequence fn = function
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index ccc5fc640..904ea6fd7 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -207,7 +207,7 @@ and lambda_event_kind =
val same: lambda -> lambda -> bool
val const_unit: structured_constant
val lambda_unit: lambda
-val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
+val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
val iter: (lambda -> unit) -> lambda -> unit
@@ -215,7 +215,8 @@ module IdentSet: Set.S with type elt = Ident.t
val free_variables: lambda -> IdentSet.t
val free_methods: lambda -> IdentSet.t
-val transl_path: Path.t -> lambda
+val transl_normal_path: Path.t -> lambda (* Path.t is already normal *)
+val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda
val subst_lambda: lambda Ident.tbl -> lambda -> lambda
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 7387ea64a..b6ba0ac86 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -2163,7 +2163,9 @@ let combine_constructor arg ex_pat cstr partial ctx def
else Lprim(Pfield 0, [arg])
in
Lifthenelse(Lprim(Pintcomp Ceq,
- [slot; transl_path path]),
+ [slot;
+ transl_path ~loc:ex_pat.pat_loc
+ ex_pat.pat_env path]),
act, rem)
| _ -> assert false)
tests default in
@@ -2734,7 +2736,7 @@ let partial_function loc () =
(* [Location.get_pos_info] is too expensive *)
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_match_failure;
+ [transl_normal_path Predef.path_match_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 3ef160fe2..beb268480 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -255,12 +255,15 @@ let rec lam ppf = function
fprintf ppf ")" in
fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
| Llet(str, id, arg, body) ->
+ let kind = function
+ Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in
let rec letbody = function
| Llet(str, id, arg, body) ->
- fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+ fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg;
letbody body
| expr -> expr in
- fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+ fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s@ %a@]"
+ Ident.print id (kind str) lam arg;
let expr = letbody body in
fprintf ppf ")@]@ %a)@]" lam expr
| Lletrec(id_arg_list, body) ->
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index b22c0adaf..55ddab3bc 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -115,6 +115,9 @@ let name_pattern default p =
| Tpat_alias(p, id, _) -> id
| _ -> Ident.create default
+let normalize_cl_path cl path =
+ Env.normalize_path (Some cl.cl_loc) cl.cl_env path
+
let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
@@ -124,7 +127,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
match envs with None -> []
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
in
- ((envs, (obj_init, path)::inh_init),
+ ((envs, (obj_init, normalize_cl_path cl path)
+ ::inh_init),
mkappl(Lvar obj_init, env @ [obj]))
| Tcl_structure str ->
create_object cl_table obj (fun obj ->
@@ -253,7 +257,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
Tcl_ident ( path, _, _) ->
begin match inh_init with
(obj_init, path')::inh_init ->
- let lpath = transl_path path in
+ let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
(inh_init,
Llet (Strict, obj_init,
mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
@@ -331,8 +335,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
- assert (Path.same path path');
- let lpath = transl_path path in
+ assert (Path.same (normalize_cl_path cl path) path');
+ let lpath = transl_normal_path path' in
let inh = Ident.create "inh"
and ofs = List.length vals + 1
and valids, methids = super in
@@ -398,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf =
try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
with Not_found -> raise Exit
end;
- (path, obj_init)
+ (normalize_cl_path cl path, obj_init)
| Tcl_fun (_, pat, _, cl, partial) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
let build params rem =
@@ -446,7 +450,7 @@ let transl_class_rebind ids cl vf =
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
let id = (obj_init' = lfunction [self] obj_init0) in
- if id then transl_path path else
+ if id then transl_normal_path path else
let cla = Ident.create "class"
and new_init = Ident.create "new_init"
@@ -456,7 +460,7 @@ let transl_class_rebind ids cl vf =
Llet(
Strict, new_init, lfunction [obj_init] obj_init',
Llet(
- Alias, cla, transl_path path,
+ Alias, cla, transl_normal_path path,
Lprim(Pmakeblock(0, Immutable),
[mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table]
@@ -741,7 +745,7 @@ let transl_class ids cl_id pub_meths cl vflag =
Lprim(Pmakeblock(0, Immutable),
menv :: List.map (fun id -> Lvar id) !new_ids_init)
and linh_envs =
- List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+ List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p]))
(List.rev inh_init)
in
let make_envs lam =
@@ -758,7 +762,7 @@ let transl_class ids cl_id pub_meths cl vflag =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
let inh_keys =
- List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
+ List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in
let lclass lam =
Llet(Strict, class_init,
Lfunction(Curried, [cla], def_ids cla cl_init), lam)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index d63381631..3a6cf7187 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -589,7 +589,7 @@ let assert_failed exp =
Location.get_pos_info exp.exp_loc.Location.loc_start in
Lprim(Praise Raise_regular, [event_after exp
(Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_assert_failure;
+ [transl_normal_path Predef.path_assert_failure;
Lconst(Const_block(0,
[Const_base(Const_string (fname, None));
Const_base(Const_int line);
@@ -635,7 +635,7 @@ and transl_exp0 e =
| Texp_ident(path, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
- transl_path path
+ transl_path ~loc:e.exp_loc e.exp_env path
| Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
| Texp_constant cst ->
Lconst(Const_base cst)
@@ -734,7 +734,7 @@ and transl_exp0 e =
Lprim(Pmakeblock(n, Immutable), ll)
end
| Cstr_exception (path, _) ->
- let slot = transl_path path in
+ let slot = transl_path ~loc:e.exp_loc e.exp_env path in
if cstr.cstr_arity = 0 then slot
else Lprim(Pmakeblock(0, Immutable), slot :: ll)
end
@@ -813,16 +813,18 @@ and transl_exp0 e =
Lsend (kind, tag, obj, cache, e.exp_loc)
in
event_after e lam
- | Texp_new (cl, _, _) ->
- Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
+ | Texp_new (cl, {Location.loc=loc}, _) ->
+ Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]),
+ [lambda_unit], Location.none)
| Texp_instvar(path_self, path, _) ->
- Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+ Lprim(Parrayrefu Paddrarray,
+ [transl_normal_path path_self; transl_normal_path path])
| Texp_setinstvar(path_self, path, _, expr) ->
- transl_setinstvar (transl_path path_self) path expr
+ transl_setinstvar (transl_normal_path path_self) path expr
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
Llet(Strict, cpy,
- Lapply(Translobj.oo_prim "copy", [transl_path path_self],
+ Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self],
Location.none),
List.fold_right
(fun (path, _, expr) rem ->
@@ -1044,7 +1046,7 @@ and transl_let rec_flag pat_expr_list body =
and transl_setinstvar self var expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
- [self; transl_path var; transl_exp expr])
+ [self; transl_normal_path var; transl_exp expr])
and transl_record all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 10915d853..9825e5065 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -50,26 +50,42 @@ let transl_exception path decl =
(* Compile a coercion *)
-let rec apply_coercion restr arg =
+let rec apply_coercion strict restr arg =
match restr with
Tcoerce_none ->
arg
- | Tcoerce_structure pos_cc_list ->
- name_lambda arg (fun id ->
- Lprim(Pmakeblock(0, Immutable),
- List.map (apply_coercion_field id) pos_cc_list))
+ | Tcoerce_structure(pos_cc_list, id_pos_list) ->
+ name_lambda strict arg (fun id ->
+ let lam =
+ Lprim(Pmakeblock(0, Immutable),
+ List.map (apply_coercion_field id) pos_cc_list) in
+ let fv = free_variables lam in
+ let (lam,s) =
+ List.fold_left (fun (lam,s) (id',pos,c) ->
+ if IdentSet.mem id' fv then
+ let id'' = Ident.create (Ident.name id') in
+ (Llet(Alias,id'',
+ apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam),
+ Ident.add id' (Lvar id'') s)
+ else (lam,s))
+ (lam, Ident.empty) id_pos_list
+ in
+ if s == Ident.empty then lam else subst_lambda s lam)
| Tcoerce_functor(cc_arg, cc_res) ->
let param = Ident.create "funarg" in
- name_lambda arg (fun id ->
+ name_lambda strict arg (fun id ->
Lfunction(Curried, [param],
- apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
+ apply_coercion Strict cc_res
+ (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)],
Location.none))))
| Tcoerce_primitive p ->
transl_primitive Location.none p
+ | Tcoerce_alias (path, cc) ->
+ name_lambda strict arg
+ (fun id -> apply_coercion Alias cc (transl_normal_path path))
and apply_coercion_field id (pos, cc) =
- apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
+ apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id]))
(* Compose two coercions
apply_coercion c1 (apply_coercion c2 e) behaves like
@@ -79,18 +95,26 @@ let rec compose_coercions c1 c2 =
match (c1, c2) with
(Tcoerce_none, c2) -> c2
| (c1, Tcoerce_none) -> c1
- | (Tcoerce_structure pc1, Tcoerce_structure pc2) ->
+ | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
let v2 = Array.of_list pc2 in
+ let ids1 =
+ List.map (fun (id,pos1,c1) ->
+ let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2))
+ ids1
+ in
Tcoerce_structure
(List.map
(function (p1, Tcoerce_primitive p) ->
(p1, Tcoerce_primitive p)
| (p1, c1) ->
let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
- pc1)
+ pc1,
+ ids1 @ ids2)
| (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
Tcoerce_functor(compose_coercions arg2 arg1,
compose_coercions res1 res2)
+ | (c1, Tcoerce_alias (path, c2)) ->
+ Tcoerce_alias (path, compose_coercions c1 c2)
| (_, _) ->
fatal_error "Translmod.compose_coercions"
@@ -119,7 +143,7 @@ let field_path path field =
let mod_prim name =
try
- transl_path
+ transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
Env.empty))
with Not_found ->
@@ -135,7 +159,8 @@ let undefined_location loc =
let init_shape modl =
let rec init_shape_mod env mty =
match Mtype.scrape env mty with
- Mty_ident _ ->
+ Mty_ident _
+ | Mty_alias _ ->
raise Not_found
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
@@ -264,9 +289,13 @@ let rec bound_value_identifiers = function
(* Compile a module expression *)
let rec transl_module cc rootpath mexp =
+ match mexp.mod_type with
+ Mty_alias _ -> apply_coercion Alias cc lambda_unit
+ | _ ->
match mexp.mod_desc with
Tmod_ident (path,_) ->
- apply_coercion cc (transl_path path)
+ apply_coercion StrictOpt cc
+ (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
| Tmod_structure str ->
transl_struct [] cc rootpath str
| Tmod_functor( param, _, mty, body) ->
@@ -279,20 +308,21 @@ let rec transl_module cc rootpath mexp =
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
Lfunction(Curried, [param'],
- Llet(Alias, param, apply_coercion ccarg (Lvar param'),
+ Llet(Alias, param,
+ apply_coercion Alias ccarg (Lvar param'),
transl_module ccres bodypath body))
| _ ->
fatal_error "Translmod.transl_module")
cc
| Tmod_apply(funct, arg, ccarg) ->
oo_wrap mexp.mod_env true
- (apply_coercion cc)
+ (apply_coercion Strict cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg], mexp.mod_loc))
| Tmod_constraint(arg, mty, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
- apply_coercion cc (Translcore.transl_exp arg)
+ apply_coercion Strict cc (Translcore.transl_exp arg)
and transl_struct fields cc rootpath str =
transl_structure fields cc rootpath str.str_items
@@ -303,15 +333,19 @@ and transl_structure fields cc rootpath = function
Tcoerce_none ->
Lprim(Pmakeblock(0, Immutable),
List.map (fun id -> Lvar id) (List.rev fields))
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure(pos_cc_list, id_pos_list) ->
+ (* ignore id_pos_list as the ids are already bound *)
let v = Array.of_list (List.rev fields) in
- Lprim(Pmakeblock(0, Immutable),
+ (*List.fold_left
+ (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*)
+ (Lprim(Pmakeblock(0, Immutable),
List.map
(fun (pos, cc) ->
match cc with
Tcoerce_primitive p -> transl_primitive Location.none p
- | _ -> apply_coercion cc (Lvar v.(pos)))
- pos_cc_list)
+ | _ -> apply_coercion Strict cc (Lvar v.(pos)))
+ pos_cc_list))
+ (*id_pos_list*)
| _ ->
fatal_error "Translmod.transl_structure"
end
@@ -332,12 +366,12 @@ and transl_structure fields cc rootpath = function
let id = decl.cd_id in
Llet(Strict, id, transl_exception (field_path rootpath id) decl,
transl_structure (id :: fields) cc rootpath rem)
- | Tstr_exn_rebind( id, _, path, _, _) ->
- Llet(Strict, id, transl_path path,
+ | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+ Llet(Strict, id, transl_path ~loc item.str_env path,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_module mb ->
let id = mb.mb_id in
- Llet(Strict, id,
+ Llet(pure_module mb.mb_expr, id,
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_recmodule bindings ->
@@ -367,7 +401,7 @@ and transl_structure fields cc rootpath = function
| id :: ids ->
Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
rebind_idents (pos + 1) (id :: newfields) ids) in
- Llet(Strict, mid, transl_module Tcoerce_none None modl,
+ Llet(pure_module modl, mid, transl_module Tcoerce_none None modl,
rebind_idents 0 fields ids)
| Tstr_modtype _
@@ -376,6 +410,12 @@ and transl_structure fields cc rootpath = function
| Tstr_attribute _ ->
transl_structure fields cc rootpath rem
+and pure_module m =
+ match m.mod_desc with
+ Tmod_ident _ -> Alias
+ | Tmod_constraint (m,_,_,_) -> pure_module m
+ | _ -> Strict
+
(* Update forward declaration in Translcore *)
let _ =
Translcore.transl_module := transl_module
@@ -509,8 +549,8 @@ let transl_store_structure glob map prims str =
let lam = transl_exception (field_path rootpath id) decl in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
- | Tstr_exn_rebind( id, _, path, _, _) ->
- let lam = subst_lambda subst (transl_path path) in
+ | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+ let lam = subst_lambda subst (transl_path ~loc item.str_env path) in
Lsequence(Llet(Strict, id, lam, store_ident id),
transl_store rootpath (add_ident false id subst) rem)
| Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} ->
@@ -527,8 +567,7 @@ let transl_store_structure glob map prims str =
transl_store rootpath (add_ident true id subst)
rem)))
| Tstr_module{mb_id=id; mb_expr=modl} ->
- let lam =
- transl_module Tcoerce_none (field_path rootpath id) modl in
+ let lam = transl_module Tcoerce_none (field_path rootpath id) modl in
(* Careful: the module value stored in the global may be different
from the local module value, in case a coercion is applied.
If so, keep using the local module value (id) in the remainder of
@@ -580,7 +619,7 @@ let transl_store_structure glob map prims str =
and store_ident id =
try
let (pos, cc) = Ident.find_same id map in
- let init_val = apply_coercion cc (Lvar id) in
+ let init_val = apply_coercion Alias cc (Lvar id) in
Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
with Not_found ->
fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
@@ -633,7 +672,8 @@ let build_ident_map restr idlist more_ids =
match restr with
Tcoerce_none ->
natural_map 0 Ident.empty [] idlist
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
+ (* ignore _id_pos_list as the ids are already bound *)
let idarray = Array.of_list idlist in
let rec export_map pos map prims undef = function
[] ->
@@ -721,14 +761,14 @@ let transl_toplevel_item item =
(make_sequence toploop_setvalue_id idents)
| Tstr_exception decl ->
toploop_setvalue decl.cd_id (transl_exception None decl)
- | Tstr_exn_rebind(id, _, path, _, _) ->
- toploop_setvalue id (transl_path path)
+ | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) ->
+ toploop_setvalue id (transl_path ~loc item.str_env path)
| Tstr_module {mb_id=id; mb_expr=modl} ->
(* we need to use the unique name for the module because of issues
with "open" (PR#1672) *)
set_toplevel_unique_name id;
- toploop_setvalue id
- (transl_module Tcoerce_none (Some(Pident id)) modl)
+ let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
+ toploop_setvalue id lam
| Tstr_recmodule bindings ->
let idents = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
@@ -785,10 +825,11 @@ let transl_package component_names target_name coercion =
match coercion with
Tcoerce_none ->
List.map get_component component_names
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+ (* ignore id_pos_list as the ids are already bound *)
let g = Array.of_list component_names in
List.map
- (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
+ (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos)))
pos_cc_list
| _ ->
assert false in
@@ -808,14 +849,15 @@ let transl_store_package component_names target_name coercion =
[Lprim(Pgetglobal target_name, []);
get_component id]))
0 component_names)
- | Tcoerce_structure pos_cc_list ->
+ | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+ (* ignore id_pos_list as the ids are already bound *)
let id = Array.of_list component_names in
(List.length pos_cc_list,
make_sequence
(fun dst (src, cc) ->
Lprim(Psetfield(dst, false),
[Lprim(Pgetglobal target_name, []);
- apply_coercion cc (get_component id.(src))]))
+ apply_coercion Strict cc (get_component id.(src))]))
0 pos_cc_list)
| _ -> assert false
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 437c3d71e..7f0d8577e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -20,7 +20,7 @@ open Lambda
let oo_prim name =
try
- transl_path
+ transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
@@ -93,12 +93,19 @@ let prim_makearray =
{ prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false }
+(* Also use it for required globals *)
let transl_label_init expr =
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
+ let expr =
+ List.fold_right
+ (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+ (Env.get_required_globals ()) expr
+ in
+ Env.reset_required_globals ();
reset_labels ();
expr
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-22 12:10:40 +0000