From 99edb7e5e8a0a1041beb2af3692d1c5b6d8397d0 Mon Sep 17 00:00:00 2001 From: Andrei Paskevich Date: Wed, 12 Feb 2014 11:26:14 +0100 Subject: [PATCH] Typing: do not inline complex expressions in record updates --- src/parser/typing.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/src/parser/typing.ml b/src/parser/typing.ml index 091375035..1adb166df 100644 --- a/src/parser/typing.ml +++ b/src/parser/typing.ml @@ -177,6 +177,20 @@ let quant_var uc (x,ty) = | Some ty -> dty_of_ty (ty_of_pty uc ty) | None -> dty_fresh () +let is_reusable dt = match dt.dt_node with + | DTvar _ | DTgvar _ | DTconst _ | DTtrue | DTfalse -> true + | DTapp (_,[]) -> true + | _ -> false + +let mk_var n dt = + let dty = match dt.dt_dty with + | None -> dty_of_ty ty_bool + | Some dty -> dty in + Dterm.dterm ?loc:dt.dt_loc (DTvar (n, dty)) + +let mk_let ~loc n dt node = + DTlet (dt, id_user n loc, Dterm.dterm ~loc node) + let chainable_op uc op = (* non-bool -> non-bool -> bool *) op.id = "infix =" || op.id = "infix <>" || @@ -312,11 +326,14 @@ let rec dterm uc gvars denv {pp_desc = desc; pp_loc = loc} = DTapp (cs, fl) | PPupdate (e1, fl) -> let e1 = dterm uc gvars denv e1 in + let re = is_reusable e1 in + let v = if re then e1 else mk_var "_q " e1 in let get_val _ pj = function | Some e -> dterm uc gvars denv e - | None -> Dterm.dterm ~loc (DTapp (pj,[e1])) in + | None -> Dterm.dterm ~loc (DTapp (pj,[v])) in let cs, fl = parse_record ~loc uc get_val fl in - DTapp (cs, fl) + let d = DTapp (cs, fl) in + if re then d else mk_let ~loc "_q " e1 d | PPnamed (Lpos uloc, e1) -> DTuloc (dterm uc gvars denv e1, uloc) | PPnamed (Lstr lab, e1) -> -- GitLab