diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/bytegen.ml | 8 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 10 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 2 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 50 | ||||
| -rw-r--r-- | bytecomp/translmod.ml | 4 | ||||
| -rw-r--r-- | bytecomp/typeopt.ml | 5 |
6 files changed, 60 insertions, 19 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index af5f0a3fd..be884ded5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -144,8 +144,9 @@ let rec size_of_lambda = function | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with - | Record_regular -> RHS_block size + | Record_regular | Record_inlined _ -> RHS_block size | Record_float -> RHS_floatblock size + | Record_extension -> RHS_block (size + 1) end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body @@ -154,7 +155,10 @@ let rec size_of_lambda = function RHS_block (List.length args) | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) | Lprim (Pmakearray Pgenarray, args) -> assert false - | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> + RHS_block size + | Lprim (Pduprecord (Record_extension, size), args) -> + RHS_block (size + 1) | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam | Lsequence (lam, lam') -> size_of_lambda lam' diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 8ab6cec8b..cba32391e 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1348,7 +1348,9 @@ let make_constr_matching p def ctx = function | ((arg, mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - match cstr.cstr_tag with + if cstr.cstr_inlined <> None then + (arg, Alias) :: argl + else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl | Cstr_extension _ -> @@ -1628,8 +1630,10 @@ let make_record_matching all_labels def = function let lbl = all_labels.(pos) in let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_extension -> Pfield (lbl.lbl_pos + 1) + in let str = match lbl.lbl_mut with Immutable -> Alias diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index d528a3574..1b9085edd 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -84,7 +84,9 @@ let print_bigarray name unsafe kind ppf layout = let record_rep ppf r = match r with | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" + | Record_extension -> fprintf ppf "ext" ;; let string_of_loc_kind = function diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 876abaa94..14f8b0659 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -746,7 +746,10 @@ and transl_exp0 e = end | Texp_construct(_, cstr, args) -> let ll = transl_list args in - begin match cstr.cstr_tag with + if cstr.cstr_inlined <> None then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with Cstr_constant n -> Lconst(Const_pointer n) | Cstr_block n -> @@ -776,20 +779,26 @@ and transl_exp0 e = [Lconst(Const_base(Const_int tag)); lam]) end | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr + transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list + opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, _, lbl) -> let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_extension -> Pfield (lbl.lbl_pos + 1) + in Lprim(access, [transl_exp arg]) | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_extension -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) + in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> let kind = array_kind e in @@ -1071,7 +1080,7 @@ and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), [self; transl_normal_path var; transl_exp expr]) -and transl_record all_labels repres lbl_expr_list opt_init_expr = +and transl_record env all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in (* Determine if there are "enough" new fields *) if 3 + 2 * List.length lbl_expr_list >= size @@ -1086,7 +1095,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = for i = 0 to Array.length all_labels - 1 do let access = match all_labels.(i).lbl_repres with - Record_regular -> Pfield i + Record_regular | Record_inlined _ -> Pfield i + | Record_extension -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1104,13 +1114,26 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - Record_regular -> Lconst(Const_block(0, cl)) + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) + | Record_extension -> + raise Not_constant with Not_constant -> match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) - | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in + | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) + | Record_float -> Lprim(Pmakearray Pfloatarray, ll) + | Record_extension -> + let path = + match all_labels.(0).lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in + let slot = transl_path env path in + Lprim(Pmakeblock(0, mut), slot :: ll) + in begin match opt_init_expr with None -> lam | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) @@ -1124,8 +1147,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = let update_field (_, lbl, expr) cont = let upd = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_extension -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) + in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in begin match opt_init_expr with None -> assert false diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index dc7d2d7a6..1f475565f 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -805,9 +805,13 @@ let transl_toplevel_item item = let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; transl_type_extension item.str_env None tyext (make_sequence toploop_setvalue_id idents) | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; toploop_setvalue ext.ext_id (transl_extension_constructor item.str_env None ext) | Tstr_module {mb_id=id; mb_expr=modl} -> diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index c96e32b66..eb8c9435e 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun c -> c.Types.cd_args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,8 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = Cstr_tuple []) + cstrs -> Pintarray | {type_kind = _} -> Paddrarray |