Added function to convert C types into their dwarf represnation.

7 files changed, 208 insertions, 30 deletions

diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml
index a394cf8e..510dbc64 100644
--- a/backend/PrintAsm.ml
+++ b/backend/PrintAsm.ml
@@ -91,7 +91,7 @@ module Printer(Target:TARGET) =
             
   end
 
-let print_program oc p =
+let print_program oc p db =
   let module Target = (val (sel_target ()):TARGET) in
   let module Printer = Printer(Target) in
   PrintAnnot.reset_filenames ();
diff --git a/backend/PrintAsm.mli b/backend/PrintAsm.mli
index eb63f1be..0b2869b0 100644
--- a/backend/PrintAsm.mli
+++ b/backend/PrintAsm.mli
@@ -11,6 +11,4 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-open PrintAsmaux
-
-val print_program: out_channel -> Asm.program -> unit
+val print_program: out_channel -> Asm.program -> DwarfTypes.dw_entry option -> unit
diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml
index 0ee0842a..b7f417f6 100644
--- a/debug/CtoDwarf.ml
+++ b/debug/CtoDwarf.ml
@@ -10,9 +10,175 @@
 (*                                                                     *)
 (* *********************************************************************)
 
+open C
+open Cprint
+open DwarfTypes
+open DwarfUtil
+open Machine
+
 (* Functions to translate a C Ast into Dwarf 2 debugging information *)
 
 
-(* Hashtable to from type name to entry id *)
+(* Hashtable from type name to entry id *)
 let type_table: (string, int) Hashtbl.t = Hashtbl.create 7
 
