Shorten symbol names in classic mode (ocaml-flambda#1919)

driver/flambda_backend_args.ml

@@ -315,6 +315,18 @@ let mk_flambda2_expert_max_function_simplify_run f =
     Flambda2.Expert.Default.max_function_simplify_run
 ;;
 
+let mk_flambda2_expert_shorten_symbol_names f =
+  "-flambda2-expert-shorten-symbol-names", Arg.Unit f,
+  " Shorten symbol names (Flambda 2 only, set by\n\
+    \     default in classic mode)"
+;;
+
+let mk_no_flambda2_expert_shorten_symbol_names f =
+  "-no-flambda2-expert-shorten-symbol-names", Arg.Unit f,
+  " Do not shorten symbol names (Flambda 2 only, set by\n\
+    \     default except for classic mode)"
+;;
+
 let mk_flambda2_debug_concrete_types_only_on_canonicals f =
   "-flambda2-debug-concrete-types-only-on-canonicals", Arg.Unit f,
   Printf.sprintf " Check that concrete\n\
@@ -614,6 +626,8 @@ module type Flambda_backend_options = sig
   val flambda2_expert_can_inline_recursive_functions : unit -> unit
   val no_flambda2_expert_can_inline_recursive_functions : unit -> unit
   val flambda2_expert_max_function_simplify_run : int -> unit
+  val flambda2_expert_shorten_symbol_names : unit -> unit
+  val no_flambda2_expert_shorten_symbol_names : unit -> unit
   val flambda2_debug_concrete_types_only_on_canonicals : unit -> unit
   val no_flambda2_debug_concrete_types_only_on_canonicals : unit -> unit
   val flambda2_debug_keep_invalid_handlers : unit -> unit
@@ -734,6 +748,10 @@ struct
       F.no_flambda2_expert_can_inline_recursive_functions;
     mk_flambda2_expert_max_function_simplify_run
       F.flambda2_expert_max_function_simplify_run;
+    mk_flambda2_expert_shorten_symbol_names
+      F.flambda2_expert_shorten_symbol_names;
+    mk_no_flambda2_expert_shorten_symbol_names
+      F.no_flambda2_expert_shorten_symbol_names;
     mk_flambda2_debug_concrete_types_only_on_canonicals
       F.flambda2_debug_concrete_types_only_on_canonicals;
     mk_no_flambda2_debug_concrete_types_only_on_canonicals
@@ -885,6 +903,10 @@ module Flambda_backend_options_impl = struct
     Flambda2.Expert.can_inline_recursive_functions := Flambda_backend_flags.Set false
   let flambda2_expert_max_function_simplify_run runs =
     Flambda2.Expert.max_function_simplify_run := Flambda_backend_flags.Set runs
+  let flambda2_expert_shorten_symbol_names () =
+    Flambda2.Expert.shorten_symbol_names := Flambda_backend_flags.Set true
+  let no_flambda2_expert_shorten_symbol_names () =
+    Flambda2.Expert.shorten_symbol_names := Flambda_backend_flags.Set false
   let flambda2_debug_concrete_types_only_on_canonicals =
     set' Flambda2.Debug.concrete_types_only_on_canonicals
   let no_flambda2_debug_concrete_types_only_on_canonicals =

driver/flambda_backend_args.mli

@@ -84,6 +84,8 @@ module type Flambda_backend_options = sig
   val flambda2_expert_can_inline_recursive_functions : unit -> unit
   val no_flambda2_expert_can_inline_recursive_functions : unit -> unit
   val flambda2_expert_max_function_simplify_run : int -> unit
+  val flambda2_expert_shorten_symbol_names : unit -> unit
+  val no_flambda2_expert_shorten_symbol_names : unit -> unit
   val flambda2_debug_concrete_types_only_on_canonicals : unit -> unit
   val no_flambda2_debug_concrete_types_only_on_canonicals : unit -> unit
   val flambda2_debug_keep_invalid_handlers : unit -> unit

driver/flambda_backend_flags.ml

@@ -159,6 +159,7 @@ module Flambda2 = struct
       let max_unboxing_depth = 3
       let can_inline_recursive_functions = false
       let max_function_simplify_run = 2
+      let shorten_symbol_names = false
     end
 
     type flags = {
@@ -169,6 +170,7 @@ module Flambda2 = struct
       max_unboxing_depth : int;
       can_inline_recursive_functions : bool;
       max_function_simplify_run : int;
+      shorten_symbol_names : bool
     }
 
     let default = {
@@ -179,11 +181,13 @@ module Flambda2 = struct
       max_unboxing_depth = Default.max_unboxing_depth;
       can_inline_recursive_functions = Default.can_inline_recursive_functions;
       max_function_simplify_run = Default.max_function_simplify_run;
+      shorten_symbol_names = Default.shorten_symbol_names;
     }
 
     let oclassic = {
       default with
       fallback_inlining_heuristic = true;
+      shorten_symbol_names = true;
     }
 
     let o2 = {
@@ -203,6 +207,7 @@ module Flambda2 = struct
     let max_unboxing_depth = ref Default
     let can_inline_recursive_functions = ref Default
     let max_function_simplify_run = ref Default
+    let shorten_symbol_names = ref Default
   end
 
   module Debug = struct

driver/flambda_backend_flags.mli

@@ -128,6 +128,7 @@ module Flambda2 : sig
       val max_unboxing_depth : int
       val can_inline_recursive_functions : bool
       val max_function_simplify_run : int
+      val shorten_symbol_names : bool
     end
 
     type flags = {
@@ -138,6 +139,7 @@ module Flambda2 : sig
       max_unboxing_depth : int;
       can_inline_recursive_functions : bool;
       max_function_simplify_run : int;
+      shorten_symbol_names : bool;
     }
 
     val default_for_opt_level : opt_level or_default -> flags
@@ -149,6 +151,7 @@ module Flambda2 : sig
     val max_unboxing_depth : int or_default ref
     val can_inline_recursive_functions : bool or_default ref
     val max_function_simplify_run : int or_default ref
+    val shorten_symbol_names : bool or_default ref
   end
 
   module Debug : sig

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -47,29 +47,37 @@ type close_functions_result =
   | Lifted of (Symbol.t * Env.value_approximation) Function_slot.Lmap.t
   | Dynamic of Set_of_closures.t * Env.value_approximation Function_slot.Map.t
 
-let declare_symbol_for_function_slot env ident function_slot : Env.t * Symbol.t
-    =
+let manufacture_symbol acc proposed_name =
+  let acc, linkage_name =
+    if Flambda_features.Expert.shorten_symbol_names ()
+    then Acc.manufacture_symbol_short_name acc
+    else acc, Linkage_name.of_string proposed_name
+  in
   let symbol =
-    Symbol.create
-      (Compilation_unit.get_current_exn ())
-      (Linkage_name.of_string (Function_slot.to_string function_slot))
+    Symbol.create (Compilation_unit.get_current_exn ()) linkage_name
+  in
+  acc, symbol
+
+let declare_symbol_for_function_slot env acc ident function_slot :
+    Env.t * Acc.t * Symbol.t =
+  let acc, symbol =
+    manufacture_symbol acc (Function_slot.to_string function_slot)
   in
   let env =
     Env.add_simple_to_substitute env ident (Simple.symbol symbol)
       K.With_subkind.any_value
   in
-  env, symbol
+  env, acc, symbol
 
 let register_const0 acc constant name =
   match Static_const.Map.find constant (Acc.shareable_constants acc) with
   | exception Not_found ->
     (* Create a variable to ensure uniqueness of the symbol. *)
     let var = Variable.create name in
-    let symbol =
-      Symbol.create
-        (Compilation_unit.get_current_exn ())
+    let acc, symbol =
+      manufacture_symbol acc
         (* CR mshinwell: this Variable.rename looks to be redundant *)
-        (Linkage_name.of_string (Variable.unique_name (Variable.rename var)))
+        (Variable.unique_name (Variable.rename var))
     in
     let acc = Acc.add_declared_symbol ~symbol ~constant acc in
     let acc =
@@ -953,10 +961,8 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr
             (* This is a inconstant statically-allocated value, so cannot go
                through [register_const0]. The definition must be placed right
                away. *)
-            let symbol =
-              Symbol.create
-                (Compilation_unit.get_current_exn ())
-                (Linkage_name.of_string (Variable.unique_name var))
+            let acc, symbol =
+              manufacture_symbol acc (Variable.unique_name var)
             in
             let static_const = Static_const.block tag Immutable static_fields in
             let static_consts =
@@ -995,11 +1001,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr
                && Env.at_toplevel env
                && Flambda_features.classic_mode () ->
           (* Special case to lift toplevel exception declarations *)
-          let symbol =
-            Symbol.create
-              (Compilation_unit.get_current_exn ())
-              (Linkage_name.of_string (Variable.unique_name var))
-          in
+          let acc, symbol = manufacture_symbol acc (Variable.unique_name var) in
           let transform_arg arg =
             Simple.pattern_match' arg
               ~var:(fun var ~coercion:_ ->
@@ -1792,8 +1794,8 @@ let close_functions acc external_env ~current_region function_declarations =
     then
       Ident.Map.fold
         (fun ident function_slot (acc, env, symbol_map) ->
-          let env, symbol =
-            declare_symbol_for_function_slot env ident function_slot
+          let env, acc, symbol =
+            declare_symbol_for_function_slot env acc ident function_slot
           in
           let approx =
             match Function_slot.Map.find function_slot approx_map with

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -347,9 +347,16 @@ module Acc = struct
       seen_a_function : bool;
       slot_offsets : Slot_offsets.t;
       regions_closed_early : Ident.Set.t;
-      closure_infos : closure_info list
+      closure_infos : closure_info list;
+      symbol_short_name_counter : int
     }
 
+  let manufacture_symbol_short_name t =
+    let counter = t.symbol_short_name_counter in
+    let t = { t with symbol_short_name_counter = counter + 1 } in
+    let name = Linkage_name.of_string ("s" ^ string_of_int counter) in
+    t, name
+
   let cost_metrics t = t.cost_metrics
 
   let increment_metrics metrics t =
@@ -436,7 +443,8 @@ module Acc = struct
       seen_a_function = false;
       slot_offsets;
       regions_closed_early = Ident.Set.empty;
-      closure_infos = []
+      closure_infos = [];
+      symbol_short_name_counter = 0
     }
 
   let declared_symbols t = t.declared_symbols

middle_end/flambda2/from_lambda/closure_conversion_aux.mli

@@ -213,6 +213,8 @@ module Acc : sig
 
   val create : slot_offsets:Slot_offsets.t -> cmx_loader:Flambda_cmx.loader -> t
 
+  val manufacture_symbol_short_name : t -> t * Linkage_name.t
+
   val declared_symbols : t -> (Symbol.t * Static_const.t) list
 
   val lifted_sets_of_closures :

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -53,9 +53,11 @@ let print_compact_location ppf (loc : Location.t) =
 let name_for_function (func : Lambda.lfunction) =
   (* Name anonymous functions by their source location, if known. *)
   match func.loc with
-  | Loc_unknown -> "anon-fn"
+  | Loc_unknown -> "fn"
   | Loc_known { loc; _ } ->
-    Format.asprintf "anon-fn[%a]" print_compact_location loc
+    if Flambda_features.Expert.shorten_symbol_names ()
+    then "fn"
+    else Format.asprintf "fn[%a]" print_compact_location loc
 
 let extra_args_for_exn_continuation env exn_handler =
   List.map

middle_end/flambda2/identifiers/int_ids.ml

@@ -714,7 +714,11 @@ module Code_id = struct
       !previous_name_stamp
     in
     let linkage_name =
-      let name = Printf.sprintf "%s_%d_code" name name_stamp in
+      let name =
+        if Flambda_features.Expert.shorten_symbol_names ()
+        then Printf.sprintf "%s_%d" name name_stamp
+        else Printf.sprintf "%s_%d_code" name name_stamp
+      in
       Symbol0.for_name compilation_unit name |> Symbol0.linkage_name
     in
     let data : Code_id_data.t = { compilation_unit; name; linkage_name } in

middle_end/flambda2/ui/flambda_features.ml

@@ -241,6 +241,10 @@ module Expert = struct
   let max_function_simplify_run () =
     !Flambda_backend_flags.Flambda2.Expert.max_function_simplify_run
     |> with_default ~f:(fun d -> d.max_function_simplify_run)
+
+  let shorten_symbol_names () =
+    !Flambda_backend_flags.Flambda2.Expert.shorten_symbol_names
+    |> with_default ~f:(fun d -> d.shorten_symbol_names)
 end
 
 let stack_allocation_enabled () = Config.stack_allocation

middle_end/flambda2/ui/flambda_features.mli

@@ -134,6 +134,8 @@ module Expert : sig
   val can_inline_recursive_functions : unit -> bool
 
   val max_function_simplify_run : unit -> int
+
+  val shorten_symbol_names : unit -> bool
 end
 
 val stack_allocation_enabled : unit -> bool