Mark symbols as having visibility STV_PROTECTED

backend/amd64/emit.mlp

@@ -715,10 +715,34 @@ let emit_vec128_constant {high; low} lbl =
   D.qword (Const low);
   D.qword (Const high)
 
+let global_maybe_protected sym =
+  D.global sym;
+  if !Flambda_backend_flags.symbol_visibility_protected then
+    match system with
+    | S_macosx
+    | S_win32
+    | S_win64
+    | S_mingw64
+    | S_cygwin
+    | S_mingw
+    | S_unknown -> ()
+    | S_gnu
+    | S_solaris
+    | S_linux_elf
+    | S_bsd_elf
+    | S_beos
+    | S_linux
+    | S_freebsd
+    | S_netbsd
+    | S_openbsd ->
+      (* Global symbols can be marked as being protected. Unlike in C we don't want
+        them to be preempted as we're doing a lot of cross module inlining. *)
+      D.protected sym
+
 let emit_global_label_for_symbol lbl =
   add_def_symbol lbl;
   let lbl = emit_symbol lbl in
-  D.global lbl;
+  global_maybe_protected lbl;
   _label lbl
 
 let emit_global_label s =
@@ -1807,7 +1831,7 @@ let fundecl fundecl =
   then (* PR#4690 *)
     D.private_extern (emit_symbol fundecl.fun_name)
   else
-    D.global (emit_symbol fundecl.fun_name);
+    global_maybe_protected (emit_symbol fundecl.fun_name);
   (* Even if the function name is Local, still emit an
      actual linker symbol for it. This provides symbols
      for perf, gdb, and similar tools *)
@@ -1881,7 +1905,7 @@ let emit_item = function
     | Local ->
       _label (label_name (emit_symbol s.sym_name))
     | Global ->
-      D.global (emit_symbol s.sym_name);
+      global_maybe_protected (emit_symbol s.sym_name);
       add_def_symbol s.sym_name;
       _label (emit_symbol s.sym_name);
       _label (label_name (emit_symbol s.sym_name))

backend/asm_targets/asm_directives.ml

@@ -238,6 +238,8 @@ module Make (A : Asm_directives_intf.Arg) : Asm_directives_intf.S = struct
 
   let global sym = D.global (Asm_symbol.encode sym)
 
+  let protected sym = D.protected (Asm_symbol.encode sym)
+
   let const_machine_width const = D.qword const
 
   let symbol =

backend/asm_targets/asm_directives_intf.ml

@@ -66,6 +66,8 @@ module type Arg = sig
 
     val global : string -> unit
 
+    val protected : string -> unit
+
     val type_ : string -> string -> unit
 
     val byte : constant -> unit
@@ -172,6 +174,9 @@ module type S = sig
   (** Mark a symbol as global. *)
   val global : Asm_symbol.t -> unit
 
+  (** Mark a symbol as having visibility protected. *)
+  val protected : Asm_symbol.t -> unit
+
   (** Emit a machine-width reference to the given symbol. *)
   val symbol : ?comment:string -> Asm_symbol.t -> unit
 

backend/internal_assembler/symbol_entry.ml

@@ -92,7 +92,7 @@ let create_symbol (symbol : X86_binary_emitter.symbol) symbol_table sections
   let symbol_entry =
     { st_name = String_table.current_length string_table;
       st_info = (global lsl 4) lor bind;
-      st_other = 0;
+      st_other = if symbol.sy_protected then 3 else 0;
       st_shndx =
         Section_table.get_sec_idx sections
           (X86_proc.Section_name.of_string symbol.sy_sec.sec_name);

backend/x86_ast.mli

@@ -375,6 +375,7 @@ type asm_line =
   | Bytes of string
   | Comment of string
   | Global of string
+  | Protected of string
   | Hidden of string
   | Weak of string
   | Long of constant

backend/x86_binary_emitter.ml

@@ -69,6 +69,7 @@ type symbol = {
   mutable sy_type : string option;
   mutable sy_size : int option;
   mutable sy_global : bool;
+  mutable sy_protected : bool;
   mutable sy_sec : section;
   mutable sy_pos : int option;
   mutable sy_num : int option; (* position in .symtab *)
@@ -112,6 +113,7 @@ let get_symbol b s =
         sy_size = None;
         sy_pos = None;
         sy_global = false;
+        sy_protected = false;
         sy_num = None;
         sy_sec = b.sec;
       }
@@ -2030,7 +2032,8 @@ let assemble_line b loc ins =
         assemble_instr b loc instr;
         incr loc
     | Comment _ -> ()
-    | Global s -> (get_symbol b s).sy_global <- true
+    | Global sym -> (get_symbol b sym).sy_global <- true
+    | Protected sym -> (get_symbol b sym).sy_protected <- true
     | Quad (Const n) -> buf_int64L b n
     | Quad cst ->
         record_local_reloc b (RelocConstant (cst, B64));

backend/x86_binary_emitter.mli

@@ -24,6 +24,7 @@ type symbol = {
   mutable sy_type : string option;
   mutable sy_size : int option;
   mutable sy_global : bool;
+  mutable sy_protected : bool;
   mutable sy_sec : section;
   mutable sy_pos : int option;
   mutable sy_num : int option; (* position in .symtab *)

backend/x86_dsl.ml

@@ -95,6 +95,8 @@ module D = struct
   let extrn s ptr = directive (External (s, ptr))
   let file ~file_num ~file_name = directive (File (file_num, file_name))
   let global s = directive (Global s)
+  let protected s = directive (Protected s)
+
   let hidden s = directive (Hidden s)
   let weak s = directive (Weak s)
   let indirect_symbol s = directive (Indirect_symbol s)

backend/x86_dsl.mli

@@ -87,6 +87,7 @@ module D : sig
   val extrn: string -> data_type -> unit
   val file: file_num:int -> file_name:string -> unit
   val global: string -> unit
+  val protected: string -> unit
   val hidden: string -> unit
   val indirect_symbol: string -> unit
   val label: ?typ:data_type -> string -> unit

backend/x86_gas.ml

@@ -433,7 +433,8 @@ let print_line b = function
         bprintf b "\t.ascii\t\"%s\""
           (string_of_substring_literal i (String.length s - i) s)
   | Comment s -> bprintf b "\t\t\t\t/* %s */" s
-  | Global s -> bprintf b "\t.globl\t%s" s;
+  | Global s -> bprintf b "\t.globl\t%s" s
+  | Protected s -> bprintf b "\t.protected\t%s" s;
   | Hidden s -> bprintf b "\t.hidden\t%s" s;
   | Weak s -> bprintf b "\t.weak\t%s" s;
   | Long n -> bprintf b "\t.long\t%a" cst n

backend/x86_masm.ml

@@ -422,6 +422,7 @@ let print_line b = function
   | Weak _
   | Reloc _
   | Direct_assignment _
+  | Protected _
     -> assert false
 
 let generate_asm oc lines =

driver/flambda_backend_args.ml

@@ -563,6 +563,16 @@ let set_long_frames_threshold n =
             Flambda_backend_flags.max_long_frames_threshold));
   Flambda_backend_flags.long_frames_threshold := n
 
+let mk_symbol_visibility_protected f =
+  "-symbol-visibility-protected", Arg.Unit f,
+  " Emit global symbols with visibility STV_PROTECTED on supported systems"
+;;
+
+let mk_no_symbol_visibility_protected f =
+  "-no-symbol-visibility-protected", Arg.Unit f,
+  " Emit global symbols with visibility STV_DEFAULT"
+;;
+
 module type Flambda_backend_options = sig
   val ocamlcfg : unit -> unit
   val no_ocamlcfg : unit -> unit
@@ -595,6 +605,9 @@ module type Flambda_backend_options = sig
   val disable_poll_insertion : unit -> unit
   val enable_poll_insertion : unit -> unit
 
+  val symbol_visibility_protected : unit -> unit
+  val no_symbol_visibility_protected : unit -> unit
+
   val long_frames : unit -> unit
   val no_long_frames : unit -> unit
   val long_frames_threshold : int -> unit
@@ -699,6 +712,9 @@ struct
     mk_disable_poll_insertion F.disable_poll_insertion;
     mk_enable_poll_insertion F.enable_poll_insertion;
 
+    mk_symbol_visibility_protected F.symbol_visibility_protected;
+    mk_no_symbol_visibility_protected F.symbol_visibility_protected;
+
     mk_long_frames F.long_frames;
     mk_no_long_frames F.no_long_frames;
     mk_debug_long_frames_threshold F.long_frames_threshold;
@@ -857,6 +873,9 @@ module Flambda_backend_options_impl = struct
   let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion
   let enable_poll_insertion = clear' Flambda_backend_flags.disable_poll_insertion
 
+  let symbol_visibility_protected = set' Flambda_backend_flags.symbol_visibility_protected
+  let no_symbol_visibility_protected = clear' Flambda_backend_flags.symbol_visibility_protected
+
   let long_frames =  set' Flambda_backend_flags.allow_long_frames
   let no_long_frames = clear' Flambda_backend_flags.allow_long_frames
   let long_frames_threshold n = set_long_frames_threshold n
@@ -1119,6 +1138,7 @@ module Extra_params = struct
       end;
       true
     | "poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion
+    | "symbol-visibility-protected" -> set' Flambda_backend_flags.disable_poll_insertion
     | "long-frames" -> set' Flambda_backend_flags.allow_long_frames
     | "debug-long-frames-threshold" ->
       begin match Compenv.check_int ppf name v with

driver/flambda_backend_args.mli

@@ -51,6 +51,9 @@ module type Flambda_backend_options = sig
   val disable_poll_insertion : unit -> unit
   val enable_poll_insertion : unit -> unit
 
+  val symbol_visibility_protected : unit -> unit
+  val no_symbol_visibility_protected : unit -> unit
+
   val long_frames : unit -> unit
   val no_long_frames : unit -> unit
   val long_frames_threshold : int -> unit

driver/flambda_backend_flags.ml

@@ -65,6 +65,8 @@ let internal_assembler = ref false
 
 let gc_timings = ref false
 
+let symbol_visibility_protected = ref false (* -symbol-visibility-protected*)
+
 let flags_by_opt_level ~opt_level ~default ~oclassic ~o2 ~o3 =
   match opt_level with
   | Default -> default

driver/flambda_backend_flags.mli

@@ -65,6 +65,8 @@ val gc_timings : bool ref
 val use_cached_generic_functions : bool ref
 val cached_generic_functions_path : string ref
 
+val symbol_visibility_protected : bool ref
+
 module Flambda2 : sig
   val debug : bool ref
 

ocaml/driver/main_args.ml

@@ -296,7 +296,6 @@ let mk_no_probes f =
     "-no-probes", Arg.Unit f, " Ignore [%%probe ..]"
 ;;
 
-
 let mk_labels f =
   "-labels", Arg.Unit f, " Use commuting label mode"