diff options
Diffstat (limited to 'bytecomp/translmod.ml')
| -rw-r--r-- | bytecomp/translmod.ml | 146 |
1 files changed, 104 insertions, 42 deletions
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 10915d8533..4b3141ad90 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -44,32 +44,48 @@ let transl_exception path decl = | Some p -> Path.name p in Lprim(prim_set_oo_id, - [Lprim(Pmakeblock(Obj.object_tag, Immutable), + [Lprim(Pmakeblock(Obj.object_tag, Mutable), [Lconst(Const_base(Const_string (name,None))); Lconst(Const_base(Const_int 0))])]) (* 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 -> @@ -137,6 +161,8 @@ let init_shape modl = match Mtype.scrape env mty with Mty_ident _ -> raise Not_found + | Mty_alias _ -> + Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) | Mty_functor(id, arg, res) -> @@ -264,9 +290,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 +309,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 +334,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 +367,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 +402,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 +411,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 @@ -414,7 +455,7 @@ let rec defined_idents = function List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ defined_idents rem - | Tstr_attribute _ -> [] + | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -437,7 +478,7 @@ let rec more_idents = function | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} -> all_idents str.str_items @ more_idents rem | Tstr_module _ -> more_idents rem - | Tstr_attribute _ -> [] + | Tstr_attribute _ -> more_idents rem and all_idents = function [] -> [] @@ -461,7 +502,7 @@ and all_idents = function | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} -> mb_id :: all_idents str.str_items @ all_idents rem | Tstr_module mb -> mb.mb_id :: all_idents rem - | Tstr_attribute _ -> [] + | Tstr_attribute _ -> all_idents rem (* A variant of transl_structure used to compile toplevel structure definitions @@ -509,8 +550,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 +568,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 +620,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 +673,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 +762,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 @@ -782,17 +823,23 @@ let get_component = function let transl_package component_names target_name coercion = let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in + Lprim(Psetglobal target_name, [apply_coercion Strict coercion components]) + (* + let components = 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 Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) let transl_store_package component_names target_name coercion = let rec make_sequence fn pos arg = @@ -808,15 +855,30 @@ 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) -> + let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) + in + let blk = Ident.create "block" in + (List.length pos_cc_list, + Llet (Strict, blk, apply_coercion Strict coercion components, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal target_name, []); + Lprim(Pfield pos, [Lvar blk])])) + 0 pos_cc_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 (* Error report *) |