refactoring

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/dwarf@13100 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

asmcomp/dwarf/compilation_unit_state.ml

@@ -0,0 +1,176 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Mark Shinwell, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright and licence information to be added.                     *)
+(*                                                                     *)
+(*                                                                     *)
+(*                                                                     *)
+(***********************************************************************)
+
+type t = {
+  source_file_path : string option;
+  start_of_code_label : string;
+  end_of_code_label : string;
+  mutable externally_visible_functions : string list;
+  mutable function_tags :
+    (int * string * Dwarf_low.Tag.t * Dwarf_low.Attribute_value.t list) list;
+  mutable debug_loc_table : Dwarf_low.Debug_loc_table.t;
+}
+
+let create ~source_file_path ~start_of_code_label ~end_of_code_label =
+  { source_file_path;
+    start_of_code_label;
+    end_of_code_label;
+    externally_visible_functions = [];
+    function_tags = [];
+    debug_loc_table = Dwarf_low.Debug_loc_table.create ();
+  }
+
+let builtin_ocaml_type_label_value = "type_value"
+
+let build_ocaml_type_tags () = [
+  1, builtin_ocaml_type_label_value, Dwarf_low.Tag.base_type, [
+    Dwarf_low.Attribute_value.create_name ~source_file_path:"value";
+    Dwarf_low.Attribute_value.create_encoding
+      ~encoding:Dwarf_low.Encoding_attribute.signed;
+    Dwarf_low.Attribute_value.create_byte_size
+      ~byte_size:8;
+  ];
+]
+
+module Function = struct
+  type t = string  (* function name, ahem *)
+end
+
+let start_function t ~function_name ~arguments_and_locations =
+  let starting_label = sprintf "Llr_begin_%s" function_name in
+  let ending_label = sprintf "Llr_end_%s" function_name in
+  emit_label_declaration starting_label;
+  let debug_loc_table, argument_tags =
+    List.fold arguments_and_locations
+      ~init:(t.debug_loc_table, [])
+      ~f:(fun (debug_loc_table, tags) (ident, pseudoreg_location) ->
+            let location_expression =
+              match pseudoreg_location with
+              (* CR mshinwell: fix the stack case *)
+              | `Stack () -> None
+              | `Hard_register reg_number ->
+                Some (Dwarf_low.Location_expression.in_register reg_number)
+            in
+            match location_expression with
+            | None -> debug_loc_table, tags
+            | Some location_expression ->
+              let base_address_selection_entry =
+                Dwarf_low.Location_list_entry.
+                  create_base_address_selection_entry
+                  ~base_address_label:starting_label
+              in
+              let location_list_entry =
+                Dwarf_low.Location_list_entry.create_location_list_entry
+                  ~start_of_code_label:starting_label
+                  ~first_address_when_in_scope:starting_label
+                  ~first_address_when_not_in_scope:ending_label  (* fixme *)
+                  ~location_expression
+              in
+              let location_list =
+                Dwarf_low.Location_list.create
+                  [base_address_selection_entry; location_list_entry]
+              in
+              let debug_loc_table, loclistptr_attribute_value =
+                Dwarf_low.Debug_loc_table.insert debug_loc_table
+                  ~location_list
+              in
+              let arg_name = Ident.name ident in
+              let tag =
+                2, function_name ^ "__arg__" ^ (Ident.unique_name ident),
+                  Dwarf_low.Tag.formal_parameter,
+                  [Dwarf_low.Attribute_value.create_name
+                     ~source_file_path:arg_name;
+                   loclistptr_attribute_value;
+                   Dwarf_low.Attribute_value.create_type
+                     ~label_name:builtin_ocaml_type_label_value;
+                  ]
+              in
+              debug_loc_table, tag::tags)
+  in
+  let subprogram_tag =
+    let tag =
+      if List.length argument_tags > 0 then
+        Dwarf_low.Tag.subprogram
+      else
+        Dwarf_low.Tag.subprogram_with_no_children
+    in
+    1, function_name, tag, [
+      Dwarf_low.Attribute_value.create_name ~source_file_path:function_name;
+      Dwarf_low.Attribute_value.create_external ~is_visible_externally:true;
+      Dwarf_low.Attribute_value.create_low_pc ~address_label:starting_label;
+      Dwarf_low.Attribute_value.create_high_pc ~address_label:ending_label;
+    ]
+  in
+  let this_function's_tags =
+    subprogram_tag::(List.rev argument_tags)
+  in
+  t.externally_visible_functions <-
+    function_name::t.externally_visible_functions;
+  t.debug_loc_table <- debug_loc_table;
+  t.function_tags <- t.function_tags @ this_function's_tags;
+  function_name
+
+let end_function _t function_name =
+  emit_label_declaration (sprintf "Llr_end_%s" function_name)
+
+let emit_debugging_info_prologue _t =
+  emit_section_declaration ~section_name:".debug_abbrev";
+  emit_label_declaration ~label_name:"Ldebug_abbrev0";
+  emit_section_declaration ~section_name:".debug_line";
+  emit_label_declaration ~label_name:"Ldebug_line0";
+  emit_section_declaration ~section_name:".debug_loc";
+  emit_label_declaration ~label_name:"Ldebug_loc0"
+
+let emit_debugging_info_epilogue t =
+  let producer_name = sprintf "ocamlopt %s" Sys.ocaml_version in
+  let compile_unit_attribute_values =
+    let common = [
+      Dwarf_low.Attribute_value.create_producer ~producer_name;
+      Dwarf_low.Attribute_value.create_low_pc
+        ~address_label:t.start_of_code_label;
+      Dwarf_low.Attribute_value.create_high_pc
+        ~address_label:t.end_of_code_label;
+      Dwarf_low.Attribute_value.create_stmt_list
+        ~section_offset_label:"Ldebug_line0";
+      Dwarf_low.Attribute_value.create_comp_dir ~directory:(Sys.getcwd ());
+    ]
+    in
+    match t.source_file_path with
+    | None -> common
+    | Some source_file_path ->
+      (Dwarf_low.Attribute_value.create_name ~source_file_path)::common
+  in
+  let tags_with_attribute_values = [
+    0, "compile_unit",
+      Dwarf_low.Tag.compile_unit, compile_unit_attribute_values;
+  ] @ (build_ocaml_type_tags ()) @ t.function_tags
+  in
+  let debug_info =
+    Dwarf_low.Debug_info_section.create ~tags_with_attribute_values
+  in
+  let debug_abbrev =
+    Dwarf_low.Debug_info_section.to_abbreviations_table debug_info
+  in
+  emit_section_declaration ~section_name:".debug_info";
+  emit_label_declaration "Ldebug_info0";
+  Dwarf_low.Debug_info_section.emit debug_info;
+  emit_switch_to_section ~section_name:".debug_abbrev";
+  Dwarf_low.Abbreviations_table.emit debug_abbrev;
+  emit_section_declaration ~section_name:".debug_pubnames";
+  Dwarf_low.Pubnames_table.emit
+    ~externally_visible_functions:t.externally_visible_functions
+    ~debug_info;
+  emit_section_declaration ~section_name:".debug_aranges";
+  Dwarf_low.Aranges_table.emit ~start_of_code_label:t.start_of_code_label
+    ~end_of_code_label:t.end_of_code_label;
+  emit_switch_to_section ~section_name:".debug_loc";
+  Dwarf_low.Debug_loc_table.emit t.debug_loc_table