+(* Hashtable from typedefname to entry id *)
+let defined_types_table: (string, int) Hashtbl.t = Hashtbl.create 7
+
+let typ_to_string (ty: typ) =
+  let buf = Buffer.create 7 in
+  let chan = Format.formatter_of_buffer buf in
+  typ chan ty;
+  Format.pp_print_flush chan ();
+  Buffer.contents buf
+
+let rec mmap f env = function
+  | [] -> ([],env)
+  | hd :: tl ->
+      let (hd',env1) = f env hd in
+      let (tl', env2) = mmap f env1 tl in
+      (hd' :: tl', env2)
+
+let rec type_to_dwarf (typ: typ): int * dw_entry list =
+  let typ_string = typ_to_string typ in
+  try
+    Hashtbl.find type_table typ_string,[]
+  with Not_found ->
+    let attr_to_dw attr_list id entries =
+      List.fold_left (fun (id,entry) attr ->
+        match attr with
+        | AConst -> let const_tag = DW_TAG_const_type ({const_type = id;}) in
+          let const_entry = new_entry const_tag in
+          const_entry.id,const_entry::entry
+        | AVolatile ->  let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in
+          let volatile_entry = new_entry volatile_tag in
+          volatile_entry.id,volatile_entry::entry
+        | ARestrict 
+        | AAlignas _
+        | Attr _ -> id,entry) (id,entries) (List.rev attr_list) in
+    let attr_to_dw_tag attr_list tag =
+      let entry = new_entry tag in
+      attr_to_dw attr_list entry.id [entry] in
+    let id,entries = 
+      match typ with
+      | TVoid at -> let void = {
+          base_type_byte_size = 0;
+          base_type_encoding = None;
+          base_type_name = "void";
+        } in
+        attr_to_dw_tag at (DW_TAG_base_type void)
+      | TInt (k,at) ->
+          let byte_size,encoding,name =
+            (match k with
+            | IBool -> 1,DW_ATE_boolean,"_Bool" 
+            | IChar -> 1,(if !config.char_signed then DW_ATE_signed_char else DW_ATE_unsigned_char),"char" 
+            | ISChar -> 1,DW_ATE_signed_char,"signed char"
+            | IUChar -> 1,DW_ATE_unsigned_char,"unsigned char"
+            | IInt -> !config.sizeof_int,DW_ATE_signed,"signed int"
+            | IUInt -> !config.sizeof_int,DW_ATE_unsigned,"unsigned int"
+            | IShort -> !config.sizeof_short,DW_ATE_signed,"signed short"
+            | IUShort -> !config.sizeof_short,DW_ATE_unsigned,"unsigned short"
+            | ILong -> !config.sizeof_long, DW_ATE_signed,"long"
+            | IULong -> !config.sizeof_long, DW_ATE_unsigned,"unsigned long"
+            | ILongLong -> !config.sizeof_longlong, DW_ATE_signed,"long long"
+            | IULongLong -> !config.sizeof_longlong, DW_ATE_unsigned,"unsigned long long")in
+          let int = {
+            base_type_byte_size = byte_size;
+            base_type_encoding = Some encoding;
+            base_type_name = name;} in
+          attr_to_dw_tag at (DW_TAG_base_type int)
+      | TFloat (k,at) ->
+          let byte_size,name =
+            (match k with
+            | FFloat -> !config.sizeof_float,"float"
+            | FDouble -> !config.sizeof_double,"double"
+            | FLongDouble -> !config.sizeof_longdouble,"long double") in
+          let float = {
+            base_type_byte_size = byte_size;
+            base_type_encoding = Some DW_ATE_float;
+            base_type_name = name;
+          } in
+          attr_to_dw_tag at (DW_TAG_base_type float)
+      | TPtr (t,at) ->
+          let t,e = type_to_dwarf t in
+          let pointer = {pointer_type = t;} in
+          let t,e2 = attr_to_dw_tag at (DW_TAG_pointer_type pointer) in
+          t,e2@e
+      | TFun (rt,args,_,at) ->
+          let ret,et = (match rt with
+          | TVoid _ -> None,[] (* Void return *)
+          | _ -> let ret,et = type_to_dwarf rt in
+            Some ret,et) in
+          let prototyped,children,others =
+            (match args with 
+            | None ->
+                let u = {
+                  unspecified_parameter_file_loc = None;
+                  unspecified_parameter_artificial = None;
+                } in
+                let u = new_entry (DW_TAG_unspecified_parameter u) in 
+                false,[u],[]
+            | Some [] -> true,[],[]
+            | Some l ->
+                let c,e = mmap (fun acc (_,t) ->
+                  let t,e = type_to_dwarf t in
+                  let fp =
+                    {
+                     formal_parameter_file_loc = None;
+                     formal_parameter_artificial = None;
+                     formal_parameter_location = None;
+                     formal_parameter_name = None;
+                     formal_parameter_segment = None;
+                     formal_parameter_type = t;
+                     formal_parameter_variable_parameter = None;
+                   } in
+                  let entry = new_entry (DW_TAG_formal_parameter fp) in
+                  entry,(e@acc)) [] l in
+                true,c,e) in
+          let s = {
+            subroutine_type = ret;
+            subroutine_prototyped = prototyped;
+          } in
+          let s = new_entry (DW_TAG_subroutine_type s) in
+          let s = add_children s children in
+          attr_to_dw at s.id ((s::others)@et)
+      | TStruct (i,at)
+      | TUnion (i,at)
+      | TEnum (i,at)
+      | TNamed (i,at) ->
+          let t = Hashtbl.find defined_types_table i.name in
+          attr_to_dw at t []
+      | TArray (child,size,at) ->
+          let size_to_subrange s =
+            let b = (match s with 
+            | None -> None
+            | Some i ->
+                let i = Int64.to_int i in
+                Some (BoundConst i)) in
+            let s = {
+              subrange_type = None;
+              subrange_upper_bound = b;
+            } in
+            new_entry (DW_TAG_subrange_type s) in 
+          let rec aux t = 
+            (match t with
+            | TArray (child,size,_) ->
+                let sub = size_to_subrange size in
+                let t,c,e = aux child in
+                t,sub::c,e
+            | _ -> let t,e = type_to_dwarf t in
+            t,[],e) in
+          let t,children,e = aux child in
+          let sub = size_to_subrange size in
+          let children = List.rev (sub::children) in
+          let arr = {
+            array_type_file_loc = None;
+            array_type = t;
+          } in
+          let arr = new_entry (DW_TAG_array_type arr) in
+          let arr = add_children arr children in
+          attr_to_dw at arr.id (arr::e)          
+    in
+    Hashtbl.add type_table typ_string id;
+    id,entries
+        
diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml
index 07d62998..0b175563 100644
--- a/debug/DwarfPrinter.ml
+++ b/debug/DwarfPrinter.ml
@@ -130,9 +130,9 @@ module DwarfPrinter(Target: TARGET) :
           prologue 0x1;
           add_attr_some e.array_type_file_loc add_file_loc;
           add_type buf
-      | DW_TAG_base_type _ ->
+      | DW_TAG_base_type b ->
           prologue 0x24;
-          add_encoding buf;
+          add_attr_some b.base_type_encoding add_encoding;
           add_byte_size buf;
           add_name buf
       | DW_TAG_compile_unit e ->
@@ -163,7 +163,7 @@ module DwarfPrinter(Target: TARGET) :
           add_attr_some e.formal_parameter_file_loc add_file_loc;
           add_attr_some e.formal_parameter_artificial add_artificial;
           add_location  e.formal_parameter_location buf;
-          add_name buf;
+          add_attr_some e.formal_parameter_name add_name;
           add_location e.formal_parameter_segment buf;
           add_type buf;
           add_attr_some e.formal_parameter_variable_parameter add_variable_parameter
@@ -206,9 +206,12 @@ module DwarfPrinter(Target: TARGET) :
       | DW_TAG_subrange_type e ->
           prologue 0x21;
           add_attr_some e.subrange_type add_type;
-          add_bound_value e.subrange_upper_bound buf
-      | DW_TAG_subroutine_type _ ->
+          (match e.subrange_upper_bound  with 
+          | None -> ()
+          | Some b -> add_bound_value b buf)
+      | DW_TAG_subroutine_type e ->
           prologue 0x15;
+          add_attr_some e.subroutine_type add_type;
           add_prototyped buf
       | DW_TAG_typedef e ->
           prologue 0x16;
@@ -337,17 +340,20 @@ module DwarfPrinter(Target: TARGET) :
 
     let print_base_type oc bt =
       print_byte oc bt.base_type_byte_size;
-      let encoding = match bt.base_type_encoding with
-      | DW_ATE_address -> 0x1
-      | DW_ATE_boolean -> 0x2
-      | DW_ATE_complex_float -> 0x3
-      | DW_ATE_float -> 0x4
-      | DW_ATE_signed -> 0x5
-      | DW_ATE_signed_char -> 0x6
-      | DW_ATE_unsigned -> 0x7
-      | DW_ATE_unsigned_char -> 0x8
-      in
-      print_byte oc encoding;
+      match bt.base_type_encoding with 
+      | Some e ->
+          let encoding = match e with
+          | DW_ATE_address -> 0x1
+          | DW_ATE_boolean -> 0x2
+          | DW_ATE_complex_float -> 0x3
+          | DW_ATE_float -> 0x4
+          | DW_ATE_signed -> 0x5
+          | DW_ATE_signed_char -> 0x6
+          | DW_ATE_unsigned -> 0x7
+          | DW_ATE_unsigned_char -> 0x8
+          in
+          print_byte oc encoding;
+      | None -> ();
       print_string oc bt.base_type_name
 
     let print_compilation_unit oc tag =
@@ -377,7 +383,7 @@ module DwarfPrinter(Target: TARGET) :
       print_file_loc oc fp.formal_parameter_file_loc;
       print_opt_value oc fp.formal_parameter_artificial print_flag;
       print_opt_value oc fp.formal_parameter_location print_loc;
-      print_string oc fp.formal_parameter_name;
+      print_opt_value oc fp.formal_parameter_name print_string;
       print_opt_value oc fp.formal_parameter_segment print_loc;
       print_ref oc fp.formal_parameter_type;
       print_opt_value oc fp.formal_parameter_variable_parameter print_flag
@@ -421,9 +427,10 @@ module DwarfPrinter(Target: TARGET) :
 
     let print_subrange oc sr =
       print_opt_value oc sr.subrange_type print_ref;
-      print_bound_value oc sr.subrange_upper_bound
+      print_opt_value oc sr.subrange_upper_bound print_bound_value
 
     let print_subroutine oc st =
+      print_opt_value oc st.subroutine_type print_ref;
       print_flag oc st.subroutine_prototyped
 
     let print_typedef oc td =
diff --git a/debug/DwarfTypes.ml b/debug/DwarfTypes.mli
index 268711b3..4f434c4d 100644
--- a/debug/DwarfTypes.ml
+++ b/debug/DwarfTypes.mli
@@ -59,7 +59,7 @@ type dw_tag_array_type =
 type dw_tag_base_type =
     {
      base_type_byte_size: constant;
-     base_type_encoding:  encoding;
+     base_type_encoding:  encoding option;
      base_type_name:      string;
    }
 
@@ -93,7 +93,7 @@ type dw_tag_formal_parameter =
      formal_parameter_file_loc:           file_loc       option;
      formal_parameter_artificial:         flag           option;
      formal_parameter_location:           location_value option;
-     formal_parameter_name:               string;
+     formal_parameter_name:               string         option;
      formal_parameter_segment:            location_value option;
      formal_parameter_type:               reference;
      formal_parameter_variable_parameter: flag           option;
@@ -150,12 +150,13 @@ type dw_tag_subprogram =
 
 type dw_tag_subrange_type =
     {
-     subrange_type:        reference option;
-     subrange_upper_bound: bound_value;
+     subrange_type:        reference   option;
+     subrange_upper_bound: bound_value option;
    }
 
 type dw_tag_subroutine_type =
     {
+     subroutine_type:       reference option;
      subroutine_prototyped: flag;
    }
 
diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml
index 764194a6..91ef94a8 100644
--- a/debug/DwarfUtil.ml
+++ b/debug/DwarfUtil.ml
@@ -33,10 +33,15 @@ let new_entry tag =
  }
 
 (* Add an entry as child to  another entry *)
-let add_children entry child =
+let add_child entry child =
   {entry with children = child::entry.children;}
 
 
+(* Add entries as children to  another entry *)
+let add_children entry children =
+  {entry with children = entry.children@children;}
+
+
 let list_iter_with_next f list =
   let rec aux = (function
     | [] -> ()
diff --git a/driver/Driver.ml b/driver/Driver.ml
index d8b28285..f14b2671 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -15,6 +15,7 @@ open Commandline
 open Camlcoq
 open Clflags
 open Timing
+open CtoDwarf
 
 (* Location of the compatibility library *)
 
@@ -181,7 +182,7 @@ let compile_c_ast sourcename csyntax ofile =
     dump_asm asm (output_filename sourcename ".c" ".sdump");
   (* Print Asm in text form *)
   let oc = open_out ofile in
-  PrintAsm.print_program oc asm;
+  PrintAsm.print_program oc asm None;
   close_out oc
 
 (* From C source to asm *)
@@ -212,7 +213,7 @@ let compile_cminor_file ifile ofile =
         exit 2
     | Errors.OK p ->
         let oc = open_out ofile in
-        PrintAsm.print_program oc p;
+        PrintAsm.print_program oc p None;
         close_out oc
   with Parsing.Parse_error ->
          eprintf "File %s, character %d: Syntax error\n"