new directives on x86

Author: spiessimon

backend/amd64/emit.ml

@@ -777,7 +777,7 @@ let emit_literals p align emit_literal =
       (* CR sspies: The following section is incorrect. We are in a data section
          here. Fix this when cleaning up the section mechanism. *)
       D.unsafe_set_interal_section_ref Text);
-    D.align ~bytes:align;
+    D.align ~data_section:false ~bytes:align;
     List.iter emit_literal !p;
     p := [])
 
@@ -2068,7 +2068,7 @@ let fundecl fundecl =
   contains_calls := fundecl.fun_contains_calls;
   emit_named_text_section !function_name;
   let fun_sym = S.create fundecl.fun_name in
-  D.align ~bytes:8;
+  D.align ~data_section:false ~bytes:8;
   D.global fun_sym;
   D.type_symbol ~ty:Function fun_sym;
   D.define_symbol_label ~section:Text fun_sym;
@@ -2132,11 +2132,11 @@ let emit_item (d : Cmm.data_item) =
     D.symbol_plus_offset ~offset_in_bytes:(Targetint.of_int o) sym
   | Cstring s -> D.string s
   | Cskip n -> if n > 0 then D.space ~bytes:n
-  | Calign n -> D.align ~bytes:n
+  | Calign n -> D.align ~data_section:true ~bytes:n
 
 let data l =
   D.data ();
-  D.align ~bytes:8;
+  D.align ~data_section:true ~bytes:8;
   List.iter emit_item l
 
 let file_emitter ~file_num ~file_name =
@@ -2174,7 +2174,7 @@ let begin_assembly _unix =
   if macosx
   then (
     DSL.ins I.NOP [||];
-    D.align ~bytes:8);
+    D.align ~data_section:false ~bytes:8);
   let code_end = Cmm_helpers.make_symbol "code_end" in
   Emitaux.Dwarf_helpers.begin_dwarf ~code_begin ~code_end ~file_emitter
 
@@ -2192,7 +2192,7 @@ let end_assembly () =
   D.global data_end_sym;
   D.define_symbol_label ~section:Data data_end_sym;
   D.int64 0L;
