Change the way the debug sections are printed.

If a user uses the #pragma use_section for functions the diab linker
requires a separate debug_info section for each entry. This commit
adds functionality to emulate this behavior.

1 files changed, 69 insertions, 47 deletions

diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
index 7fce22a7..3239ceb6 100644
--- a/debug/Dwarfgen.ml
+++ b/debug/Dwarfgen.ml
@@ -72,10 +72,20 @@ let void_to_entry id =
   } in
   new_entry id (DW_TAG_base_type void)
 
-let typedef_to_entry id t =
+let translate_file_loc sec (f,l)  =
+  Hashtbl.find filenum (sec,f),l
+
+let translate_file_loc_opt sec = function
+  | None -> None
+  | Some (f,l) ->
+    try 
+      Some (translate_file_loc sec (f,l))
+    with Not_found -> None
+
+let typedef_to_entry sec id t =
   let i = get_opt_val t.typ in
   let td = {
-    typedef_file_loc = t.typedef_file_loc;
+    typedef_file_loc = translate_file_loc_opt sec t.typedef_file_loc;
     typedef_name = t.typedef_name;
     typedef_type = i;
   } in
@@ -110,7 +120,7 @@ let const_to_entry id c =
 let volatile_to_entry id v =
   new_entry id (DW_TAG_volatile_type ({volatile_type = v.vol_type}))
 
