diff options
| -rw-r--r-- | asmcomp/cmmgen.ml | 4 | ||||
| -rw-r--r-- | bytecomp/bytegen.ml | 7 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 2 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 4 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 16 | ||||
| -rw-r--r-- | typing/datarepr.ml | 2 | ||||
| -rw-r--r-- | typing/includecore.ml | 7 | ||||
| -rw-r--r-- | typing/typedecl.ml | 4 | ||||
| -rw-r--r-- | typing/types.ml | 5 | ||||
| -rw-r--r-- | typing/types.mli | 5 |
10 files changed, 34 insertions, 22 deletions
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 5de630631..0e92fc499 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -633,8 +633,10 @@ let rec expr_size env = function RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) - | Uprim (Pduprecord (Record_regular _, sz), _, _) -> + | Uprim (Pduprecord (Record_regular | Record_inlined _, sz), _, _) -> RHS_block sz + | Uprim (Pduprecord (Record_exception _, sz), _, _) -> + RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz | Usequence(exp, exp') -> diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 3df4a151c..90764de6b 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -144,7 +144,7 @@ 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_exception _ -> RHS_block (size + 1) end @@ -155,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_exception _, 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 1450fad00..3ec3611ba 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1597,7 +1597,7 @@ 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_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos | Record_exception _ -> Pfield (lbl.lbl_pos + 1) in diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 0e3300b52..7e9c197e3 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -83,8 +83,8 @@ let print_bigarray name unsafe kind ppf layout = let record_rep ppf r = match r with - | Record_regular 0 -> fprintf ppf "regular" - | Record_regular i -> fprintf ppf "regular (tag %i)" i + | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" | Record_exception p -> fprintf ppf "exn (%s)" (Path.name p) ;; diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 18d8622d1..a2d15bf77 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -762,7 +762,7 @@ and transl_exp0 e = | Texp_field(arg, _, lbl) -> let access = match lbl.lbl_repres with - Record_regular _ -> Pfield lbl.lbl_pos + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos | Record_exception _ -> Pfield (lbl.lbl_pos + 1) in @@ -770,7 +770,8 @@ and transl_exp0 e = | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with - Record_regular _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) | Record_float -> Psetfloatfield lbl.lbl_pos | Record_exception _ -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) @@ -1072,7 +1073,7 @@ and transl_record env 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_exception _ -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) @@ -1091,14 +1092,16 @@ and transl_record env 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 tag -> Lconst(Const_block(tag, 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_exception _ -> raise Not_constant with Not_constant -> match repres with - Record_regular tag -> Lprim(Pmakeblock(tag, mut), ll) + Record_regular -> Lprim(Pmakeblock(0, mut), ll) + | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) | Record_float -> Lprim(Pmakearray Pfloatarray, ll) | Record_exception path -> let slot = transl_path env path in @@ -1117,7 +1120,8 @@ and transl_record env 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_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) | Record_float -> Psetfloatfield lbl.lbl_pos | Record_exception _ -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) in diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 3c908464b..5c1f987b4 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -108,7 +108,7 @@ let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; - lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular 0; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; lbl_private = Public; lbl_loc = Location.none; lbl_attributes = []; diff --git a/typing/includecore.ml b/typing/includecore.ml index 1514a85cd..f783e49a1 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -145,8 +145,8 @@ let report_type_mismatch0 first second decl ppf err = (Ident.name s) (if b then second else first) decl | Record_representation (r1, r2) -> let repr = function - | Record_regular 0 -> "regular" - | Record_regular i -> Printf.sprintf"inline record (tag %i)" i + | Record_regular -> "regular" + | Record_inlined i -> Printf.sprintf"inlined(tag %i)" i | Record_float -> "unboxed float" | Record_exception p -> Printf.sprintf "exception %s" (Path.name p) in @@ -204,7 +204,8 @@ let rec compare_records env decl1 decl2 n labels1 labels2 = let record_representations r1 r2 = match r1, r2 with - | Record_regular i, Record_regular j -> i = j + | Record_regular, Record_regular -> true + | Record_inlined i, Record_inlined j -> i = j | Record_float, Record_float -> true | Record_exception _, Record_exception _ -> true (* allow a different path to support exception rebinding *) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0a99a3c70..6bab0c06d 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -279,12 +279,12 @@ let transl_declaration ?exnid env sdecl id = | [{txt="#tag#"}, PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_int tag)}, _)}]] -> begin match exnid with | Some id -> Record_exception (Path.Pident id) - | None -> Record_regular tag + | None -> Record_inlined tag end | _ -> if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' then Record_float - else Record_regular 0 in + else Record_regular in Ttype_record lbls, Type_record(lbls', rep) in let (tman, man) = match sdecl.ptype_manifest with diff --git a/typing/types.ml b/typing/types.ml index 505ca70aa..3eff6c70a 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -143,9 +143,10 @@ type label_description = } and record_representation = - Record_regular of int (* All fields are boxed / tagged *) + Record_regular (* All fields are boxed / tagged *) + | Record_inlined of int (* Same, for inlined records *) | Record_float (* All fields are floats *) - | Record_exception of Path.t + | Record_exception of Path.t (* Inlined record under exception *) (* Variance *) diff --git a/typing/types.mli b/typing/types.mli index ac81632e5..8cf172a8f 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -140,9 +140,10 @@ type label_description = } and record_representation = - Record_regular of int (* All fields are boxed / tagged *) + Record_regular (* All fields are boxed / tagged *) + | Record_inlined of int (* Same, for inlined records *) | Record_float (* All fields are floats *) - | Record_exception of Path.t + | Record_exception of Path.t (* Inlined record under exception *) (* Variance *) |