-  D.align ~bytes:8;
+  D.align ~data_section:true ~bytes:8;
   (* #7887 *)
   let frametable = Cmm_helpers.make_symbol "frametable" in
   let frametable_sym = S.create frametable in
@@ -2221,7 +2221,7 @@ let end_assembly () =
       (* [efa_word] is [D.targetint (Targetint.of_int_exn n)] in
          mshinwell/ocaml#gdb-names-gpr x86 emitter *)
       efa_word = (fun n -> D.targetint (Targetint.of_int_exn n));
-      efa_align = (fun n -> D.align ~bytes:n);
+      efa_align = (fun n -> D.align ~data_section:true ~bytes:n);
       efa_label_rel =
         (fun lbl ofs ->
           let lbl = label_to_asm_label ~section:Data lbl in

backend/arm64/emit.ml

@@ -150,10 +150,15 @@ module Directive = struct
     | Code
     | Machine_width_data
 
+  type reloc_type = R_X86_64_PLT32
+
   type comment = string
 
   type t =
-    | Align of { bytes : int }
+    | Align of
+        { bytes : int;
+          data_section : bool
+        }
     | Bytes of
         { str : string;
           comment : string option
@@ -207,6 +212,14 @@ module Directive = struct
           comment : string option
         }
     | Protected of string
+    | Hidden of string
+    | Weak of string
+    | External of string
+    | Reloc of
+        { offset : Constant.t;
+          name : reloc_type;
+          expr : Constant.t
+        }
 
   let bprintf = Printf.bprintf
 
@@ -271,6 +284,8 @@ module Directive = struct
       bprintf buf "\t.ascii\t\"%s\""
         (string_of_string_literal (String.sub s !i (l - !i)))
 
+  let reloc_type_to_string = function R_X86_64_PLT32 -> "R_X86_64_PLT32"
+
   let print_gas buf t =
     let gas_comment_opt comment_opt =
       if not (emit_comments ())
@@ -281,7 +296,9 @@ module Directive = struct
         | Some comment -> Printf.sprintf "\t/* %s */" comment
     in
     match t with
-    | Align { bytes = n } ->
+    | Align { bytes = n; data_section = _ } ->
+      (* The data_section is only relevant for the binary emitter. On GAS, we
+         can ignore it and just use [.align] in both cases. *)
       (* Some assemblers interpret the integer n as a 2^n alignment and others
          as a number of bytes. *)
       let n =
@@ -381,6 +398,14 @@ module Directive = struct
         Misc.fatal_error
           "Cannot emit [Direct_assignment] except on macOS-like assemblers")
     | Protected s -> bprintf buf "\t.protected\t%s" s
+    | Hidden s -> bprintf buf "\t.hidden\t%s" s
+    | Weak s -> bprintf buf "\t.weak\t%s" s
+    (* masm only *)
+    | External _ -> assert false
+    | Reloc { offset; name; expr } ->
+      bprintf buf "\t.reloc\t%a, %s, %a" Constant.print offset
+        (reloc_type_to_string name)
+        Constant.print expr
 
   let print_masm buf t =
     let unsupported name =
@@ -395,7 +420,10 @@ module Directive = struct
         | Some comment -> Printf.sprintf "\t; %s" comment
     in
     match t with
-    | Align { bytes } -> bprintf buf "\tALIGN\t%d" bytes
+    | Align { bytes; data_section = _ } ->
+      (* The data_section is only relevant for the binary emitter. On MASM, we
+         can ignore it. *)
+      bprintf buf "\tALIGN\t%d" bytes
     | Bytes { str; comment } ->
       buf_bytes_directive buf ~directive:"BYTE" str;
       bprintf buf "%s" (masm_comment_opt comment)
@@ -441,6 +469,11 @@ module Directive = struct
     | Uleb128 _ -> unsupported "Uleb128"
     | Direct_assignment _ -> unsupported "Direct_assignment"
     | Protected _ -> unsupported "Protected"
+    | Hidden _ -> unsupported "Hidden"
+    | Weak _ -> unsupported "Weak"
+    | External s -> bprintf buf "\tEXTRN\t%s: NEAR" s
+    (* The only supported "type" on EXTRN declarations i NEAR. *)
+    | Reloc _ -> unsupported "Reloc"
 
   let print b t =
     match TS.assembler () with
@@ -485,6 +518,13 @@ let const_variable var = Variable var
 
 let const_int64 i : expr = Signed_int i
 
+let const_with_offset const (offset : int64) =
+  if Int64.equal offset 0L
+  then const
+  else if Int64.compare offset 0L < 0
+  then Add (const, Signed_int (Int64.neg offset))
+  else Add (const, Signed_int offset)
+
 let emit_ref = ref None
 
 let emit (d : Directive.t) =
@@ -497,7 +537,7 @@ let emit_non_masm (d : Directive.t) =
 
 let section ~names ~flags ~args = emit (Section { names; flags; args })
 
-let align ~bytes = emit (Align { bytes })
+let align ~data_section ~bytes = emit (Align { bytes; data_section })
 
 let should_generate_cfi () =
   (* We generate CFI info even if we're not generating any other debugging
@@ -548,8 +588,16 @@ let indirect_symbol symbol = emit (Indirect_symbol (Asm_symbol.encode symbol))
 
 let private_extern symbol = emit (Private_extern (Asm_symbol.encode symbol))
 
+let extrn symbol = emit (External (Asm_symbol.encode symbol))
+
+let hidden symbol = emit (Hidden (Asm_symbol.encode symbol))
+
+let weak symbol = emit (Weak (Asm_symbol.encode symbol))
+
 let size symbol cst = emit (Size (Asm_symbol.encode symbol, lower_expr cst))
 
+let size_const sym n = emit (Size (Asm_symbol.encode sym, Signed_int n))
+
 let type_ symbol ~type_ = emit (Type (symbol, type_))
 
 let sleb128 ?comment i =
@@ -626,7 +674,7 @@ let label ?comment label = const_machine_width ?comment (Label label)
 let label_plus_offset ?comment lab ~offset_in_bytes =
   let offset_in_bytes = Targetint.to_int64 offset_in_bytes in
   let lab = const_label lab in
-  const_machine_width ?comment (const_add lab (const_int64 offset_in_bytes))
+  const_machine_width ?comment (const_with_offset lab offset_in_bytes)
 
 let define_label label =
   let lbl_section = Asm_label.section label in
@@ -797,7 +845,7 @@ let symbol ?comment sym = const_machine_width ?comment (Symbol sym)
 
 let symbol_plus_offset symbol ~offset_in_bytes =
   let offset_in_bytes = Targetint.to_int64 offset_in_bytes in
-  const_machine_width (Add (Symbol symbol, Signed_int offset_in_bytes))
+  const_machine_width (const_with_offset (Symbol symbol) offset_in_bytes)
 
 let int8 ?comment i =
   const ?comment (Signed_int (Int64.of_int (Int8.to_int i))) Eight
@@ -890,9 +938,11 @@ let between_labels_16_bit ?comment:_ ~upper:_ ~lower:_ () =
   (* CR poechsel: use the arguments *)
   Misc.fatal_error "between_labels_16_bit not implemented yet"
 
-let between_labels_32_bit ?comment:_ ~upper:_ ~lower:_ () =
-  (* CR poechsel: use the arguments *)
-  Misc.fatal_error "between_labels_32_bit not implemented yet"
+let between_labels_32_bit ?comment:_comment ~upper ~lower () =
+  let expr = const_sub (const_label upper) (const_label lower) in
+  (* CR sspies: Following the x86 implementation, we *do not* force an assembly
+     time constant here. *)
+  const expr Thirty_two
 
 let between_labels_64_bit ?comment:_ ~upper:_ ~lower:_ () =
   (* CR poechsel: use the arguments *)
@@ -1065,3 +1115,14 @@ let offset_into_dwarf_section_symbol ?comment:_comment
   match width with
   | Thirty_two -> const expr Thirty_two
   | Sixty_four -> const expr Sixty_four
+
+let reloc_x86_64_plt32 ~offset_from_this ~target_symbol ~rel_offset_from_next =
+  emit
+    (Reloc
+       { offset = Sub (This, Signed_int offset_from_this);
+         name = R_X86_64_PLT32;
+         expr =
+           Sub
+             ( Named_thing (Asm_symbol.encode target_symbol),
+               Signed_int rel_offset_from_next )
+       })

backend/asm_targets/asm_directives_new.ml

@@ -159,7 +159,7 @@ val cfi_def_cfa_register : reg:string -> unit
 val mark_stack_non_executable : unit -> unit
 
 (** Leave as much space as is required to achieve the given alignment. *)
-val align : bytes:int -> unit
+val align : data_section:bool -> bytes:int -> unit
 
 (** Emit a directive giving the displacement between the given symbol and
     the current position.  This should only be used to state sizes of
@@ -168,6 +168,8 @@ val align : bytes:int -> unit
     from that whose size is being stated (e.g. on POWER with ELF ABI v1). *)
 val size : ?size_of:Asm_symbol.t -> Asm_symbol.t -> unit
 
+val size_const : Asm_symbol.t -> int64 -> unit
+
 (** Leave a gap in the object file. *)
 val space : bytes:int -> unit
 
@@ -197,6 +199,15 @@ val protected : Asm_symbol.t -> unit
     details). *)
 val private_extern : Asm_symbol.t -> unit
 
+(** Mark an already encoded symbol as external. *)
+val extrn : Asm_symbol.t -> unit
+
+(** Mark an already encoded symbol or label as hidden. *)
+val hidden : Asm_symbol.t -> unit
+
+(** Mark an already encoded symbol or label as weak. *)
+val weak : Asm_symbol.t -> unit
+
 (** Marker inside the definition of a lazy symbol stub (see platform or
     assembler documentation for details). *)
 val indirect_symbol : Asm_symbol.t -> unit
@@ -306,6 +317,12 @@ val offset_into_dwarf_section_symbol :
   Asm_symbol.t ->
   unit
 
+val reloc_x86_64_plt32 :
+  offset_from_this:int64 ->
+  target_symbol:Asm_symbol.t ->
+  rel_offset_from_next:int64 ->
+  unit
+
 module Directive : sig
   module Constant : sig
     (* CR sspies: make this private again once the first-class module has been
@@ -354,6 +371,10 @@ module Directive : sig
      removed *)
   type comment = string
 
+  (* ELF specific *)
+  type reloc_type = R_X86_64_PLT32
+  (* X86 only *)
+
   (* CR sspies: make this private again once the first-class module has been
      removed *)
 
@@ -363,7 +384,14 @@ module Directive : sig
       have had all necessary prefixing, mangling, escaping and suffixing
       applied. *)
   type t =