asmcomp/dwarf/compilation_unit_state.mli

@@ -0,0 +1,33 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Mark Shinwell, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright and licence information to be added.                     *)
+(*                                                                     *)
+(*                                                                     *)
+(*                                                                     *)
+(***********************************************************************)
+
+type t
+
+val create : source_file_path:string
+  -> start_of_code_label:string
+  -> end_of_code_label:string
+  -> t
+
+val emit_debugging_info_prologue : t -> emitter:Dwarf_low.Emitter.t -> unit
+val emit_debugging_info_epilogue : t -> emitter:Dwarf_low.Emitter.t -> unit
+
+module Function : sig
+  type t
+end
+
+val start_function : t
+  -> function_name:string
+  -> arguments_and_locations:
+       (string * [ `Stack of unit | `Hard_register of int ]) list
+  -> Function.t
+
+val end_function : t -> Function.t -> unit

asmcomp/dwarf_low/abbreviation_code.ml

@@ -0,0 +1,16 @@
+type t = Value.t
+
+exception Bad_abbreviation_code of int
+
+let of_int i =
+  if i < 1 then raise (Bad_abbreviation_code i);
+  Value.as_uleb128 i
+
+let null () =
+  Value.as_uleb128 0
+
+let emit t ~emitter =
+  Value.emit t ~emitter
+
+let size t =
+  Value.size t

asmcomp/dwarf_low/abbreviation_code.mli

@@ -0,0 +1,6 @@
+type t
+
+include Emittable with type t := t
+
+val of_int : int -> t
+val null : unit -> t

asmcomp/dwarf_low/abbreviations_table.ml

@@ -0,0 +1,8 @@
+type t = Abbreviations_table_entry.t list
+
+let create abbrev_table_entries =
+  abbrev_table_entries
+
+let emit t ~emitter =
+  List.iter t ~f:(Abbreviations_table_entry.emit ~emitter);
+  Value.emit (Value.as_uleb128 0) ~emitter

asmcomp/dwarf_low/abbreviations_table.mli

@@ -0,0 +1,5 @@
+type t
+
+include Emittable with type t := t
+
+val create : Abbreviations_table_entry.t list -> t

asmcomp/dwarf_low/abbreviations_table_entry.ml

