diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/printlambda.ml | 7 | ||||
| -rw-r--r-- | bytecomp/translmod.ml | 49 |
2 files changed, 42 insertions, 14 deletions
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 8774e72b8..46e47ec08 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/translmod.ml b/bytecomp/translmod.ml index 189cf23ba..1dc89a1b5 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -35,10 +35,17 @@ let rec apply_coercion restr arg = match restr with Tcoerce_none -> arg - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure(pos_cc_list, id_pos_list) -> name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list)) + let lam = + Lprim(Pmakeblock(0, Immutable), + List.map (apply_coercion_field id) pos_cc_list) in + let fv = free_variables lam in + List.fold_left (fun lam (id',pos,c) -> + if IdentSet.mem id' fv then + Llet(Alias,id',apply_coercion c (Lprim(Pfield pos,[Lvar id])),lam) + else lam) + lam id_pos_list) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in name_lambda arg (fun id -> @@ -62,19 +69,25 @@ 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) - | (Tcoerce_alias (path, c1), c2) -> + | (c1, Tcoerce_alias (path, c2)) -> Tcoerce_alias (path, compose_coercions c1 c2) | (_, _) -> fatal_error "Translmod.compose_coercions" @@ -292,15 +305,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) + pos_cc_list)) + (*id_pos_list*) | _ -> fatal_error "Translmod.transl_structure" end @@ -326,6 +343,11 @@ and transl_structure fields cc rootpath = function transl_structure (id :: fields) cc rootpath rem) | Tstr_module mb -> let id = mb.mb_id in + (* let rec strict m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> strict m + | _ -> Strict in *) Llet(Strict, id, transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr, transl_structure (id :: fields) cc rootpath rem) @@ -621,7 +643,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 [] -> @@ -773,7 +796,8 @@ 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))) @@ -796,7 +820,8 @@ 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 |