-    | Align of { bytes : int }
+    | Align of
+        { bytes : int;
+              (** The number of bytes to align to. This will be taken log2 by the emitter on
+          Arm and macOS platforms.*)
+          data_section : bool
+              (** The data_section flag controls whether the binary emitter emits NOP instructions
+          or null bytes. *)
+        }
     | Bytes of
         { str : string;
           comment : string option
@@ -417,6 +445,14 @@ module Directive : sig
           comment : string option
         }
     | Protected of string
+    | Hidden of string
+    | Weak of string
+    | External of string
+    | Reloc of
+        { offset : Constant.t;
+          name : reloc_type;
+          expr : Constant.t
+        }
 
   (** Translate the given directive to textual form.  This produces output
       suitable for either gas or MASM as appropriate. *)

backend/asm_targets/asm_directives_new.mli

@@ -69,6 +69,8 @@ let create_string section label =
   assert (not (contains_escapable_char label));
   { section; label = String label }
 
+let create_string_unchecked section label = { section; label = String label }
+
 let label_prefix =
   match Target_system.assembler () with MacOS -> "L" | MASM | GAS_like -> ".L"
 
@@ -138,6 +140,7 @@ let for_dwarf_section (dwarf_section : Asm_section.dwarf_section) =
   | Debug_str -> Lazy.force debug_str_label
   | Debug_line -> Lazy.force debug_line_label
 