-let enum_to_entry id e =
+let enum_to_entry sec id e =
   let enumerator_to_entry e =
     let tag =
       {
@@ -121,7 +131,7 @@ let enum_to_entry id e =
     new_entry (next_id ()) (DW_TAG_enumerator tag) in
   let bs = sizeof_ikind enum_ikind in
   let enum = {
-    enumeration_file_loc = e.enum_file_loc;
+    enumeration_file_loc = translate_file_loc_opt sec e.enum_file_loc;
     enumeration_byte_size = bs;
     enumeration_declaration = Some false;
     enumeration_name = Some e.enum_name;
@@ -172,9 +182,9 @@ let member_to_entry mem =
   } in
   new_entry (next_id ()) (DW_TAG_member mem)
 
-let struct_to_entry id s =
+let struct_to_entry sec id s =
   let tag = {
-     structure_file_loc = s.ct_file_loc;
+     structure_file_loc = translate_file_loc_opt sec s.ct_file_loc;
      structure_byte_size = s.ct_sizeof;
      structure_declaration = Some s.ct_declaration;
      structure_name = if s.ct_name <> "" then Some s.ct_name else None;
@@ -183,9 +193,9 @@ let struct_to_entry id s =
   let child = List.map member_to_entry s.ct_members in
   add_children entry child
 
-let union_to_entry id s =
+let union_to_entry sec id s =
   let tag = {
-    union_file_loc = s.ct_file_loc;
+    union_file_loc =  translate_file_loc_opt sec s.ct_file_loc;
     union_byte_size = s.ct_sizeof;
     union_declaration = Some s.ct_declaration;
     union_name = if s.ct_name <> "" then Some s.ct_name else None;
@@ -194,20 +204,20 @@ let union_to_entry id s =
   let child = List.map member_to_entry s.ct_members in
   add_children entry child
 
-let composite_to_entry id s =
+let composite_to_entry sec id s =
   match s.ct_sou with
-  | Struct -> struct_to_entry id s
-  | Union -> union_to_entry id s
+  | Struct -> struct_to_entry sec id s
+  | Union -> union_to_entry sec id s
 
-let infotype_to_entry id = function
+let infotype_to_entry sec id = function
   | IntegerType i -> int_type_to_entry id i
   | FloatType f -> float_type_to_entry id f
   | PointerType p -> pointer_to_entry id p
   | ArrayType arr -> array_to_entry id arr
-  | CompositeType c -> composite_to_entry id c
-  | EnumType e -> enum_to_entry id e
+  | CompositeType c -> composite_to_entry sec id c
+  | EnumType e -> enum_to_entry sec id e
   | FunctionType f -> fun_type_to_entry id f
-  | Typedef t -> typedef_to_entry id t
+  | Typedef t -> typedef_to_entry sec id t
   | ConstType c -> const_to_entry id c
   | VolatileType v -> volatile_to_entry id v
   | Void -> void_to_entry id
@@ -246,7 +256,7 @@ let needs_types id d =
         let d,c' = add_type f.cfd_typ d in
         d,c||c') (d,false) c.ct_members
 
-let gen_types needed =
+let gen_types sec needed =
   let rec aux d =
     let d,c = IntSet.fold (fun id (d,c) ->
       let d,c' = needs_types id d in
@@ -258,13 +268,13 @@ let gen_types needed =
   let typs = aux needed in
   List.rev (Hashtbl.fold (fun id t acc -> 
     if IntSet.mem id typs then
-      (infotype_to_entry id t)::acc
+      (infotype_to_entry sec id t)::acc
     else 
       acc) types [])
 
-let global_variable_to_entry acc id v =
+let global_variable_to_entry sec acc id v =
   let var = {
-    variable_file_loc = v.gvar_file_loc;
+    variable_file_loc = translate_file_loc sec v.gvar_file_loc;
     variable_declaration = Some v.gvar_declaration;
     variable_external = Some v.gvar_external;
     variable_name = v.gvar_name;
@@ -338,10 +348,10 @@ let function_parameter_to_entry f_id (acc,bcc) p =
   } in
   new_entry (next_id ()) (DW_TAG_formal_parameter p),(IntSet.add p.formal_parameter_type acc,loc_list@bcc)
 
-let rec local_variable_to_entry f_id (acc,bcc) v id =
+let rec local_variable_to_entry sec f_id (acc,bcc) v id =
   let loc,loc_list = location_entry f_id (get_opt_val v.lvar_atom) in
   let var = {
-    variable_file_loc = v.lvar_file_loc;
+    variable_file_loc = translate_file_loc sec v.lvar_file_loc;
     variable_declaration = None;
     variable_external = None;
     variable_name = v.lvar_name;
@@ -350,7 +360,7 @@ let rec local_variable_to_entry f_id (acc,bcc) v id =
   } in
   new_entry id (DW_TAG_variable var),(IntSet.add v.lvar_type acc,loc_list@bcc)
 
-and scope_to_entry f_id acc sc id =
+and scope_to_entry sec f_id acc sc id =
   let l_pc,h_pc = try
     let r = Hashtbl.find scope_ranges id in
     let lbl l = match l with 
@@ -367,27 +377,27 @@ and scope_to_entry f_id acc sc id =
     lexical_block_high_pc = h_pc;
     lexical_block_low_pc = l_pc;
   } in
-  let vars,acc = mmap (local_to_entry f_id) acc sc.scope_variables in
+  let vars,acc = mmap (local_to_entry sec f_id) acc sc.scope_variables in
   let entry = new_entry id (DW_TAG_lexical_block scope) in
   add_children entry vars,acc
 
-and local_to_entry f_id acc id =
+and local_to_entry sec f_id acc id =
   match Hashtbl.find local_variables id with
-  | LocalVariable v -> local_variable_to_entry f_id acc v id
-  | Scope v -> scope_to_entry f_id acc v id
+  | LocalVariable v -> local_variable_to_entry sec f_id acc v id
+  | Scope v -> scope_to_entry sec f_id acc v id
 
-let fun_scope_to_entries f_id acc id =
+let fun_scope_to_entries sec f_id acc id =
   match id with
   | None -> [],acc
   | Some id ->
       let sc = Hashtbl.find local_variables id in
       (match sc with
-      | Scope sc ->mmap (local_to_entry f_id) acc sc.scope_variables
+      | Scope sc ->mmap (local_to_entry sec f_id) acc sc.scope_variables
       | _ -> assert false)
 
-let function_to_entry (acc,bcc) id f =
+let function_to_entry sec (acc,bcc) id f =
   let f_tag = {
-    subprogram_file_loc = f.fun_file_loc;
+    subprogram_file_loc = translate_file_loc sec f.fun_file_loc;
     subprogram_external = Some f.fun_external;
     subprogram_name = f.fun_name;
     subprogram_prototyped = true;
@@ -399,24 +409,36 @@ let function_to_entry (acc,bcc) id f =
   let acc = match f.fun_return_type with Some s -> IntSet.add s acc | None -> acc in
   let f_entry =  new_entry id (DW_TAG_subprogram f_tag) in
   let params,(acc,bcc) = mmap (function_parameter_to_entry f_id) (acc,bcc) f.fun_parameter in
-  let vars,(acc,bcc) = fun_scope_to_entries f_id (acc,bcc) f.fun_scope in
+  let vars,(acc,bcc) = fun_scope_to_entries sec f_id (acc,bcc) f.fun_scope in
   add_children f_entry (params@vars),(acc,bcc)
      
-let definition_to_entry (acc,bcc) id t =
+let definition_to_entry sec (acc,bcc) id t =
   match t with
-  | GlobalVariable g -> let e,acc = global_variable_to_entry acc id g in
+  | GlobalVariable g -> let e,acc = global_variable_to_entry sec acc id g in
     e,(acc,bcc)
-  | Function f -> function_to_entry (acc,bcc) id f
-
-let gen_defs () =
-  let defs,(typ,locs) = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in
-  t::acc,bcc) definitions ([],(IntSet.empty,[])) in
-  List.rev defs,typ,locs
-
-let gen_debug_info () : dw_entry * dw_locations=
-  let cp =  {
-    compile_unit_name = !file_name;
-  } in
-  let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
-  let defs,ty,locs = gen_defs () in
-  add_children cp ((gen_types ty) @ defs),locs
+  | Function f -> function_to_entry sec (acc,bcc) id f
+
+module StringMap = Map.Make(String)
+
+let gen_debug_info sec_name var_section : debug_entries =
+  let defs = Hashtbl.fold (fun id t acc ->
+    let s = match t with
+    | GlobalVariable _ -> var_section
+    | Function f -> sec_name (get_opt_val f.fun_atom) in
+    let old = try StringMap.find s acc with Not_found -> [] in
+    StringMap.add s ((id,t)::old) acc) definitions StringMap.empty in
+  StringMap.fold (fun s defs acc ->
+    let defs,(ty,locs) = List.fold_left (fun (acc,bcc) (id,t) -> 
+      let t,bcc = definition_to_entry s bcc id t in
+      t::acc,bcc) ([],(IntSet.empty,[])) defs in
+    let line_start,low_pc,debug_start,_ = Hashtbl.find compilation_section_start s
+    and high_pc = Hashtbl.find compilation_section_end s in
+    let cp = {
+      compile_unit_name = !file_name;
+      compile_unit_low_pc = low_pc;
+      compile_unit_high_pc = high_pc;
+      compile_unit_stmt_list = line_start; 
+    } in
+    let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
+    let cp = add_children cp ((gen_types s ty) @ defs) in
+    (s,debug_start,cp,(low_pc,locs))::acc) defs []