diff options
-rw-r--r-- | backend/PrintAsm.ml | 2 | ||||
-rw-r--r-- | backend/PrintAsm.mli | 4 | ||||
-rw-r--r-- | debug/CtoDwarf.ml | 168 | ||||
-rw-r--r-- | debug/DwarfPrinter.ml | 43 | ||||
-rw-r--r-- | debug/DwarfTypes.mli (renamed from debug/DwarfTypes.ml) | 9 | ||||
-rw-r--r-- | debug/DwarfUtil.ml | 7 | ||||
-rw-r--r-- | driver/Driver.ml | 5 |
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" |