+(* CR sspies: Remove the other cases where we never emit a label upfront. *)
 let for_section (section : Asm_section.t) =
   match section with
   | DWARF dwarf_section -> for_dwarf_section dwarf_section
@@ -147,3 +150,7 @@ let for_section (section : Asm_section.t) =
   | Eight_byte_literals -> Lazy.force eight_byte_literals_label
   | Sixteen_byte_literals -> Lazy.force sixteen_byte_literals_label
   | Jump_tables -> Lazy.force jump_tables_label
+  | Stapsdt_base -> Misc.fatal_error "Stapsdt_base has no associated label"
+  | Stapsdt_note -> Misc.fatal_error "Stapsdt_note has no associated label"
+  | Probes -> Misc.fatal_error "Probes has no associated label"
+  | Note_ocaml_eh -> Misc.fatal_error "Note_ocaml_eh has no associated label"

backend/asm_targets/asm_label.ml

@@ -52,6 +52,9 @@ val create_int : Asm_section.t -> int -> t
 (** Create a textual label. The supplied name must not require escaping. *)
 val create_string : Asm_section.t -> string -> t
 
+(** Create a textual label. Argument string is not checked, so use with caution. *)
+val create_string_unchecked : Asm_section.t -> string -> t
+
 (** Convert a label to the corresponding textual form, suitable for direct
     emission into an assembly file. This may be useful e.g. when emitting an
     instruction referencing a label. *)

backend/asm_targets/asm_label.mli

@@ -48,6 +48,10 @@ type t =
   | Sixteen_byte_literals
   | Jump_tables
   | Text
+  | Stapsdt_base
+  | Stapsdt_note
+  | Probes
+  | Note_ocaml_eh
 
 let dwarf_sections_in_order () =
   let sections =
@@ -72,7 +76,7 @@ let is_delayed = function
       ( Debug_info | Debug_abbrev | Debug_aranges | Debug_str | Debug_loclists
       | Debug_rnglists | Debug_addr | Debug_loc | Debug_ranges )
   | Data | Read_only_data | Eight_byte_literals | Sixteen_byte_literals
-  | Jump_tables | Text ->
+  | Jump_tables | Text | Stapsdt_base | Stapsdt_note | Probes | Note_ocaml_eh ->
     false
 
 let print ppf t =
