merge

Author: TheNumbat

backend/amd64/emit.ml

@@ -68,15 +68,20 @@ let to_x86_constant_with_width (c : ND.Directive.Constant_with_width.t) :
 
 let to_x86_directive (dir : ND.Directive.t) : X86_ast.asm_line list =
   let comment_lines comment =
-    Option.to_list (Option.map (fun s -> X86_ast.Comment s) comment)
+    (* CR sspies: This check is usually done in the printing function of the new
+       directives. Since we are skipping those at the moment (by emitting via
+       the X86 DSL), we do the same check here in the conversion. *)
+    if !Clflags.keep_asm_file && !Flambda_backend_flags.dasm_comments
+    then Option.to_list (Option.map (fun s -> X86_ast.Comment s) comment)
+    else []
   in
   match dir with
   | Align { bytes } ->
     [X86_ast.Align (false, bytes)]
     (* The data field is currently ignored by both assembler backends. The bytes
        field is only converted to the final value when printing. *)
   | Bytes { str; comment } -> comment_lines comment @ [X86_ast.Bytes str]
-  | Comment s -> [X86_ast.Comment s]
+  | Comment s -> comment_lines (Some s)
   | Const { constant; comment } ->
     comment_lines comment @ [to_x86_constant_with_width constant]
   | Direct_assignment (s, c) ->
@@ -108,7 +113,7 @@ let to_x86_directive (dir : ND.Directive.t) : X86_ast.asm_line list =
     comment_lines comment @ [X86_ast.Sleb128 (to_x86_constant constant)]
   | Space { bytes } -> [Space bytes]
   | Type (n, st) ->
-    let typ = match st with Function -> "STT_FUNC" | Object -> "STT_OBJECT" in
+    let typ = ND.symbol_type_to_string st in
     [Type (n, typ)]
   | Uleb128 { constant; comment } ->
     comment_lines comment @ [X86_ast.Uleb128 (to_x86_constant constant)]
@@ -117,6 +122,9 @@ let to_x86_directive (dir : ND.Directive.t) : X86_ast.asm_line list =
   | Cfi_endproc -> [X86_ast.Cfi_endproc]
   | Cfi_offset { reg; offset } -> [X86_ast.Cfi_offset (reg, offset)]
   | Cfi_startproc -> [X86_ast.Cfi_startproc]
+  | Cfi_remember_state -> [X86_ast.Cfi_remember_state]
+  | Cfi_restore_state -> [X86_ast.Cfi_restore_state]
+  | Cfi_def_cfa_register r -> [X86_ast.Cfi_def_cfa_register r]
   | Protected s -> [X86_ast.Protected s]
 
 let _label s = D.label ~typ:QWORD s
@@ -619,105 +627,6 @@ let emit_jump_tables () =
   List.iter emit_jump_table !jump_tables;
   jump_tables := []
 
-let file_emitter ~file_num ~file_name =
-  ND.file ~file_num:(Some file_num) ~file_name
-
-let build_asm_directives () : (module Asm_targets.Asm_directives_intf.S) =
-  (module Asm_targets.Asm_directives.Make (struct
-    let emit_line line = ND.comment line
-
-    let get_file_num file_name = Emitaux.get_file_num ~file_emitter file_name
-
-    let debugging_comments_in_asm_files = !Flambda_backend_flags.dasm_comments
-
-    module D = struct
-      type constant = ND.Directive.Constant.t
-
-      let const_int64 num = ND.Directive.Constant.Signed_int num
-
-      let const_label str = ND.Directive.Constant.Named_thing str
-
-      let const_add c1 c2 = ND.Directive.Constant.Add (c1, c2)
-
-      let const_sub c1 c2 = ND.Directive.Constant.Sub (c1, c2)
-
-      (* CR sspies: The functions depending on [emit_directive] below break
-         abstractions. This is intensional at the moment, because this is only
-         the first step of getting rid of the first-class module entirely. *)
-      let emit_directive d = List.iter directive (to_x86_directive d)
-
-      type data_type =
-        | NONE
-        | DWORD
-        | QWORD
-        | VEC128
-
-      let file = file_emitter
-
-      let loc ~file_num ~line ~col ?discriminator () =
-        ignore discriminator;
-        D.loc ~file_num ~line ~col ?discriminator ()
-
-      let comment str = D.comment str
-
-      let label ?data_type str =
-        let _ = data_type in
-        emit_directive (New_label (str, Code))
-
-      let section ?delayed:_ name flags args =
-        match name, flags, args with
-        | [".data"], _, _ -> ND.data ()
-        | [".text"], _, _ -> ND.text ()
-        | name, flags, args -> ND.switch_to_section_raw ~names:name ~flags ~args
-
-      let text () = D.text ()
-
-      let new_line () = D.new_line ()
-
-      let emit_constant const size =
-        emit_directive
-          (Const
-             { constant = ND.Directive.Constant_with_width.create const size;
-               comment = None
-             })
-
-      let global sym = emit_directive (Global sym)
-
-      let protected sym =
-        if not (is_macosx system) then emit_directive (Protected sym)
-
-      let type_ sym typ_ =
-        let typ_ : ND.symbol_type =
-          match typ_ with
-          | "@function" -> Function
-          | "@object" -> Object
-          | "STT_OBJECT" -> Object
-          | "STT_FUNC" -> Function
-          | _ -> Misc.fatal_error "Unsupported type"
-        in
-        emit_directive (Type (sym, typ_))
-
-      let byte const = emit_constant const Eight
-
-      let word const = emit_constant const Sixteen
-
-      let long const = emit_constant const Thirty_two
-
-      let qword const = emit_constant const Sixty_four
-
-      let bytes str = ND.string str
-
-      let uleb128 const =
-        emit_directive (Uleb128 { constant = const; comment = None })
-
-      let sleb128 const =
-        emit_directive (Sleb128 { constant = const; comment = None })
-
-      let direct_assignment var const =
-        emit_directive (Direct_assignment (var, const))
-    end
-  end))
-
 (* Names for instructions *)
 
 let instr_for_intop = function