@@ -0,0 +1,19 @@
+type t = {
+  abbreviation_code : Abbreviation_code.t;
+  tag : Tag.t;
+  attributes : Attribute.t list;
+}
+
+let create ~abbreviation_code ~tag ~attributes =
+  { abbreviation_code;
+    tag;
+    attributes;
+  }
+
+let emit t ~emitter =
+  Abbreviation_code.emit t.abbreviation_code ~emitter;
+  Tag.emit t.tag ~emitter;
+  Child_determination.emit (Tag.child_determination t.tag) ~emitter;
+  List.iter t.attributes ~f:(Attribute.emit_followed_by_form ~emitter);
+  Value.emit (Value.as_uleb128 0) ~emitter;
+  Value.emit (Value.as_uleb128 0) ~emitter

asmcomp/dwarf_low/abbreviations_table_entry.mli

@@ -0,0 +1,8 @@
+type t
+
+include Emittable with type t := t
+
+val create : abbreviation_code:Abbreviation_code.t
+  -> tag:Tag.t
+  -> attributes:Attribute.t list
+  -> t

asmcomp/dwarf_low/aranges_table.ml

@@ -0,0 +1,33 @@
+type t = {
+  size : Value.t;
+  values : Value.t list;
+}
+
+let create ~start_of_code_label ~end_of_code_label =
+  let address_width_in_bytes_on_target = Value.as_byte 8 in
+  let values = [
+    Value.as_two_byte_int 2;  (* section version number *)
+    Value.as_four_byte_int 0;
+    address_width_in_bytes_on_target;
+    Value.as_byte 0;
+    Value.as_two_byte_int 0;
+    Value.as_two_byte_int 0;
+    Value.as_code_address_from_label start_of_code_label;
+    Value.as_code_address_from_label_diff
+      end_of_code_label start_of_code_label;
+    Value.as_code_address Int64.zero;
+    Value.as_code_address Int64.zero;
+  ]
+  in
+  let size =
+    List.fold_left values
+      ~init:0
+      ~f:(fun size value -> size + Value.size value)
+  in
+  { size; values; }
+
+let size t = t.size
+
+let emit t ~emitter =
+  Value.emit (Value.as_four_byte_int t.size) ~emitter;
+  List.iter t.values ~f:(Value.emit ~emitter)

asmcomp/dwarf_low/aranges_table.mli

@@ -0,0 +1,7 @@
+type t
+
+include Emittable with type t := t
+
+val create : start_of_code_label:string
+  -> end_of_code_label:string
+  -> t

asmcomp/dwarf_low/attribute.ml

@@ -0,0 +1,57 @@
+type t =
+  | DW_AT_low_pc
+  | DW_AT_high_pc
+  | DW_AT_name
+  | DW_AT_comp_dir
+  | DW_AT_producer
+  | DW_AT_stmt_list
+  | DW_AT_external
+  | DW_AT_location
+  | DW_AT_type
+  | DW_AT_encoding
+  | DW_AT_byte_size
+
+let encode = function
+  | DW_AT_low_pc -> 0x11
+  | DW_AT_high_pc -> 0x12
+  | DW_AT_name -> 0x03
+  | DW_AT_comp_dir -> 0x1b
+  | DW_AT_producer -> 0x25
+  | DW_AT_stmt_list -> 0x10
+  | DW_AT_external -> 0x3f
+  | DW_AT_location -> 0x02
+  | DW_AT_type -> 0x49
+  | DW_AT_encoding -> 0x3e
+  | DW_AT_byte_size -> 0x0b
+
+let form = function
+  | DW_AT_low_pc -> Form.addr
+  | DW_AT_high_pc -> Form.addr
+  | DW_AT_name -> Form.string
+  | DW_AT_comp_dir -> Form.string
+  | DW_AT_producer -> Form.string
+  | DW_AT_stmt_list -> Form.data4
+  | DW_AT_external -> Form.flag
+  | DW_AT_location -> Form.data8
+  | DW_AT_type -> Form.ref_addr
+  | DW_AT_encoding -> Form.data1
+  | DW_AT_byte_size -> Form.data1
+
+let low_pc = DW_AT_low_pc
+let high_pc = DW_AT_high_pc
+let producer = DW_AT_producer
+let name = DW_AT_name
+let comp_dir = DW_AT_comp_dir
+let stmt_list = DW_AT_stmt_list
+let extern'l = DW_AT_external
+let location = DW_AT_location
+let typ' = DW_AT_type
+let encoding = DW_AT_encoding
+let byte_size = DW_AT_byte_size
+
+let size t =
+  Value.size (Value.as_uleb128 (encode t)) + Form.size (form t)
+
+let emit t ~emitter =
+  Value.emit (Value.as_uleb128 (encode t)) ~emitter;
+  Form.emit (form t) ~emitter

asmcomp/dwarf_low/attribute.mli

@@ -0,0 +1,16 @@
+type t
+
+(* [emit] emits the attribute followed by the form. *)
+include Emittable with type t := t
+
+val low_pc : t
+val high_pc : t
+val producer : t
+val name : t
+val comp_dir : t
+val stmt_list : t
+val extern'l : t
+val location : t
+val typ' : t
+val encoding : t
+val byte_size : t