Merge pull request #10681 from lthls/boolean-lifthenelse

Enforce boolean conditions in `Lifthenelse` in native mode

Changes

@@ -45,6 +45,9 @@ Working version
   are used for passing arguments that do not fit in registers.
   (Xavier Leroy, review by Vincent Laviron)
 
+- #10681: Enforce boolean conditions for the native backend
+  (Vincent Laviron, review by Gabriel Scherer)
+
 ### Standard library:
 
 * #10622: Annotate `Uchar.t` with immediate attribute

asmcomp/cmm_helpers.ml

@@ -1517,6 +1517,7 @@ struct
   let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
   let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
   let make_is_nonzero arg = arg
+  let arg_as_test arg = arg
   let make_if cond ifso ifnot =
     Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot,
       Debuginfo.none)

asmcomp/cmmgen.ml

@@ -609,8 +609,16 @@ let rec transl env e =
       let ifso_dbg = Debuginfo.none in
       let ifnot_dbg = Debuginfo.none in
       let dbg = Debuginfo.none in
-      transl_if env Unknown dbg cond
-        ifso_dbg (transl env ifso) ifnot_dbg (transl env ifnot)
+      let ifso = transl env ifso in
+      let ifnot = transl env ifnot in
+      let approx =
+        match ifso, ifnot with
+        | Cconst_int (1, _), Cconst_int (3, _) -> Then_false_else_true
+        | Cconst_int (3, _), Cconst_int (1, _) -> Then_true_else_false
+        | _, _ -> Unknown
+      in
+      transl_if env approx dbg cond
+        ifso_dbg ifso ifnot_dbg ifnot
   | Usequence(exp1, exp2) ->
       Csequence(remove_unit(transl env exp1), transl env exp2)
   | Uwhile(cond, body) ->

lambda/matching.ml

@@ -2357,7 +2357,15 @@ module SArg = struct
 
   let make_isin h arg = Lprim (Pnot, [ make_isout h arg ], Loc_unknown)
 
-  let make_is_nonzero arg = arg
+  let make_is_nonzero arg =
+    if !Clflags.native_code then
+      Lprim (Pintcomp Cne,
+             [arg; Lconst (Const_base (Const_int 0))],
+             Loc_unknown)
+    else
+      arg
+
+  let arg_as_test arg = arg
 
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
 