@@ -1589,7 +1498,10 @@ let emit_instr ~first ~fallthrough i =
       (* +0.0 *)
       I.xorpd (res i 0) (res i 0)
     | _ ->
-      (* float32 constants still take up 8 bytes; we load the lower half. *)
+      (* float32 constants take up 8 bytes when we emit them with
+         [float_literal] (see the conversion from int32 to int64 below). Thus,
+         we load the lower half. Note that this is different from Cmm 32-bit
+         floats ([Csingle]), which are emitted as 4-byte constants. *)
       let lbl = add_float_constant (Int64.of_int32 f) in
       I.movss (mem64_rip REAL4 (emit_label lbl)) (res i 0))
   | Lop (Const_float f) -> (
@@ -2081,7 +1993,7 @@ let emit_instr ~first ~fallthrough i =
     cfi_adjust_cfa_offset 8;
     I.mov rsp (domain_field Domainstate.Domain_exn_handler);
     stack_offset := !stack_offset + 16
-  | Lpoptrap ->
+  | Lpoptrap _ ->
     emit_pop_trap_label ();
     I.pop (domain_field Domainstate.Domain_exn_handler);
     cfi_adjust_cfa_offset (-8);
@@ -2118,7 +2030,7 @@ let emit_instr ~first ~fallthrough i =
 let rec emit_all ~first ~fallthrough i =
   match i.desc with
   | Lend -> ()
-  | Lprologue | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap | Lop _
+  | Lprologue | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap _ | Lop _
   | Lcall_op _ | Llabel _ | Lbranch _
   | Lcondbranch (_, _)
   | Lcondbranch3 (_, _, _)
@@ -2260,15 +2172,14 @@ let begin_assembly unix =
   (* We initialize the new assembly directives. *)
   Asm_targets.Asm_label.initialize ~new_label:(fun () ->
       Cmm.new_label () |> Label.to_int);
-  ND.initialize
-    ~big_endian:Arch.big_endian
+  ND.initialize ~big_endian:Arch.big_endian
+    ~emit_assembly_comments:!Flambda_backend_flags.dasm_comments
       (* As a first step, we emit by calling the corresponding x86 emit
          directives. *) ~emit:(fun d ->
       List.iter directive (to_x86_directive d));
   let code_begin = Cmm_helpers.make_symbol "code_begin" in
   let code_end = Cmm_helpers.make_symbol "code_end" in
-  Emitaux.Dwarf_helpers.begin_dwarf ~build_asm_directives ~code_begin ~code_end
-    ~file_emitter:D.file;
+  Emitaux.Dwarf_helpers.begin_dwarf ~code_begin ~code_end ~file_emitter:D.file;
   if is_win64 system
   then (
     D.extrn "caml_call_gc" NEAR;
@@ -2412,7 +2323,7 @@ let emit_probe_handler_wrapper p =
       name, handler_code_sym
     | Lcall_op
         (Lcall_ind | Ltailcall_ind | Lcall_imm _ | Ltailcall_imm _ | Lextcall _)
-    | Lprologue | Lend | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap
+    | Lprologue | Lend | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap _
     | Lop _ | Llabel _ | Lbranch _
     | Lcondbranch (_, _)
     | Lcondbranch3 (_, _, _)
@@ -2580,7 +2491,7 @@ let emit_probe_notes0 () =
       | Lcall_op
           ( Lcall_ind | Ltailcall_ind | Lcall_imm _ | Ltailcall_imm _
           | Lextcall _ )
-      | Lprologue | Lend | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap
+      | Lprologue | Lend | Lreloadretaddr | Lreturn | Lentertrap | Lpoptrap _
       | Lop _ | Llabel _ | Lbranch _
       | Lcondbranch (_, _)
       | Lcondbranch3 (_, _, _)