From f1e2e975494d96bd82fe3cf88f29f4fa25408703 Mon Sep 17 00:00:00 2001 From: Stephen Dolan Date: Wed, 27 Oct 2021 15:31:05 +0100 Subject: [PATCH] Port ocaml/ocaml#10728 Ensure that functions are evaluated after their arguments (cherry picked from commit b71489f03eb883b3732b69ffb35f14beebb0419e) --- middle_end/closure/closure.ml | 74 +++++++++++++------- testsuite/tests/basic/eval_order_8.ml | 22 ++++++ testsuite/tests/basic/eval_order_8.reference | 4 ++ 3 files changed, 75 insertions(+), 25 deletions(-) create mode 100644 testsuite/tests/basic/eval_order_8.ml create mode 100644 testsuite/tests/basic/eval_order_8.reference diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 5be6f18807c..86ac36888a8 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -223,7 +223,8 @@ let is_pure_prim p = | Arbitrary_effects, _ -> false (* Check if a clambda term is ``pure'', - that is without side-effects *and* not containing function definitions *) + that is without side-effects *and* not containing function definitions + (Pure terms may still read mutable state) *) let rec is_pure = function Uvar _ -> true @@ -731,9 +732,10 @@ type env = { *) (* Approximates "no effects and no coeffects" *) -let is_substituable ~mutable_vars = function +let rec is_substituable ~mutable_vars = function | Uvar v -> not (V.Set.mem v mutable_vars) | Uconst _ -> true + | Uoffset(arg, _) -> is_substituable ~mutable_vars arg | _ -> false (* Approximates "only generative effects" *) @@ -741,7 +743,8 @@ let is_erasable = function | Uclosure _ -> true | u -> is_pure u -let bind_params { backend; mutable_vars; _ } loc fpc params args body = +let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body = + let fpc = fdesc.fun_float_const_prop in let rec aux subst pl al body = match (pl, al) with ([], []) -> substitute (Debuginfo.from_location loc) (backend, fpc) @@ -770,7 +773,16 @@ let bind_params { backend; mutable_vars; _ } loc fpc params args body = in (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - aux V.Map.empty (List.rev params) (List.rev args) body + let params, args = List.rev params, List.rev args in + let params, args, body = + (* Ensure funct is evaluated after args *) + match params with + | my_closure :: params when not fdesc.fun_closed -> + (params @ [my_closure]), (args @ [funct]), body + | _ -> + params, args, (if is_pure funct then body else Usequence (funct, body)) + in + aux V.Map.empty params args body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -783,27 +795,39 @@ let warning_if_forced_inline ~loc ~attribute warning = (* Generate a direct application *) let direct_apply env fundesc ufunct uargs ~loc ~attribute = - let app_args = - if fundesc.fun_closed then uargs else uargs @ [ufunct] in - let app = - match fundesc.fun_inline, attribute with - | _, Never_inline | None, _ -> - let dbg = Debuginfo.from_location loc in - warning_if_forced_inline ~loc ~attribute - "Function information unavailable"; - Udirect_apply(fundesc.fun_label, app_args, dbg) - | Some(params, body), _ -> - bind_params env loc fundesc.fun_float_const_prop params app_args - body - in - (* If ufunct can contain side-effects or function definitions, - we must make sure that it is evaluated exactly once. - If the function is not closed, we evaluate ufunct as part of the - arguments. - If the function is closed, we force the evaluation of ufunct first. *) - if not fundesc.fun_closed || is_pure ufunct - then app - else Usequence(ufunct, app) + match fundesc.fun_inline, attribute with + | _, Never_inline + | None, _ -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute + "Function information unavailable"; + if fundesc.fun_closed && is_pure ufunct then + Udirect_apply(fundesc.fun_label, uargs, dbg) + else if not fundesc.fun_closed && + is_substituable ~mutable_vars:env.mutable_vars ufunct then + Udirect_apply(fundesc.fun_label, uargs @ [ufunct], dbg) + else begin + let args = List.map (fun arg -> + if is_substituable ~mutable_vars:env.mutable_vars arg then + None, arg + else + let id = V.create_local "arg" in + Some (VP.create id, arg), Uvar id) uargs in + let app_args = List.map snd args in + List.fold_left (fun app (binding,_) -> + match binding with + | None -> app + | Some (v, e) -> Ulet(Immutable, Pgenval, v, e, app)) + (if fundesc.fun_closed then + Usequence (ufunct, Udirect_apply (fundesc.fun_label, app_args, dbg)) + else + let clos = V.create_local "clos" in + Ulet(Immutable, Pgenval, VP.create clos, ufunct, + Udirect_apply(fundesc.fun_label, app_args @ [Uvar clos], dbg))) + args + end + | Some(params, body), _ -> + bind_params env loc fundesc params uargs ufunct body (* Add [Value_integer] info to the approximation of an application *) diff --git a/testsuite/tests/basic/eval_order_8.ml b/testsuite/tests/basic/eval_order_8.ml new file mode 100644 index 00000000000..7a69ff6dd5b --- /dev/null +++ b/testsuite/tests/basic/eval_order_8.ml @@ -0,0 +1,22 @@ +(* TEST *) + +(* closed, inlined *) +let[@inline always] f () () = print_endline "4" +let () = (let () = print_string "3" in f) (print_string "2") (print_string "1") + +(* closed, not inlined *) +let[@inline never] f () () = print_endline "4" +let () = (let () = print_string "3" in f) (print_string "2") (print_string "1") + +(* closure, inlined *) +let[@inline never] g x = + (let () = print_string "3" in fun () () -> print_endline x) + (print_string "2") (print_string "1") +let () = g "4" + +(* closure, not inlined *) +let[@inline never] g x = + (let () = print_string "3" in + let[@inline never] f () () = print_endline x in f) + (print_string "2") (print_string "1") +let () = g "4" diff --git a/testsuite/tests/basic/eval_order_8.reference b/testsuite/tests/basic/eval_order_8.reference new file mode 100644 index 00000000000..8eca48c4435 --- /dev/null +++ b/testsuite/tests/basic/eval_order_8.reference @@ -0,0 +1,4 @@ +1234 +1234 +1234 +1234