@@ -94,6 +98,10 @@ let print ppf t =
     | Sixteen_byte_literals -> "Sixteen_byte_literals"
     | Jump_tables -> "Jump_tables"
     | Text -> "Text"
+    | Stapsdt_base -> "Stapsdt_base"
+    | Stapsdt_note -> "Stapsdt_note"
+    | Probes -> "Probes"
+    | Note_ocaml_eh -> "Note_ocaml_eh"
   in
   Format.pp_print_string ppf str
 
@@ -104,7 +112,8 @@ let equal t1 t2 = Stdlib.compare t1 t2 = 0
 let section_is_text = function
   | Text -> true
   | Data | Read_only_data | Eight_byte_literals | Sixteen_byte_literals
-  | Jump_tables | DWARF _ ->
+  | Jump_tables | DWARF _ | Stapsdt_base | Stapsdt_note | Probes | Note_ocaml_eh
+    ->
     false
 
 type section_details =
@@ -164,19 +173,20 @@ let details t ~first_occurrence =
         | false, _ -> []
       in
       [name], flags, args
-    | (Eight_byte_literals | Sixteen_byte_literals), (ARM | AArch64 | Z), _
-    | (Eight_byte_literals | Sixteen_byte_literals), _, Solaris ->
-      rodata ()
-    | Sixteen_byte_literals, _, MacOS_like ->
-      ["__TEXT"; "__literal16"], None, ["16byte_literals"]
-    | Sixteen_byte_literals, _, (MinGW_64 | Cygwin) -> [".rdata"], Some "dr", []
-    | Sixteen_byte_literals, _, (MinGW_32 | Win32 | Win64) -> data ()
-    | Sixteen_byte_literals, _, _ -> [".rodata.cst8"], Some "a", ["@progbits"]
+    (* Eight Byte Literals; based on corresponding upstream secions *)
     | Eight_byte_literals, _, MacOS_like ->
       ["__TEXT"; "__literal8"], None, ["8byte_literals"]
     | Eight_byte_literals, _, (MinGW_64 | Cygwin) -> [".rdata"], Some "dr", []
-    | Eight_byte_literals, _, (MinGW_32 | Win32 | Win64) -> data ()
-    | Eight_byte_literals, _, _ -> [".rodata.cst8"], Some "a", ["@progbits"]
+    | Eight_byte_literals, _, Win64 -> data ()
+    | Eight_byte_literals, _, _ ->
+      [".rodata.cst8"], Some "aM", ["@progbits"; "8"]
+    (* Sixteen Byte Literals; based on corresponding upstream secions *)
+    | Sixteen_byte_literals, _, MacOS_like ->
+      ["__TEXT"; "__literal16"], None, ["16byte_literals"]
+    | Sixteen_byte_literals, _, (MinGW_64 | Cygwin) -> [".rdata"], Some "dr", []
+    | Sixteen_byte_literals, _, Win64 -> data ()
+    | Sixteen_byte_literals, _, _ ->
+      [".rodata.cst16"], Some "aM", ["@progbits"; "16"]
     | Jump_tables, _, (MinGW_64 | Cygwin) -> [".rdata"], Some "dr", []
     | Jump_tables, _, (MinGW_32 | Win32) -> data ()
     | Jump_tables, _, (MacOS_like | Win64) ->
@@ -185,6 +195,18 @@ let details t ~first_occurrence =
     | Read_only_data, _, (MinGW_32 | Win32) -> data ()
     | Read_only_data, _, (MinGW_64 | Cygwin) -> [".rdata"], Some "dr", []
     | Read_only_data, _, _ -> rodata ()
+    (* CR sspies: Is this one really possible on all systems? *)
+    | Stapsdt_base, _, _ ->
+      [".stapsdt.base"], Some "aG", ["\"progbits\""; ".stapsdt.base"; "comdat"]
+    | Stapsdt_note, _, MacOS_like ->
+      ["__DATA"; "__note_stapsdt"], None, ["regular"]
+    | Stapsdt_note, _, (GNU | Solaris | Linux | Generic_BSD | BeOS) ->
+      [".note.stapsdt"], Some "?", ["\"note\""]
+    | Stapsdt_note, _, _ ->
+      Misc.fatal_error "Target systems does not support stapsdt."
+    | Probes, _, MacOS_like -> ["__TEXT"; "__probes"], None, ["regular"]
+    | Probes, _, _ -> [".probes"], Some "wa", ["\"progbits\""]
+    | Note_ocaml_eh, _, _ -> [".note.ocaml_eh"], Some "?", ["\"note\""]
   in
   { names; flags; args }
 

