Ensure that functions are evaluated after their arguments (flambda-backend #353)

Author: stedolan

middle_end/closure/closure.ml

@@ -224,7 +224,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
@@ -730,17 +731,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)
@@ -768,7 +771,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 *)
@@ -787,36 +799,50 @@ let fail_if_probe ~probe msg =
 (* Generate a direct application *)
 
 let direct_apply env fundesc ufunct uargs ~probe ~loc ~attribute =
-  let app_args =
-    if fundesc.fun_closed then uargs else uargs @ [ufunct] in
-  let app =
-    match fundesc.fun_inline, attribute with
-    | _, Never_inlined | None, _ ->
-      let dbg = Debuginfo.from_location loc in
-        warning_if_forced_inlined ~loc ~attribute
-          "Function information unavailable";
-        if not fundesc.fun_closed then begin
-          fail_if_probe ~probe "Not closed"
-        end;
-        begin match probe, attribute with
-        | None, _ -> ()
-        | Some _, Never_inlined -> ()
-        | Some _, _ ->
-          fail_if_probe ~probe "Erroneously marked to be inlined"
-        end;
-        Udirect_apply(fundesc.fun_label, app_args, probe, 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_inlined
+  | None, _ ->
+     let dbg = Debuginfo.from_location loc in
+     warning_if_forced_inlined ~loc ~attribute
+       "Function information unavailable";
+     if not fundesc.fun_closed then begin
+       fail_if_probe ~probe "Not closed"
+     end;
+     begin match probe, attribute with
+     | None, _ -> ()
+     | Some _, Never_inlined -> ()
+     | Some _, _ ->
+       fail_if_probe ~probe "Erroneously marked to be inlined"
+     end;
+     if fundesc.fun_closed && is_pure ufunct then
+       Udirect_apply(fundesc.fun_label, uargs, probe, dbg)
+     else if not fundesc.fun_closed &&
+               is_substituable ~mutable_vars:env.mutable_vars ufunct then
+       Udirect_apply(fundesc.fun_label, uargs @ [ufunct], probe, 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, probe, 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],
+                               probe, 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 *)