diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/matching.ml | 4 | ||||
| -rw-r--r-- | bytecomp/translclass.ml | 31 | ||||
| -rw-r--r-- | bytecomp/translmod.ml | 2 | ||||
| -rw-r--r-- | bytecomp/typeopt.ml | 2 |
4 files changed, 20 insertions, 19 deletions
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 184626dfa6..f7caf464e7 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2337,8 +2337,8 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with ctx pm | Tpat_variant(lab, _, row) -> compile_test (compile_match repr partial) partial - (divide_variant row) - (combine_variant row arg partial) + (divide_variant !row) + (combine_variant !row arg partial) ctx pm | _ -> assert false end diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index fd2b91de08..8bad09eb39 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -71,10 +71,10 @@ let transl_val tbl create name = Lapply (oo_prim (if create then "new_variable" else "get_variable"), [Lvar tbl; transl_label name]) -let transl_vals tbl create vals rem = +let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(StrictOpt, id, transl_val tbl create name, rem)) + Llet(strict, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -88,7 +88,7 @@ let meths_super tbl meths inh_meths = inh_meths [] let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false vals + transl_vals tbl false StrictOpt vals (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) @@ -203,22 +203,22 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let bind_method tbl lab id cl_init = - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + Llet(Strict, id, Lapply (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), cl_init) let bind_methods tbl meths vals cl_init = let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in 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 vals 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 i = ref (len + nvals) in let getter, names = if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(StrictOpt, ids, + Llet(Strict, ids, Lapply (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right @@ -246,6 +246,8 @@ let rec index a = function | b :: l -> if b = a then 0 else 1 + index a l +let bind_id_as_val (id, _) = ("", id) + let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> @@ -308,16 +310,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in @@ -583,6 +585,9 @@ open M Si ids=0 (objet immediat), alors on ne conserve que env_init. *) +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) @@ -600,10 +605,6 @@ let transl_class ids cl_id arity pub_meths cl vflag = let subst env lam i0 new_ids' = let fv = free_variables lam in let fv = List.fold_right IdentSet.remove !new_ids' fv in - (* IdentSet.iter - (fun id -> - if not (List.mem id new_ids) then prerr_endline (Ident.name id)) - fv; *) let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in (* need to handle methods specially (PR#3576) *) let fm = IdentSet.diff (free_methods lam) meth_ids in diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index f34047b3bd..a2a221eaf1 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -333,7 +333,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(Alias, mid, transl_module Tcoerce_none None modl, + Llet(Strict, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) (* Update forward declaration in Translcore *) diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 8838145468..6e8075a3a0 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -52,7 +52,7 @@ let maybe_pointer exp = let array_element_kind env ty = let ty = Ctype.repr (Ctype.expand_head env ty) in match ty.desc with - Tvar -> + Tvar | Tunivar -> Pgenarray | Tconstr(p, args, abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then |