Enforce boolean Lifthenelse in native mode

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)

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,9 @@ 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
+ | 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

@@ -91,6 +91,7 @@ module type S =
  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
  (* construct an actual switch :

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)