Ensure that functions are evaluated after their arguments (#10728)

Author: stedolan

Changes

@@ -51,6 +51,9 @@ Working version
 - #10681: Enforce boolean conditions for the native backend
   (Vincent Laviron, review by Gabriel Scherer)
 
+- #10728: Ensure that functions are evaluated after their arguments
+  (Stephen Dolan, review by Mark Shinwell)
+
 ### Standard library:
 
 * #10622: Annotate `Uchar.t` with immediate attribute

middle_end/closure/closure.ml

@@ -219,7 +219,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
@@ -729,17 +730,19 @@ 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" *)
 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)
@@ -772,7 +775,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
 
 let warning_if_forced_inline ~loc ~attribute warning =
   if attribute = Always_inline then
@@ -782,27 +794,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 *)
 

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"

testsuite/tests/basic/eval_order_8.reference

@@ -0,0 +1,4 @@
+1234
+1234
+1234
+1234