Refactor unboxing decision code (#394)

Author: Gbury

.depend

@@ -26,6 +26,7 @@
   tests/extension-constructor
   tests/flambda
   tests/flambda-specialization
+  tests/flambda-unboxing
 # tests/float-unboxing              FAIL (FIXME)  'float_subst_boxed_number.ml' see flambdatest/mlexamples/float_unboxing.ml for a simplified error example
   tests/fma
   tests/formats-transition

.github/workflows/test-list

@@ -330,6 +330,12 @@ MIDDLE_END_FLAMBDA_SIMPLIFY=\
   middle_end/flambda/simplify/simplify_simple.cmo \
   middle_end/flambda/simplify/simplify_import.cmo \
   middle_end/flambda/simplify/basic/simplify_named_result.cmo \
+  middle_end/flambda/unboxing/unboxing_types.cmo \
+  middle_end/flambda/unboxing/unboxers.cmo \
+  middle_end/flambda/unboxing/build_unboxing_denv.cmo \
+  middle_end/flambda/unboxing/is_unboxing_beneficial.cmo \
+  middle_end/flambda/unboxing/optimistic_unboxing_decision.cmo \
+  middle_end/flambda/unboxing/unboxing_epa.cmo \
   middle_end/flambda/unboxing/unbox_continuation_params.cmo \
   middle_end/flambda/lifting/sort_lifted_constants.cmo \
   middle_end/flambda/lifting/reification.cmo \

compilerlibs/Makefile.compilerlibs

@@ -1015,6 +1015,11 @@ let mk_flambda_expert_max_block_size_for_projections f =
     this value"
 ;;
 
+let mk_flambda_expert_max_unboxing_depth f =
+  "-flambda-expert-max-unboxing-depth", Arg.Int f,
+  " Do not unbox types deeper that this value"
+;;
+
 let mk_flambda_debug_permute_every_name f =
   "-flambda-debug-permute-every-name", Arg.Unit f,
     " Permute every name to check permutation works"
@@ -1277,6 +1282,7 @@ module type Optcommon_options = sig
   val _no_flambda_expert_phantom_lets : unit -> unit
   val _flambda_expert_max_inlining_depth : int -> unit
   val _flambda_expert_max_block_size_for_projections : int -> unit
+  val _flambda_expert_max_unboxing_depth : int -> unit
   val _flambda_debug_permute_every_name : unit -> unit
   val _no_flambda_debug_permute_every_name : unit -> unit
   val _flambda_debug_concrete_types_only_on_canonicals : unit -> unit
@@ -1647,6 +1653,8 @@ struct
       F._flambda_expert_max_inlining_depth;
     mk_flambda_expert_max_block_size_for_projections
       F._flambda_expert_max_block_size_for_projections;
+    mk_flambda_expert_max_unboxing_depth
+      F._flambda_expert_max_unboxing_depth;
     mk_flambda_debug_permute_every_name
       F._flambda_debug_permute_every_name;
     mk_no_flambda_debug_permute_every_name
@@ -1814,6 +1822,8 @@ module Make_opttop_options (F : Opttop_options) = struct
       F._flambda_expert_max_inlining_depth;
     mk_flambda_expert_max_block_size_for_projections
       F._flambda_expert_max_block_size_for_projections;
+    mk_flambda_expert_max_unboxing_depth
+      F._flambda_expert_max_unboxing_depth;
     mk_flambda_debug_permute_every_name
       F._flambda_debug_permute_every_name;
     mk_no_flambda_debug_permute_every_name
@@ -2141,6 +2151,8 @@ module Default = struct
       Flambda.Expert.max_inlining_depth := depth
     let _flambda_expert_max_block_size_for_projections size =
       Flambda.Expert.max_block_size_for_projections := Some size
+    let _flambda_expert_max_unboxing_depth depth =
+      Flambda.Expert.max_unboxing_depth := depth
     let _flambda_debug_permute_every_name =
       set Flambda.Debug.permute_every_name
     let _no_flambda_debug_permute_every_name =

driver/main_args.ml

@@ -247,6 +247,7 @@ module type Optcommon_options = sig
   val _no_flambda_expert_phantom_lets : unit -> unit
   val _flambda_expert_max_inlining_depth : int -> unit
   val _flambda_expert_max_block_size_for_projections : int -> unit
+  val _flambda_expert_max_unboxing_depth : int -> unit
   val _flambda_debug_permute_every_name : unit -> unit
   val _no_flambda_debug_permute_every_name : unit -> unit
   val _flambda_debug_concrete_types_only_on_canonicals : unit -> unit

driver/main_args.mli

@@ -0,0 +1,13 @@
+
+type t = { foo : int; bar : float; }
+
+let foo b x y =
+  let f =
+    if b
+    then { foo = x; bar = y +. 1.; }
+    else { bar = y +. 1.; foo = x; }
+  in
+  match f with
+  | { foo; bar; } -> foo + (int_of_float bar)
+
+

flambdatest/mlexamples/block_unboxed.ml

@@ -0,0 +1,17 @@
+
+external (+.) : float -> float -> float = "%addfloat"
+
+let[@inline never] g x = x +. 42.
+
+let f b x =
+  let y = g x
+(*
+    if b then
+      x +. 1.
+    else
+   g x
+*)
+  in
+  y +. 0.
+
+

flambdatest/mlexamples/float_fn.ml

@@ -0,0 +1,17 @@
+
+external (+.) : float -> float -> float = "%addfloat"
+
+let[@inline never] g x = (x +. 42., x +. 1.)
+
+let f b x =
+  let y, z = g x
+(*
+    if b then
+      x +. 1.
+    else
+   g x
+*)
+  in
+  y +. z
+
+

flambdatest/mlexamples/float_fn_tuple.ml

@@ -0,0 +1,14 @@
+
+external (+.) : float -> float -> float = "%addfloat"
+
+let f b x =
+  let y =
+    if b then
+      x +. 1., 0.
+    else
+      x +. 42., x +. 1.
+  in
+  match y with
+  | a, b -> a +. b
+
+

flambdatest/mlexamples/float_tuple.ml

@@ -0,0 +1,11 @@
+
+let f b x =
+  let y =
+    if b then
+      x +. 1.
+    else
+      x +. 42.
+  in
+  y +. 0.
+
+