Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #516 from chambart/improve_texp_record_representation 

Improve Texp_record constructor representation
master
Pierre Chambart 2016-07-12 13:29:31 +02:00 committed by GitHub
parent 9e21876a28 316756fc56
commit 1ae28b98cf
13 changed files with 331 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Changes
View File

@ -82,7 +82,7 @@ OCaml 4.04.0:
C external. This should be faster.
(Demi Obenour)
- PR#6217, GPR#538: Optimize performance of record update:
* PR#6217, GPR#538: Optimize performance of record update:
no more performance cliff when { foo with t1 = ..; t2 = ...; ... }
hits 6 updated fields
(Olivier Nicole, review by Thomas Braibant and Pierre Chambart)
@ -221,6 +221,10 @@ OCaml 4.04.0:
- GPR#351: make driver/pparse.ml functions type-safe
(Gabriel Scherer, Dmitrii Kosarev, review by Jérémie Dimino)
- GPR#516: Improve Texp_record constructor representation, and
propagate updated record type information
(Pierre Chambart, review by Alain Frisch)
- GPR#679: delay registration of docstring after the mapper is applied
(Hugo Heuzard, review by Leo White)

86
bytecomp/translcore.ml
View File

@ -864,12 +864,9 @@ and transl_exp0 e =
Lprim(Pmakeblock(0, Immutable, None),
[Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
end
| Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record e.exp_loc 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_record {fields; representation; extended_expression} ->
transl_record e.exp_loc e.exp_env fields representation
extended_expression
| Texp_field(arg, _, lbl) ->
let access =
match lbl.lbl_repres with
@ -1262,8 +1259,8 @@ and transl_setinstvar loc self var expr =
in
Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
let size = Array.length all_labels in
and transl_record loc env fields repres opt_init_expr =
let size = Array.length fields in
(* Determine if there are "enough" fields (only relevant if this is a
functional-style record update *)
let no_init = match opt_init_expr with None -> true | _ -> false in
@ -1271,33 +1268,27 @@ and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
then begin
(* Allocate new record with given fields (and remaining fields
taken from init_expr if any *)
let lv = Array.make (Array.length all_labels) (staticfail, Pgenval) in
let init_id = Ident.create "init" in
begin match opt_init_expr with
None -> ()
| Some _ ->
for i = 0 to Array.length all_labels - 1 do
let access =
match all_labels.(i).lbl_repres with
Record_regular | Record_inlined _ -> Pfield i
| Record_extension -> Pfield (i + 1)
| Record_float -> Pfloatfield i in
let field_kind =
(* TODO recover the kind from the type of the original record *)
Pgenval
in
lv.(i) <- Lprim(access, [Lvar init_id], loc), field_kind
done
end;
List.iter
(fun (_, lbl, expr) ->
let kind = value_kind expr.exp_env expr.exp_type in
lv.(lbl.lbl_pos) <- transl_exp expr, kind)
lbl_expr_list;
let lv =
Array.mapi
(fun i (_, definition) ->
match definition with
| Kept typ ->
let field_kind = value_kind env typ in
let access =
match repres with
Record_regular | Record_inlined _ -> Pfield i
| Record_extension -> Pfield (i + 1)
| Record_float -> Pfloatfield i in
Lprim(access, [Lvar init_id], loc), field_kind
| Overridden (_lid, expr) ->
let field_kind = value_kind expr.exp_env expr.exp_type in
transl_exp expr, field_kind)
fields
in
let ll, shape = List.split (Array.to_list lv) in
let mut =
if List.exists (fun lbl -> lbl.lbl_mut = Mutable)
(Array.to_list all_labels)
if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
then Mutable
else Immutable in
let lam =
@ -1321,7 +1312,8 @@ and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
| Record_extension ->
let path =
match all_labels.(0).lbl_res.desc with
let (label, _) = fields.(0) in
match label.lbl_res.desc with
| Tconstr(p, _, _) -> p
| _ -> assert false
in
@ -1339,23 +1331,27 @@ and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
(* If you change anything here, you will likely have to change
[check_recursive_recordwith] in this file. *)
let copy_id = Ident.create "newrecord" in
let update_field (_, lbl, expr) cont =
let upd =
match lbl.lbl_repres with
Record_regular
| Record_inlined _ ->
Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension ->
Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) in
let update_field cont (lbl, definition) =
match definition with
| Kept _type -> cont
| Overridden (_lid, expr) ->
let upd =
match repres with
Record_regular
| Record_inlined _ ->
Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension ->
Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont)
in
begin match opt_init_expr with
None -> assert false
| Some init_expr ->
Llet(Strict, Pgenval, copy_id,
Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
List.fold_right update_field lbl_expr_list (Lvar copy_id))
Array.fold_left update_field (Lvar copy_id) fields)
end
end

89
testsuite/tests/basic-more/record_evaluation_order.ml Normal file
View File

@ -0,0 +1,89 @@
type r =
{ a : unit;
b : int;
c : char;
d : float; }
let r1 =
{
c = (print_endline "c1"; 'c');
a = print_endline "a1";
d = (print_endline "d1"; 1.);
b = (print_endline "b1"; 2);
}
let r2 =
{
b = (print_endline "b2"; 2);
d = (print_endline "d2"; 1.);
a = print_endline "a2";
c = (print_endline "c2"; 'c');
}
let r3 =
{ (print_endline "default"; r1) with
d = (print_endline "d3"; 1.);
c = (print_endline "c3"; 'c');
a = print_endline "a3";
}
let () = print_endline ""
type r2 =
{ x1 : unit;
x2 : unit;
x3 : unit;
x4 : unit;
x5 : unit;
x6 : unit;
x7 : unit;
x8 : unit;
x9 : unit; }
let a =
{
x5 = print_endline "x5";
x6 = print_endline "x6";
x1 = print_endline "x1";
x3 = print_endline "x3";
x4 = print_endline "x4";
x9 = print_endline "x9";
x7 = print_endline "x7";
x8 = print_endline "x8";
x2 = print_endline "x2";
}
let () = print_endline ""
let b =
{ a with
x7 = print_endline "x7";
x2 = print_endline "x2";
}
let () = print_endline ""
let c =
{ a with
x2 = print_endline "x2";
x7 = print_endline "x7";
}
let () = print_endline ""
let c =
{ a with
x2 = print_endline "x2";
x7 = print_endline "x7";
x5 = print_endline "x5";
}
let () = print_endline ""
let d =
{ a with
x5 = print_endline "x5";
x7 = print_endline "x7";
x2 = print_endline "x2";
}

38
testsuite/tests/basic-more/record_evaluation_order.reference Normal file
View File

@ -0,0 +1,38 @@
d1
c1
b1
a1
d2
c2
b2
a2
default
d3
c3
a3
x9
x8
x7
x6
x5
x4
x3
x2
x1
x7
x2
x7
x2
x7
x5
x2
x7
x5
x2
All tests succeeded.

14
testsuite/tests/float-unboxing/float_subst_boxed_number.ml
View File

@ -92,15 +92,15 @@ type block =
{ mutable float : float;
mutable int32 : int32 }
let make_some_block float int32 =
{ float; int32 }
let make_some_block record =
{ record with int32 = record.int32 }
let unbox_record_1 float int32 =
let unbox_record_1 record =
(* There is some let lifting problem to handle that case with one
round, this currently requires 2 rounds to be correctly
recognized as a mutable variable pattern *)
(* let block = (make_some_block [@inlined]) float int32 in *)
let block = { float; int32 } in
(* let block = (make_some_block [@inlined]) record in *)
let block = { record with int32 = record.int32 } in
for i = 1 to 1000 do
let y_float =
if i mod 2 = 0 then nan else Pervasives.float i
@ -116,8 +116,10 @@ let unbox_record_1 float int32 =
[@@inline never]
(* Prevent inlining to test that the type is effectively used *)
let float_int32_record = { float = 3.14; int32 = 12l }
let unbox_record () =
unbox_record_1 3.14 12l
unbox_record_1 float_int32_record
let r = ref 0.

25
typing/printtyped.ml
View File

@ -121,6 +121,16 @@ let list i f ppf l =
line i ppf "]\n";
;;
let array i f ppf a =
if Array.length a = 0 then
line i ppf "[]\n"
else begin
line i ppf "[\n";
Array.iter (f (i+1) ppf) a;
line i ppf "]\n"
end
;;
let option i f ppf x =
match x with
| None -> line i ppf "None\n";
@ -313,10 +323,10 @@ and expression i ppf x =
| Texp_variant (l, eo) ->
line i ppf "Texp_variant \"%s\"\n" l;
option i expression ppf eo;
| Texp_record (l, eo) ->
| Texp_record { fields; extended_expression; _ } ->
line i ppf "Texp_record\n";
list i longident_x_expression ppf l;
option i expression ppf eo;
array i record_field ppf fields;
option i expression ppf extended_expression;
| Texp_field (e, li, _) ->
line i ppf "Texp_field\n";
expression i ppf e;
@ -827,9 +837,12 @@ and string_x_expression i ppf (s, _, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;
expression (i+1) ppf e;
and longident_x_expression i ppf (li, _, e) =
line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
and record_field i ppf = function
| _, Overridden (li, e) ->
line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
| _, Kept _ ->
line i ppf "<kept>"
and label_x_expression i ppf (l, e) =
line i ppf "<arg>\n";

16
typing/tast_mapper.ml
View File

@ -255,11 +255,17 @@ let expr sub x =
Texp_construct (lid, cd, List.map (sub.expr sub) args)
| Texp_variant (l, expo) ->
Texp_variant (l, opt (sub.expr sub) expo)
| Texp_record (list, expo) ->
Texp_record (
List.map (tuple3 id id (sub.expr sub)) list,
opt (sub.expr sub) expo
)
| Texp_record { fields; representation; extended_expression } ->
let fields = Array.map (function
| label, Kept t -> label, Kept t
| label, Overridden (lid, exp) ->
label, Overridden (lid, sub.expr sub exp))
fields
in
Texp_record {
fields; representation;
extended_expression = opt (sub.expr sub) extended_expression;
}
| Texp_field (exp, lid, ld) ->
Texp_field (sub.expr sub exp, lid, ld)
| Texp_setfield (exp1, lid, ld, exp2) ->

105
typing/typecore.ml
View File

@ -1573,11 +1573,15 @@ let rec is_nonexpansive exp =
| Texp_construct( _, _, el) ->
List.for_all is_nonexpansive el
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
(fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
lbl_exp_list
&& is_nonexpansive_opt opt_init_exp
| Texp_record { fields; extended_expression } ->
Array.for_all
(fun (lbl, definition) ->
match definition with
| Overridden (_, exp) ->
lbl.lbl_mut = Immutable && is_nonexpansive exp
| Kept _ -> true)
fields
&& is_nonexpansive_opt extended_expression
| Texp_field(exp, _, _) -> is_nonexpansive exp
| Texp_array [] -> true
| Texp_ifthenelse(_cond, ifso, ifnot) ->
@ -2278,47 +2282,72 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
| [] -> ()
in
check_duplicates lbl_exp_list;
let opt_exp =
match opt_exp, lbl_exp_list with
None, _ -> None
| Some exp, (_lid, lbl, _lbl_exp) :: _ ->
let opt_exp, label_definitions =
let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
let matching_label lbl =
List.find
(fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
lbl_exp_list
in
match opt_exp with
None ->
let label_definitions =
Array.map (fun lbl ->
match matching_label lbl with
| (lid, _lbl, lbl_exp) ->
Overridden (lid, lbl_exp)
| exception Not_found ->
let present_indices =
List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
let label_names = extract_label_names env ty_expected in
let rec missing_labels n = function
[] -> []
| lbl :: rem ->
if List.mem n present_indices then missing_labels (n + 1) rem
else lbl :: missing_labels (n + 1) rem
in
let missing = missing_labels 0 label_names in
raise(Error(loc, env, Label_missing missing)))
lbl.lbl_all
in
None, label_definitions
| Some exp ->
let ty_exp = instance env exp.exp_type in
let unify_kept lbl =
(* do not connect overridden labels *)
if List.for_all
(fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
lbl_exp_list
then begin
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
unify_exp_types exp.exp_loc env ty_exp ty_res1;
end in
Array.iter unify_kept lbl.lbl_all;
Some {exp with exp_type = ty_exp}
| _ -> assert false
match matching_label lbl with
| lid, _lbl, lbl_exp ->
Overridden (lid, lbl_exp)
| exception Not_found -> begin
(* do not connect overridden labels *)
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
unify_exp_types exp.exp_loc env ty_exp ty_res1;
Kept ty_arg1
end
in
let label_definitions = Array.map unify_kept lbl.lbl_all in
Some {exp with exp_type = ty_exp}, label_definitions
in
let num_fields =
match lbl_exp_list with [] -> assert false
| (_, lbl,_)::_ -> Array.length lbl.lbl_all in
if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
let present_indices =
List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
let label_names = extract_label_names env ty_expected in
let rec missing_labels n = function
[] -> []
| lbl :: rem ->
if List.mem n present_indices then missing_labels (n + 1) rem
else lbl :: missing_labels (n + 1) rem
in
let missing = missing_labels 0 label_names in
raise(Error(loc, env, Label_missing missing))
end
else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
if opt_sexp <> None && List.length lid_sexp_list = num_fields then
Location.prerr_warning loc Warnings.Useless_record_with;
let label_descriptions, representation =
let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
lbl_all, lbl_repres
in
let fields =
Array.map2 (fun descr def -> descr, def)
label_descriptions label_definitions
in
re {
exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_desc = Texp_record {
fields; representation;
extended_expression = opt_exp
};
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;

12
typing/typedtree.ml
View File

@ -85,9 +85,11 @@ and expression_desc =
| Texp_construct of
Longident.t loc * constructor_description * expression list
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
expression option
| Texp_record of {
fields : ( Types.label_description * record_label_definition ) array;
representation : Types.record_representation;
extended_expression : expression option;
}
| Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
expression * Longident.t loc * label_description * expression
@ -123,6 +125,10 @@ and case =
c_rhs: expression;
}
and record_label_definition =
| Kept of Types.type_expr
| Overridden of Longident.t loc * expression
(* Value expressions for the class language *)
and class_expr =

23
typing/typedtree.mli
View File

@ -186,9 +186,22 @@ and expression_desc =
C (E1, ..., En) [E1;...;En]
*)
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
expression option
| Texp_record of {
fields : ( Types.label_description * record_label_definition ) array;
representation : Types.record_representation;
extended_expression : expression option;
}
(** { l1=P1; ...; ln=Pn } (extended_expression = None)
{ E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0)
Invariant: n > 0
If the type is { l1: t1; l2: t2 }, the expression
{ E0 with t2=P2 } is represented as
Texp_record
{ fields = [| l1, Kept t1; l2 Override P2 |]; representation;
extended_expression = Some E0 }
*)
| Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
expression * Longident.t loc * label_description * expression
@ -224,6 +237,10 @@ and case =
c_rhs: expression;
}
and record_label_definition =
| Kept of Types.type_expr
| Overridden of Longident.t loc * expression
(* Value expressions for the class language *)
and class_expr =

9
typing/typedtreeIter.ml
View File

@ -295,9 +295,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
None -> ()
| Some exp -> iter_expression exp
end
| Texp_record (list, expo) ->
List.iter (fun (_, _, exp) -> iter_expression exp) list;
begin match expo with
| Texp_record { fields; extended_expression; _ } ->
Array.iter (function
| _, Kept _ -> ()
| _, Overridden (_, exp) -> iter_expression exp)
fields;
begin match extended_expression with
None -> ()
| Some exp -> iter_expression exp
end

19
typing/typedtreeMap.ml
View File

@ -306,16 +306,19 @@ module MakeMap(Map : MapArgument) = struct
| Some exp -> Some (map_expression exp)
in
Texp_variant (label, expo)
| Texp_record (list, expo) ->
let list =
List.map (fun (lid, lab_desc, exp) ->
(lid, lab_desc, map_expression exp)
) list in
let expo = match expo with
None -> expo
| Texp_record { fields; representation; extended_expression } ->
let fields =
Array.map (function
| label, Kept t -> label, Kept t
| label, Overridden (lid, exp) ->
label, Overridden (lid, map_expression exp))
fields
in
let extended_expression = match extended_expression with
None -> extended_expression
| Some exp -> Some (map_expression exp)
in
Texp_record (list, expo)
Texp_record { fields; representation; extended_expression }
| Texp_field (exp, lid, label) ->
Texp_field (map_expression exp, lid, label)
| Texp_setfield (exp1, lid, label, exp2) ->

12
typing/untypeast.ml
View File

@ -410,11 +410,13 @@ let expression sub exp =
))
| Texp_variant (label, expo) ->
Pexp_variant (label, map_opt (sub.expr sub) expo)
| Texp_record (list, expo) ->
Pexp_record (List.map (fun (lid, _, exp) ->
(map_loc sub lid, sub.expr sub exp)
) list,
map_opt (sub.expr sub) expo)
| Texp_record { fields; extended_expression; _ } ->
let list = Array.fold_left (fun l -> function
| _, Kept _ -> l
| _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
[] fields
in
Pexp_record (list, map_opt (sub.expr sub) extended_expression)
| Texp_field (exp, lid, _label) ->
Pexp_field (sub.expr sub exp, map_loc sub lid)
| Texp_setfield (exp1, lid, _label, exp2) ->