@@ -2828,9 +2836,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def
               (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
             with
             | 1, 1, [ (0, act1) ], [ (0, act2) ] ->
-                (* Typically, match on lists, will avoid isint primitive in that
-              case *)
-                Lifthenelse (arg, act2, act1)
+                if !Clflags.native_code then
+                  Lifthenelse(Lprim (Pisint, [ arg ], loc), act1, act2)
+                else
+                  (* PR#10681: we use [arg] directly as the test here;
+                     it generates better bytecode for this common case
+                     (typically options and lists), but would prevent
+                     some optimizations with the native compiler. *)
+                  Lifthenelse (arg, act2, act1)
             | n, 0, _, [] ->
                 (* The type defines constant constructors only *)
                 call_switcher loc fail_opt arg 0 (n - 1) consts

lambda/simplif.ml

@@ -712,7 +712,24 @@ and list_emit_tail_infos is_tail =
 
 let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
   let rec aux map = function
-    | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
+    (* When compiling [fun ?(x=expr) -> body], this is first translated
+       to:
+       [fun *opt* ->
+          let x =
+            match *opt* with
+            | None -> expr
+            | Some *sth* -> *sth*
+          in
+          body]
+       We want to detect the let binding to put it into the wrapper instead of
+       the inner function.
+       We need to find which optional parameter the binding corresponds to,
+       which is why we need a deep pattern matching on the expected result of
+       the pattern-matching compiler for options.
+    *)
+    | Llet(Strict, k, id,
+           (Lifthenelse(Lprim (Pisint, [Lvar optparam], _), _, _) as def),
+           rest) when
         Ident.name optparam = "*opt*" && List.mem_assoc optparam params
           && not (List.mem_assoc optparam map)
       ->

lambda/switch.ml

@@ -126,6 +126,7 @@ sig
   val make_isout : arg -> arg -> test
   val make_isin : arg -> arg -> test
   val make_is_nonzero : arg -> test
+  val arg_as_test : arg -> test
 
   val make_if : test -> act -> act -> act
   val make_switch : loc -> arg -> int array -> act array -> act
@@ -191,6 +192,9 @@ let prerr_inter i = Printf.fprintf stderr
   and get_low cases i =
     let r,_,_ = cases.(i) in
     r
+  and get_high cases i =
+    let _,r,_ = cases.(i) in
+    r
 
   type ctests = {
     mutable n : int ;
@@ -578,6 +582,9 @@ let rec pkey chan  = function
   let make_if_nonzero arg ifso ifnot =
     Arg.make_if (Arg.make_is_nonzero arg) ifso ifnot
 
+  let make_if_bool arg ifso ifnot =
+    Arg.make_if (Arg.arg_as_test arg) ifso ifnot
+
   let do_make_if_out h arg ifso ifno =
     Arg.make_if (Arg.make_isout h arg) ifso ifno
 
@@ -667,9 +674,14 @@ let rec pkey chan  = function
           and right = {s with cases=right} in
 
           if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
-            make_if_nonzero
-              ctx.arg
-              (c_test ctx right) (c_test ctx left)
+            if lcases = 2 && get_high cases 1+ctx.off = 1 then
+              make_if_bool
+                ctx.arg
+                (c_test ctx right) (c_test ctx left)
+            else
+              make_if_nonzero
+                ctx.arg
+                (c_test ctx right) (c_test ctx left)
           else if less_tests cright cleft then
             make_if_lt
               ctx.arg (lim+ctx.off)

lambda/switch.mli

@@ -84,14 +84,32 @@ module type S =
 
     (* Various constructors, for making a binder,
         adding one integer, etc. *)
+
+    (* [bind arg cont] should bind the expression arg to a variable,
+       then call [cont] on that variable, and return the term made of
+       the binding and the result of the call. *)
     val bind : arg -> (arg -> act) -> act
+    (* [make_const n] generates a term for the integer constant [n] *)
     val make_const : int -> arg
+    (* [make_offset arg n] generates a term for adding the constant
+       integer [n] to the term [arg] *)
     val make_offset : arg -> int -> arg
+    (* [make_prim p args] generates a test using the primitive operation [p]
+       applied to arguments [args] *)
     val make_prim : primitive -> arg list -> test
+    (* [make_isout h arg] generates a test that holds when [arg] is out of
+       the interval [0, h] *)
     val make_isout : arg -> arg -> test
+    (* [make_isin h arg] generates a test that holds when [arg] is in
+       the interval [0, h] *)
     val make_isin : arg -> arg -> test
+    (* [make_is_nonzero arg] generates a test that holds when [arg] is any
+       value except 0 *)
     val make_is_nonzero : arg -> test
-
+    (* [arg_as_test arg] casts [arg], known to be either 0 or 1,
+       to a boolean test *)
+    val arg_as_test : arg -> test
+    (* [make_if cond ifso ifnot] generates a conditional branch *)
     val make_if : test -> act -> act -> act
    (* construct an actual switch :
       make_switch arg cases acts

middle_end/closure/closure.ml

@@ -483,13 +483,19 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
       make_const (List.nth l n)
   | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
       (List.nth ul n, field_approx n approx)
   (* Strings *)
   | (Pstringlength | Pbyteslength),
      _,
      [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
       make_const_int (String.length s)
   (* Kind test *)
+  | Pisint, [ Uprim(P.Pmakeblock _, _, _) ], _ ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
+      make_const_bool false
   | Pisint, _, [a1] ->
       begin match a1 with
       | Value_const(Uconst_int _) -> make_const_bool true
@@ -667,8 +673,6 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam =
             substitute loc st sb rn u2
           else
             substitute loc st sb rn u3
-      | Uprim(P.Pmakeblock _, _, _) ->
-          substitute loc st sb rn u2
       | su1 ->
           Uifthenelse(su1, substitute loc st sb rn u2,
                            substitute loc st sb rn u3)
@@ -748,6 +752,11 @@ let bind_params { backend; mutable_vars; _ } loc fpc params args body =
           let u1, u2 =
             match VP.name p1, a1 with
             | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) ->
+                (* This parameter corresponds to an optional parameter,
+                   and although it is used twice pushing the expression down
+                   actually allows us to remove the allocation as it will
+                   appear once under a Pisint primitive and once under a Pfield
+                   primitive (see [simplif_prim_pure]) *)
                 a, Uprim(P.Pmakeblock(0, Immutable, kind),
                          [Uvar (VP.var p1')], dbg)
             | _ ->
@@ -765,9 +774,6 @@ let bind_params { backend; mutable_vars; _ } loc fpc params args body =
      evaluation order (PR#2910). *)
   aux V.Map.empty (List.rev params) (List.rev args) body
 
-(* Check if a lambda term is ``pure'',
-   that is without side-effects *and* not containing function definitions *)
-
 let warning_if_forced_inline ~loc ~attribute warning =
   if attribute = Always_inline then
     Location.prerr_warning (Debuginfo.Scoped_location.to_location loc)