backend/asm_targets/asm_section.ml

@@ -48,6 +48,10 @@ type t =
   | Sixteen_byte_literals
   | Jump_tables
   | Text
+  | Stapsdt_base
+  | Stapsdt_note
+  | Probes
+  | Note_ocaml_eh
 
 val to_string : t -> string
 

backend/asm_targets/asm_section.mli

@@ -44,35 +44,29 @@ let should_be_escaped = function
 module Thing = struct
   type t =
     { name : string;
-      without_prefix : bool
+      already_encoded : bool
     }
 
-  let compare { name = name1; without_prefix = without_prefix1 }
-      { name = name2; without_prefix = without_prefix2 } =
+  let compare { name = name1; already_encoded = already_encoded1 }
+      { name = name2; already_encoded = already_encoded2 } =
     let cmp = String.compare name1 name2 in
-    if cmp = 0 then Bool.compare without_prefix1 without_prefix2 else cmp
+    if cmp = 0 then Bool.compare already_encoded1 already_encoded2 else cmp
 
   let equal t1 t2 = compare t1 t2 = 0
 
   let hash = Hashtbl.hash
 
-  let output chan { name; without_prefix } =
-    let symbol_prefix = if without_prefix then symbol_prefix () else "" in
-    Printf.fprintf chan "%s%s" symbol_prefix name
+  let output chan { name; already_encoded : _ } = Printf.fprintf chan "%s" name
 
-  let print fmt { name; without_prefix } =
-    let symbol_prefix = if without_prefix then symbol_prefix () else "" in
-    Format.pp_print_string fmt (symbol_prefix ^ name)
+  let print fmt { name; already_encoded : _ } = Format.pp_print_string fmt name
 end
 
 include Thing
 include Identifiable.Make (Thing)
 
-let create ?without_prefix name =
-  let without_prefix = Option.is_some without_prefix in
-  { name; without_prefix }
+let create ?(already_encoded = false) name = { name; already_encoded }
 
-let to_raw_string { name; without_prefix } = name
+let to_raw_string { name; already_encoded : _ } = name
 
 let escape name =
   let escaped_nb = ref 0 in
@@ -97,6 +91,9 @@ let to_escaped_string ?suffix ~symbol_prefix t =
   let suffix = match suffix with None -> "" | Some suffix -> suffix in
   symbol_prefix ^ escape t ^ suffix
 
-let encode t =
-  let symbol_prefix = if t.without_prefix then "" else symbol_prefix () in
-  to_escaped_string ~symbol_prefix t.name
+let encode { name; already_encoded } =
+  if already_encoded
+  then name
+  else
+    let symbol_prefix = symbol_prefix () in
+    to_escaped_string ~symbol_prefix name

backend/asm_targets/asm_symbol.ml

@@ -29,10 +29,10 @@ val should_be_escaped : char -> bool
 
 include Identifiable.S
 
-(* If [without_prefix] is not provided [encode] will prefix the symbol using the
-   (architecture-dependent) prefix for symbols, for example "_" on macOS. In
-   contrast, [to_raw_string] will always return the non-prefixed version. *)
-val create : ?without_prefix:unit -> string -> t
+(** [create] creates a new symbol. By default, it is assumed that the symbol has not been
+    encoded. In some rare cases, the symbol is encoded elsewhere. In these cases, set the
+    flag [already_encoded] to [true].  *)
+val create : ?already_encoded:bool -> string -> t
 
 val encode : t -> string
 

backend/asm_targets/asm_symbol.mli

@@ -177,7 +177,7 @@ let is_macos () =
   | MASM | GAS_like -> false
   | MacOS -> true
 
-  let is_gas () =
-    match assembler () with
-    | MASM | MacOS -> false
-    | GAS_like -> true
+let is_gas () =
+  match assembler () with
+  | MASM | MacOS -> false
+  | GAS_like -> true