From 8d2e4a51d56b7f4d3673a5132edd1adb37a14295 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 21 Aug 2015 15:21:36 +0200 Subject: Added symbol functions for printing of the location for global variables. --- arm/TargetPrinter.ml | 6 ++++++ backend/PrintAsm.ml | 8 ++++++-- backend/PrintAsmaux.ml | 3 +++ cfrontend/C2C.ml | 10 ++++++++-- debug/CtoDwarf.ml | 13 +++++-------- debug/DwarfPrinter.ml | 20 ++++++++++---------- debug/DwarfTypes.mli | 15 +++++++++------ ia32/TargetPrinter.ml | 6 ++++++ lib/Camlcoq.ml | 7 +++++++ powerpc/TargetPrinter.ml | 9 +++++++++ 10 files changed, 69 insertions(+), 28 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index f8d72836..33071a9a 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -923,6 +923,12 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = let new_label = new_label let print_file_loc _ _ = () (* Dummy function *) + + let get_location _ = None (* Dummy function *) + + let get_segment_location _ = None (* Dummy function *) + + let add_var_location _ = () (* Dummy function *) end let sel_target () = diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index f3c80f3e..29409b32 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -78,6 +78,7 @@ module Printer(Target:TARGET) = List.iter (Target.print_init oc) id let print_var oc name v = + if !Clflags.option_g && Configuration.advanced_debug then Target.add_var_location name; match v.gvar_init with | [] -> () | _ -> @@ -102,8 +103,7 @@ module Printer(Target:TARGET) = let sz = match v.gvar_init with [Init_space sz] -> sz | _ -> assert false in Target.print_comm_symb oc sz name align - - + let print_globdef oc (name,gdef) = match gdef with | Gfun (Internal code) -> print_function oc name code @@ -120,6 +120,10 @@ module Printer(Target:TARGET) = let get_stmt_list_addr = Target.get_stmt_list_addr let name_of_section = Target.name_of_section let get_fun_addr s = try Some (Hashtbl.find addr_mapping s) with Not_found -> None + let get_location a = try (Target.get_location (stamp_atom a)) with Not_found -> None + let get_segment_location a = try (Target.get_segment_location (stamp_atom a)) with Not_found -> None + let get_frame_base a = None + let symbol = Target.symbol end module DebugPrinter = DwarfPrinter (DwarfTarget) (Target.DwarfAbbrevs) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index b54188ca..efc8030f 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -51,6 +51,9 @@ module type TARGET = val new_label: unit -> int val label: out_channel -> int -> unit val print_file_loc: out_channel -> file_loc -> unit + val get_location: P.t -> location_value option + val get_segment_location: P.t -> location_value option + val add_var_location: P.t -> unit module DwarfAbbrevs: DWARF_ABBREVS end diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index b919c1d4..f1c8ec8e 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1038,7 +1038,9 @@ let convertFundef loc env fd = let params = List.map (fun (id, ty) -> - (intern_string id.name, convertTyp env ty)) + let id' = intern_string id.name in + add_stamp id.stamp id'; + (id', convertTyp env ty)) fd.fd_params in let vars = List.map @@ -1047,7 +1049,9 @@ let convertFundef loc env fd = unsupported "'static' or 'extern' local variable"; if init <> None then unsupported "initialized local variable"; - (intern_string id.name, convertTyp env ty)) + let id' = intern_string id.name in + add_stamp id.stamp id'; + (id', convertTyp env ty)) fd.fd_locals in let body' = convertStmt loc env fd.fd_body in let id' = intern_string fd.fd_name.name in @@ -1075,6 +1079,7 @@ let convertFundecl env (sto, id, ty, optinit) = | Tfunction(args, res, cconv) -> (args, res, cconv) | _ -> assert false in let id' = intern_string id.name in + add_stamp id.stamp id'; let sg = signature_of_type args res cconv in let ef = if id.name = "malloc" then EF_malloc else @@ -1116,6 +1121,7 @@ let convertInitializer env ty i = let convertGlobvar loc env (sto, id, ty, optinit) = let id' = intern_string id.name in + add_stamp id.stamp id'; let ty' = convertTyp env ty in let sz = Ctypes.sizeof !comp_env ty' in let al = Ctypes.alignof !comp_env ty' in diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 99b77e6f..ee594d9e 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -164,15 +164,14 @@ and fun_to_dwarf_tag rt args = false,[u],[] | Some [] -> true,[],[] | Some l -> - let c,e = mmap (fun acc (_,t) -> + let c,e = mmap (fun acc (i,t) -> let t,e = type_to_dwarf t in let fp = { + formal_parameter_id = i.stamp; 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 @@ -301,12 +300,11 @@ let glob_var_to_dwarf (s,n,t,_) gloc = | Storage_static -> false | _ -> true) in let decl = { + variable_id = n.stamp; variable_file_loc = (Some gloc); variable_declaration = Some at_decl; variable_external = Some ext; - variable_location = if ext then Some (LocSymbol n.name) else None; variable_name = n.name; - variable_segment = None; variable_type = i; } in let decl = new_entry (DW_TAG_variable decl) in @@ -322,9 +320,9 @@ let fundef_to_dwarf f gloc = | Storage_static -> false | _ -> true) in let fdef = { + subprogram_id = f.fd_name.stamp; subprogram_file_loc = (Some gloc); subprogram_external = Some ext; - subprogram_frame_base = None; subprogram_name = f.fd_name.name; subprogram_prototyped = true; subprogram_type = ret; @@ -333,11 +331,10 @@ let fundef_to_dwarf f gloc = let t,e = type_to_dwarf t in let fp = { + formal_parameter_id = p.stamp; formal_parameter_file_loc = None; formal_parameter_artificial = None; - formal_parameter_location = None; formal_parameter_name = (Some p.name); - formal_parameter_segment = None; formal_parameter_type = t; formal_parameter_variable_parameter = None; } in diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 70b68634..85efea6e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -128,9 +128,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0x34; add_attr_some e.formal_parameter_file_loc add_file_loc; add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); - add_location e.formal_parameter_location buf; + add_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; - add_location e.formal_parameter_segment buf; + add_location (get_segment_location e.formal_parameter_id) buf; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) | DW_TAG_label _ -> @@ -203,9 +203,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.variable_file_loc add_file_loc; add_attr_some e.variable_declaration add_declaration; add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); - add_location e.variable_location buf; + add_location (get_location e.variable_id) buf; add_name buf; - add_location e.variable_segment buf; + add_location (get_segment_location e.variable_id) buf; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -299,7 +299,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | LocSymbol s -> fprintf oc " .sleb128 5\n"; fprintf oc " .byte 3\n"; - fprintf oc " .4byte %s\n" s + fprintf oc " .4byte %a\n" symbol s | _ -> () let print_data_location oc dl = @@ -365,9 +365,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_formal_parameter oc fp = 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_opt_value oc (get_location fp.formal_parameter_id) print_loc; print_opt_value oc fp.formal_parameter_name print_string; - print_opt_value oc fp.formal_parameter_segment print_loc; + print_opt_value oc (get_segment_location fp.formal_parameter_id) print_loc; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -406,7 +406,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let addr = get_fun_addr sp.subprogram_name in print_file_loc oc sp.subprogram_file_loc; print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc sp.subprogram_frame_base print_loc; + print_opt_value oc (get_frame_base sp.subprogram_id) print_loc; print_opt_value oc addr print_subprogram_addr; print_string oc sp.subprogram_name; print_flag oc sp.subprogram_prototyped; @@ -439,9 +439,9 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_file_loc oc var.variable_file_loc; print_opt_value oc var.variable_declaration print_flag; print_opt_value oc var.variable_external print_flag; - print_opt_value oc var.variable_location print_loc; + print_opt_value oc (get_location var.variable_id) print_loc; print_string oc var.variable_name; - print_opt_value oc var.variable_segment print_loc; + print_opt_value oc (get_segment_location var.variable_id) print_loc; print_ref oc var.variable_type let print_volatile_type oc vt = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 4852e550..174f2403 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -13,6 +13,7 @@ (* Types used for writing dwarf debug information *) open Sections +open Camlcoq (* Basic types for the value of attributes *) @@ -37,7 +38,7 @@ type address = int type block = string type location_value = - | LocSymbol of string + | LocSymbol of atom | LocConst of constant | LocBlock of block @@ -93,11 +94,10 @@ type dw_tag_enumerator = type dw_tag_formal_parameter = { + formal_parameter_id: int; formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; - formal_parameter_location: location_value option; formal_parameter_name: string option; - formal_parameter_segment: location_value option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; } @@ -141,9 +141,9 @@ type dw_tag_structure_type = type dw_tag_subprogram = { + subprogram_id: int; subprogram_file_loc: file_loc option; subprogram_external: flag option; - subprogram_frame_base: location_value option; subprogram_name: string; subprogram_prototyped: flag; subprogram_type: reference option; @@ -184,12 +184,11 @@ type dw_tag_unspecified_parameter = type dw_tag_variable = { + variable_id: int; variable_file_loc: file_loc option; variable_declaration: flag option; variable_external: flag option; - variable_location: location_value option; variable_name: string; - variable_segment: location_value option; variable_type: reference; } @@ -270,4 +269,8 @@ module type DWARF_TARGET= val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string val get_fun_addr: string -> (int * int) option + val get_location: int -> location_value option + val get_segment_location: int -> location_value option + val get_frame_base: int -> location_value option + val symbol: out_channel -> atom -> unit end diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 18aacebf..daeda188 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -790,6 +790,12 @@ module Target(System: SYSTEM):TARGET = let new_label = new_label let print_file_loc _ _ = () (* Dummy function *) + + let get_location _ = None (* Dummy function *) + + let get_segment_location _ = None (* Dummy function *) + + let add_var_location _ = () (* Dummy function *) end diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index 68c095f0..5eb52e88 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -284,6 +284,7 @@ let coqint_of_camlint64 : int64 -> Integers.Int64.int = Z.of_uint64 type atom = positive let atom_of_string = (Hashtbl.create 17 : (string, atom) Hashtbl.t) +let atom_of_stamp = (Hashtbl.create 17: (int, atom) Hashtbl.t) let string_of_atom = (Hashtbl.create 17 : (atom, string) Hashtbl.t) let next_atom = ref Coq_xH @@ -297,6 +298,12 @@ let intern_string s = Hashtbl.add string_of_atom a s; a +let add_stamp s a = + Hashtbl.add atom_of_stamp s a + +let stamp_atom s = + Hashtbl.find atom_of_stamp s + let extern_atom a = try Hashtbl.find string_of_atom a diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 8610f750..1e78f038 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -854,7 +854,16 @@ module Target (System : SYSTEM):TARGET = let section oc sec = section oc sec; debug_section oc sec + + let locations = (Hashtbl.create 17 : (atom,DwarfTypes.location_value) Hashtbl.t) + let get_location a = try Some (Hashtbl.find locations a) with Not_found -> None + + let get_segment_location _ = None + + let add_var_location a = + if !Clflags.option_g && Configuration.advanced_debug then + Hashtbl.add locations a (DwarfTypes.LocSymbol a); end let sel_target () = -- cgit From 108db39b8b7c1d42cbc38c5aabf885ef5440f189 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 26 Aug 2015 14:28:22 +0200 Subject: Added the abbreviation for symbol constants. --- debug/DwarfPrinter.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index cd888a80..c85a9efc 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -72,6 +72,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_location loc buf = match loc with | None -> () + | Some (LocSymbol _) ->add_abbr_entry (0x2,location_block_type_abbr) buf | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf -- cgit From 861292a6c5e58b4f78bef207c717b801b3fc1fed Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 6 Sep 2015 20:32:55 +0200 Subject: Startet implementation of new Debug interface. Added a new file debug/Debug.ml which will be the interface between for generating and printing the debuging information. Currently it contains only the code for the line directived. --- arm/TargetPrinter.ml | 1 + backend/PrintAsm.ml | 4 +-- backend/PrintAsmaux.ml | 71 --------------------------------------- debug/CtoDwarf.ml | 2 +- debug/Debug.ml | 86 ++++++++++++++++++++++++++++++++++++++++++++++++ debug/DwarfPrinter.mli | 1 + ia32/TargetPrinter.ml | 1 + powerpc/TargetPrinter.ml | 5 +-- 8 files changed, 95 insertions(+), 76 deletions(-) create mode 100644 debug/Debug.ml diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 028ff6ed..d0e07958 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -20,6 +20,7 @@ open AST open Memdata open Asm open PrintAsmaux +open Debug (* Type for the ABI versions *) type float_abi_type = diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 29409b32..b88a3d50 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -134,12 +134,12 @@ module Printer(Target:TARGET) = let print_program oc p db = let module Target = (val (sel_target ()):TARGET) in let module Printer = Printer(Target) in - reset_filenames (); + Debug.reset_filenames (); print_version_and_options oc Target.comment; Target.print_prologue oc; List.iter (Printer.print_globdef oc) p.prog_defs; Target.print_epilogue oc; - close_filenames (); + Debug.close_filenames (); if !Clflags.option_g && Configuration.advanced_debug then begin match db with diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 324e7e66..441f8251 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -142,77 +142,6 @@ let cfi_rel_offset = let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) -(* Printing annotations in asm syntax *) -(** All files used in the debug entries *) -module StringSet = Set.Make(String) -let all_files : StringSet.t ref = ref StringSet.empty -let add_file file = - all_files := StringSet.add file !all_files - - -let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t - = Hashtbl.create 7 - -let last_file = ref "" - -let reset_filenames () = - Hashtbl.clear filename_info; last_file := "" - -let close_filenames () = - Hashtbl.iter - (fun file (num, fb) -> - match fb with Some b -> Printlines.close b | None -> ()) - filename_info; - reset_filenames() - -let enter_filename f = - let num = Hashtbl.length filename_info + 1 in - let filebuf = - if !Clflags.option_S || !Clflags.option_dasm then begin - try Some (Printlines.openfile f) - with Sys_error _ -> None - end else None in - Hashtbl.add filename_info f (num, filebuf); - (num, filebuf) - -(* Add file and line debug location, using GNU assembler-style DWARF2 - directives *) - -let print_file_line oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (filenum, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - let (filenum, filebuf as res) = enter_filename file in - fprintf oc " .file %d %S\n" filenum file; - res in - fprintf oc " .loc %d %d\n" filenum line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - -(* Add file and line debug location, using DWARF2 directives in the style - of Diab C 5 *) - -let print_file_line_d2 oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (_, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - enter_filename file in - if file <> !last_file then begin - fprintf oc " .d2file %S\n" file; - last_file := file - end; - fprintf oc " .d2line %d\n" line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - (** Programmer-supplied annotations (__builtin_annot). *) let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 063b0823..e37c6043 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -477,7 +477,7 @@ let union_to_dwarf (n,at,m) env gloc = (* Translate global declarations to there dwarf representation *) let globdecl_to_dwarf env (typs,decls) decl = - PrintAsmaux.add_file (fst decl.gloc); + Debug.add_file (fst decl.gloc); match decl.gdesc with | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in typs@ret,decls diff --git a/debug/Debug.ml b/debug/Debug.ml new file mode 100644 index 00000000..dfe7fd94 --- /dev/null +++ b/debug/Debug.ml @@ -0,0 +1,86 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Printf + +(* Printing annotations in asm syntax *) +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files + + +let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t + = Hashtbl.create 7 + +let last_file = ref "" + +let reset_filenames () = + Hashtbl.clear filename_info; last_file := "" + +let close_filenames () = + Hashtbl.iter + (fun file (num, fb) -> + match fb with Some b -> Printlines.close b | None -> ()) + filename_info; + reset_filenames() + +let enter_filename f = + let num = Hashtbl.length filename_info + 1 in + let filebuf = + if !Clflags.option_S || !Clflags.option_dasm then begin + try Some (Printlines.openfile f) + with Sys_error _ -> None + end else None in + Hashtbl.add filename_info f (num, filebuf); + (num, filebuf) + + +(* Add file and line debug location, using GNU assembler-style DWARF2 + directives *) + +let print_file_line oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (filenum, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + let (filenum, filebuf as res) = enter_filename file in + fprintf oc " .file %d %S\n" filenum file; + res in + fprintf oc " .loc %d %d\n" filenum line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end + +(* Add file and line debug location, using DWARF2 directives in the style + of Diab C 5 *) + +let print_file_line_d2 oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (_, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + enter_filename file in + if file <> !last_file then begin + fprintf oc " .d2file %S\n" file; + last_file := file + end; + fprintf oc " .d2line %d\n" line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 9e0e6693..ccdecffb 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -1,3 +1,4 @@ + (* *********************************************************************) (* *) (* The Compcert verified compiler *) diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index d1e213e2..9227929b 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -20,6 +20,7 @@ open AST open Memdata open Asm open PrintAsmaux +open Debug module StringSet = Set.Make(String) diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 409f2cc0..5159850d 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -21,6 +21,7 @@ open AST open Memdata open Asm open PrintAsmaux +open Debug (* Recognition of target ABI and asm syntax *) @@ -139,7 +140,7 @@ module Linux_System : SYSTEM = let print_file_line oc file line = - print_file_line oc comment file line + Debug.print_file_line oc comment file line (* Emit .cfi directives *) let cfi_startproc = cfi_startproc @@ -217,7 +218,7 @@ module Diab_System : SYSTEM = let print_file_line oc file line = - print_file_line_d2 oc comment file line + Debug.print_file_line_d2 oc comment file line (* Emit .cfi directives *) let cfi_startproc oc = () -- cgit From cc6ce2bf9b8be54375ea3285ea2fa658bc108df0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 10 Sep 2015 13:42:43 +0200 Subject: Revert "Startet implementation of new Debug interface." This reverts commit 861292a6c5e58b4f78bef207c717b801b3fc1fed. --- arm/TargetPrinter.ml | 1 - backend/PrintAsm.ml | 4 +-- backend/PrintAsmaux.ml | 71 +++++++++++++++++++++++++++++++++++++++ debug/CtoDwarf.ml | 2 +- debug/Debug.ml | 86 ------------------------------------------------ debug/DwarfPrinter.mli | 1 - ia32/TargetPrinter.ml | 1 - powerpc/TargetPrinter.ml | 5 ++- 8 files changed, 76 insertions(+), 95 deletions(-) delete mode 100644 debug/Debug.ml diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index d0e07958..028ff6ed 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -20,7 +20,6 @@ open AST open Memdata open Asm open PrintAsmaux -open Debug (* Type for the ABI versions *) type float_abi_type = diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index b88a3d50..29409b32 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -134,12 +134,12 @@ module Printer(Target:TARGET) = let print_program oc p db = let module Target = (val (sel_target ()):TARGET) in let module Printer = Printer(Target) in - Debug.reset_filenames (); + reset_filenames (); print_version_and_options oc Target.comment; Target.print_prologue oc; List.iter (Printer.print_globdef oc) p.prog_defs; Target.print_epilogue oc; - Debug.close_filenames (); + close_filenames (); if !Clflags.option_g && Configuration.advanced_debug then begin match db with diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 441f8251..324e7e66 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -142,6 +142,77 @@ let cfi_rel_offset = let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) +(* Printing annotations in asm syntax *) +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files + + +let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t + = Hashtbl.create 7 + +let last_file = ref "" + +let reset_filenames () = + Hashtbl.clear filename_info; last_file := "" + +let close_filenames () = + Hashtbl.iter + (fun file (num, fb) -> + match fb with Some b -> Printlines.close b | None -> ()) + filename_info; + reset_filenames() + +let enter_filename f = + let num = Hashtbl.length filename_info + 1 in + let filebuf = + if !Clflags.option_S || !Clflags.option_dasm then begin + try Some (Printlines.openfile f) + with Sys_error _ -> None + end else None in + Hashtbl.add filename_info f (num, filebuf); + (num, filebuf) + +(* Add file and line debug location, using GNU assembler-style DWARF2 + directives *) + +let print_file_line oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (filenum, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + let (filenum, filebuf as res) = enter_filename file in + fprintf oc " .file %d %S\n" filenum file; + res in + fprintf oc " .loc %d %d\n" filenum line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end + +(* Add file and line debug location, using DWARF2 directives in the style + of Diab C 5 *) + +let print_file_line_d2 oc pref file line = + if !Clflags.option_g && file <> "" then begin + let (_, filebuf) = + try + Hashtbl.find filename_info file + with Not_found -> + enter_filename file in + if file <> !last_file then begin + fprintf oc " .d2file %S\n" file; + last_file := file + end; + fprintf oc " .d2line %d\n" line; + match filebuf with + | None -> () + | Some fb -> Printlines.copy oc pref fb line line + end + (** Programmer-supplied annotations (__builtin_annot). *) let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index e37c6043..063b0823 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -477,7 +477,7 @@ let union_to_dwarf (n,at,m) env gloc = (* Translate global declarations to there dwarf representation *) let globdecl_to_dwarf env (typs,decls) decl = - Debug.add_file (fst decl.gloc); + PrintAsmaux.add_file (fst decl.gloc); match decl.gdesc with | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in typs@ret,decls diff --git a/debug/Debug.ml b/debug/Debug.ml deleted file mode 100644 index dfe7fd94..00000000 --- a/debug/Debug.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Printf - -(* Printing annotations in asm syntax *) -(** All files used in the debug entries *) -module StringSet = Set.Make(String) -let all_files : StringSet.t ref = ref StringSet.empty -let add_file file = - all_files := StringSet.add file !all_files - - -let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t - = Hashtbl.create 7 - -let last_file = ref "" - -let reset_filenames () = - Hashtbl.clear filename_info; last_file := "" - -let close_filenames () = - Hashtbl.iter - (fun file (num, fb) -> - match fb with Some b -> Printlines.close b | None -> ()) - filename_info; - reset_filenames() - -let enter_filename f = - let num = Hashtbl.length filename_info + 1 in - let filebuf = - if !Clflags.option_S || !Clflags.option_dasm then begin - try Some (Printlines.openfile f) - with Sys_error _ -> None - end else None in - Hashtbl.add filename_info f (num, filebuf); - (num, filebuf) - - -(* Add file and line debug location, using GNU assembler-style DWARF2 - directives *) - -let print_file_line oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (filenum, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - let (filenum, filebuf as res) = enter_filename file in - fprintf oc " .file %d %S\n" filenum file; - res in - fprintf oc " .loc %d %d\n" filenum line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end - -(* Add file and line debug location, using DWARF2 directives in the style - of Diab C 5 *) - -let print_file_line_d2 oc pref file line = - if !Clflags.option_g && file <> "" then begin - let (_, filebuf) = - try - Hashtbl.find filename_info file - with Not_found -> - enter_filename file in - if file <> !last_file then begin - fprintf oc " .d2file %S\n" file; - last_file := file - end; - fprintf oc " .d2line %d\n" line; - match filebuf with - | None -> () - | Some fb -> Printlines.copy oc pref fb line line - end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index ccdecffb..9e0e6693 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -1,4 +1,3 @@ - (* *********************************************************************) (* *) (* The Compcert verified compiler *) diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 9227929b..d1e213e2 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -20,7 +20,6 @@ open AST open Memdata open Asm open PrintAsmaux -open Debug module StringSet = Set.Make(String) diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 5159850d..409f2cc0 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -21,7 +21,6 @@ open AST open Memdata open Asm open PrintAsmaux -open Debug (* Recognition of target ABI and asm syntax *) @@ -140,7 +139,7 @@ module Linux_System : SYSTEM = let print_file_line oc file line = - Debug.print_file_line oc comment file line + print_file_line oc comment file line (* Emit .cfi directives *) let cfi_startproc = cfi_startproc @@ -218,7 +217,7 @@ module Diab_System : SYSTEM = let print_file_line oc file line = - Debug.print_file_line_d2 oc comment file line + print_file_line_d2 oc comment file line (* Emit .cfi directives *) let cfi_startproc oc = () -- cgit From ed50169fa51b8a9cfdbf65380348f6a02909d9d7 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 11 Sep 2015 10:43:30 +0200 Subject: Started implementing the types needed for storing the debug information. --- debug/CtoDwarf.ml | 2 +- debug/DebugInformation.ml | 109 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 110 insertions(+), 1 deletion(-) create mode 100644 debug/DebugInformation.ml diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index 063b0823..f1e2aea6 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -19,7 +19,7 @@ open DwarfTypes open DwarfUtil open Env open Set - +open DebugInformation (* Functions to translate a C Ast into Dwarf 2 debugging information *) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml new file mode 100644 index 00000000..be47f2a7 --- /dev/null +++ b/debug/DebugInformation.ml @@ -0,0 +1,109 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C + +(* This implements an interface for the collection of debugging + information. *) + +(* Types for the information of type info *) +type composite_field = + { + cfd_name: string; + cfd_typ: int; + cfd_bit_size: int option; + cfd_bit_offset: int option; + cfd_byte_offset: int option; + cfd_byte_size: int option; + } + +type composite_type = + { + ct_name: string; + ct_file_loc: location option; + ct_members: composite_field list; + ct_alignof: int option; + ct_sizeof: int option; + } + +type ptr_type = { + pts: int + } + +type array_type = { + arr_type: int; + arr_size: int64 option; + } + +type typedef = { + typedef_name: string; + typ: int; + } + +type enumerator = { + enumerator_file_loc: location option; + enumerator_name: string; + enumerator_const: int; + } + +type emum_type = { + enum_name: string; + enum_byte_size: int option; + enum_file_loc: location option; + enum_enumerators: enumerator list; + } + +type int_type = { + int_kind: ikind; + } + +type float_type = { + float_kind: fkind; + } + +type parameter_type = { + param_type: int; + param_name: string; + } + +type function_type = { + fun_return_type: int; + fun_prototyped: int; + fun_params: parameter_type list; + } + +type debug_types = + | IntegerType of int_type + | FloatType of float_type + | PointerType of ptr_type + | ArrayType of array_type + | StructType of composite_type + | UnionType of composite_type + | FunctionType of function_type + | Typedef of typedef + +(* All types encountered *) +let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 + +(* The basetypes, pointer, typedefs and enums all must have names *) +let name_types: (string,int) Hashtbl.t = Hashtbl.create 7 + +(* Composite types do not need to have a name. We thereore use the stamp for the mapping *) +let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7 + +(* Translate a C.typ to a string needed for hashing *) +let typ_to_string (ty: typ) = + let buf = Buffer.create 7 in + let chan = Format.formatter_of_buffer buf in + Cprint.typ chan ty; + Format.pp_print_flush chan (); + Buffer.contents buf -- cgit From 2b5940c2256384f837bcdfc2ddb4783f1b377dbf Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 11 Sep 2015 14:42:40 +0200 Subject: Started implementing the typ insert methods. In contrast to CtoDwarf this time we use the name to identify everything. To make this work we print the full identifier with stamp to avoid the problems with anonymous structs and unions. --- debug/CtoDwarf.ml | 45 -------------------- debug/DebugInformation.ml | 104 +++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 99 insertions(+), 50 deletions(-) diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index f1e2aea6..dce8d81e 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -65,51 +65,6 @@ let rec mmap f env = function (hd' :: tl', env2) -(* Helper functions for the attributes *) - -let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in - match typ with - | TVoid at -> TVoid (strip at) - | TInt (k,at) -> TInt (k,strip at) - | TFloat (k,at) -> TFloat(k,strip at) - | TPtr (t,at) -> TPtr(t,strip at) - | TArray (t,s,at) -> TArray(t,s,strip at) - | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) - | TNamed (n,at) -> TNamed(n,strip at) - | TStruct (n,at) -> TStruct(n,strip at) - | TUnion (n,at) -> TUnion(n,strip at) - | TEnum (n,at) -> TEnum(n,strip at) - - -let strip_last_attribute typ = - let rec hd_opt l = match l with - [] -> None,[] - | AConst::rest -> Some AConst,rest - | AVolatile::rest -> Some AVolatile,rest - | _::rest -> hd_opt rest in - match typ with - | TVoid at -> let l,r = hd_opt at in - l,TVoid r - | TInt (k,at) -> let l,r = hd_opt at in - l,TInt (k,r) - | TFloat (k,at) -> let l,r = hd_opt at in - l,TFloat (k,r) - | TPtr (t,at) -> let l,r = hd_opt at in - l,TPtr(t,r) - | TArray (t,s,at) -> let l,r = hd_opt at in - l,TArray(t,s,r) - | TFun (t,arg,v,at) -> let l,r = hd_opt at in - l,TFun(t,arg,v,r) - | TNamed (n,at) -> let l,r = hd_opt at in - l,TNamed(n,r) - | TStruct (n,at) -> let l,r = hd_opt at in - l,TStruct(n,r) - | TUnion (n,at) -> let l,r = hd_opt at in - l,TUnion(n,r) - | TEnum (n,at) -> let l,r = hd_opt at in - l,TEnum(n,r) - (* Dwarf tag for the void type*) let rec void_dwarf_tag = let void = { diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index be47f2a7..e84172e6 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -15,6 +15,17 @@ open C (* This implements an interface for the collection of debugging information. *) +(* Simple id generator *) +let id = ref 0 + +let next_id () = + let nid = !id in + incr id; nid + +let reset_id () = + id := 0 + + (* Types for the information of type info *) type composite_field = { @@ -39,6 +50,15 @@ type ptr_type = { pts: int } +type const_type = { + const_type: int + } + +type volatile_type = { + volatile_type: int + } + + type array_type = { arr_type: int; arr_size: int64 option; @@ -90,20 +110,94 @@ type debug_types = | UnionType of composite_type | FunctionType of function_type | Typedef of typedef + | ConstType of const_type + | VolatileType of volatile_type + | Void (* All types encountered *) let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 -(* The basetypes, pointer, typedefs and enums all must have names *) -let name_types: (string,int) Hashtbl.t = Hashtbl.create 7 - -(* Composite types do not need to have a name. We thereore use the stamp for the mapping *) -let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7 +(* Lookup table for types *) +let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 (* Translate a C.typ to a string needed for hashing *) let typ_to_string (ty: typ) = let buf = Buffer.create 7 in let chan = Format.formatter_of_buffer buf in + let old = !Cprint.print_idents_in_full in + Cprint.print_idents_in_full := true; Cprint.typ chan ty; + Cprint.print_idents_in_full := old; Format.pp_print_flush chan (); Buffer.contents buf + +(* Helper functions for the attributes *) +let strip_attributes typ = + let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + match typ with + | TVoid at -> TVoid (strip at) + | TInt (k,at) -> TInt (k,strip at) + | TFloat (k,at) -> TFloat(k,strip at) + | TPtr (t,at) -> TPtr(t,strip at) + | TArray (t,s,at) -> TArray(t,s,strip at) + | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) + | TNamed (n,at) -> TNamed(n,strip at) + | TStruct (n,at) -> TStruct(n,strip at) + | TUnion (n,at) -> TUnion(n,strip at) + | TEnum (n,at) -> TEnum(n,strip at) + +let strip_last_attribute typ = + let rec hd_opt l = match l with + [] -> None,[] + | AConst::rest -> Some AConst,rest + | AVolatile::rest -> Some AVolatile,rest + | _::rest -> hd_opt rest in + match typ with + | TVoid at -> let l,r = hd_opt at in + l,TVoid r + | TInt (k,at) -> let l,r = hd_opt at in + l,TInt (k,r) + | TFloat (k,at) -> let l,r = hd_opt at in + l,TFloat (k,r) + | TPtr (t,at) -> let l,r = hd_opt at in + l,TPtr(t,r) + | TArray (t,s,at) -> let l,r = hd_opt at in + l,TArray(t,s,r) + | TFun (t,arg,v,at) -> let l,r = hd_opt at in + l,TFun(t,arg,v,r) + | TNamed (n,at) -> let l,r = hd_opt at in + l,TNamed(n,r) + | TStruct (n,at) -> let l,r = hd_opt at in + l,TStruct(n,r) + | TUnion (n,at) -> let l,r = hd_opt at in + l,TUnion(n,r) + | TEnum (n,at) -> let l,r = hd_opt at in + l,TEnum(n,r) + +(* Does the type already exist? *) +let exist_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.mem lookup_types (typ_to_string ty) + +(* Find the type id to an type *) +let find_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.find lookup_types (typ_to_string ty) + +(* Add type and information *) +let insert_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + if not (exist_type ty) then + begin + let rec typ_aux ty = () + and attr_aux ty = + match strip_last_attribute ty with + | Some AConst,t -> + () + | None,t -> typ_aux t + in + attr_aux ty + end -- cgit From d9e0b10ac078e936c9521f1f7dba14d3fac0077a Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 14 Sep 2015 17:53:17 +0200 Subject: Implemented insert_type function and started implementing add declaration. The insert_type function add types by adding their subtypes. Also currently the structs or unions are added as empty skeletopn and later during filled during the inserting of the declarations. --- debug/DebugInformation.ml | 219 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 206 insertions(+), 13 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index e84172e6..42c229fa 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -11,6 +11,8 @@ (* *********************************************************************) open C +open Camlcoq +open Cutil (* This implements an interface for the collection of debugging information. *) @@ -66,7 +68,7 @@ type array_type = { type typedef = { typedef_name: string; - typ: int; + typ: int option; } type enumerator = { @@ -75,7 +77,7 @@ type enumerator = { enumerator_const: int; } -type emum_type = { +type enum_type = { enum_name: string; enum_byte_size: int option; enum_file_loc: location option; @@ -97,7 +99,7 @@ type parameter_type = { type function_type = { fun_return_type: int; - fun_prototyped: int; + fun_prototyped: bool; fun_params: parameter_type list; } @@ -108,6 +110,7 @@ type debug_types = | ArrayType of array_type | StructType of composite_type | UnionType of composite_type + | EnumType of enum_type | FunctionType of function_type | Typedef of typedef | ConstType of const_type @@ -133,7 +136,7 @@ let typ_to_string (ty: typ) = (* Helper functions for the attributes *) let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + let strip = List.filter (fun a -> a = AConst || a = AVolatile) in match typ with | TVoid at -> TVoid (strip at) | TInt (k,at) -> TInt (k,strip at) @@ -187,17 +190,207 @@ let find_type (ty: typ) = Hashtbl.find lookup_types (typ_to_string ty) (* Add type and information *) -let insert_type (ty: typ) = +let insert_type (ty: typ) = + let insert d_ty ty = + let id = next_id () + and name = typ_to_string ty in + Hashtbl.add all_types id d_ty; + Hashtbl.add lookup_types name id; + id in (* We are only interrested in Const and Volatile *) let ty = strip_attributes ty in - if not (exist_type ty) then - begin - let rec typ_aux ty = () - and attr_aux ty = + let rec typ_aux ty = + try find_type ty with + | Not_found -> + let d_ty = + match ty with + | TVoid _ -> Void + | TInt (k,_) -> + IntegerType ({int_kind = k }) + | TFloat (k,_) -> + FloatType ({float_kind = k}) + | TPtr (t,_) -> + let id = attr_aux t in + PointerType ({pts = id}) + | TArray (t,s,_) -> + let id = attr_aux t in + let arr = { + arr_type = id; + arr_size= s; + } in + ArrayType arr + | TFun (t,param,va,_) -> + let param,prot = (match param with + | None -> [],false + | Some p -> List.map (fun (i,t) -> let t = attr_aux t in + { + param_type = t; + param_name = i.name; + }) p,true) in + let ret = attr_aux t in + let ftype = { + fun_return_type = ret; + fun_prototyped = prot; + fun_params = param; + } in + FunctionType ftype + | TNamed (id,_) -> + let t = { + typedef_name = id.name; + typ = None; + } in + Typedef t + | TStruct (id,_) -> + let str = + { + ct_name = id.name; + ct_file_loc = None; + ct_members = []; + ct_alignof = None; + ct_sizeof = None; + } in + StructType str + | TUnion (id,_) -> + let union = + { + ct_name = id.name; + ct_file_loc = None; + ct_members = []; + ct_alignof = None; + ct_sizeof = None; + } in + UnionType union + | TEnum (id,_) -> + let enum = + { + enum_name = id.name; + enum_byte_size = None; + enum_file_loc = None; + enum_enumerators = []; + } in + EnumType enum in + insert d_ty ty + and attr_aux ty = + try + find_type ty + with + Not_found -> match strip_last_attribute ty with | Some AConst,t -> - () + let id = attr_aux t in + let const = { const_type = id} in + insert (ConstType const) ty + | Some AVolatile,t -> + let id = attr_aux t in + let volatile = {volatile_type = id} in + insert (VolatileType volatile) ty + | Some (ARestrict|AAlignas _| Attr(_,_)),t -> + attr_aux t | None,t -> typ_aux t - in - attr_aux ty - end + in + attr_aux ty + +(* Replace the struct information *) +let replace_struct id f = + let str = Hashtbl.find all_types id in + match str with + | StructType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (StructType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the union information *) +let replace_union id f = + let union = Hashtbl.find all_types id in + match union with + | UnionType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (UnionType comp') + | _ -> assert false (* This should never happen *) + +(* Replace the typdef information *) +let replace_typedef id f = + let typdef = Hashtbl.find all_types id in + match typdef with + | Typedef typ -> let typ' = f typ in + if typ <> typ' then Hashtbl.replace all_types id (Typedef typ') + | _ -> assert false (* This should never happen *) + +(* Types for global definitions *) + +(* Information for a global variable *) +type global_variable = { + gvar_name: string; + gvar_atom: atom option; + gvar_file_loc: location; + gvar_declaration: bool; + gvar_external: bool; + gvar_type: int; + } + +type definition_type = + | GlobalVariable of global_variable + +(* All definitions encountered *) +let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from stamp to debug id *) +let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 + +let find_var_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let var = Hashtbl.find definitions id in + match var with + | GlobalVariable var -> id,var + +let replace_var id var = + let var = GlobalVariable var in + Hashtbl.replace definitions id var + +let insert_declaration dec env = + let insert d_dec stamp = + let id = next_id () in + Hashtbl.add definitions id d_dec; + Hashtbl.add stamp_to_definition stamp id + in + match dec.gdesc with + | Gdecl (sto,id,ty,init) -> + if not (is_function_type env ty) then begin + if not (Hashtbl.mem stamp_to_definition id.stamp) then begin + let at_decl,ext = (match sto with + | Storage_extern -> init = None,true + | Storage_static -> false,false + | _ -> false,true) in + let ty = insert_type ty in + let decl = { + gvar_name = id.name; + gvar_atom = None; + gvar_file_loc = dec.gloc; + gvar_declaration = at_decl; + gvar_external = ext; + gvar_type = ty; + } in + insert (GlobalVariable decl) id.stamp + end else if init <> None || sto <> Storage_extern then begin (* It is a definition *) + let id,var = find_var_stamp id.stamp in + replace_var id ({var with gvar_declaration = false;}) + end + end + | Gfundef _ -> () + | Gcompositedecl (Struct,id,at) -> + ignore (insert_type (TStruct (id,at))); + let id = find_type (TStruct (id,[])) in + replace_struct id (fun comp -> if comp.ct_file_loc = None then + {comp with ct_file_loc = Some (dec.gloc);} + else comp) + | Gcompositedecl (Union,id,at) -> + ignore (insert_type (TUnion (id,at))); + let id = find_type (TUnion (id,[])) in + replace_union id (fun comp -> if comp.ct_file_loc = None then + {comp with ct_file_loc = Some (dec.gloc);} + else comp) + | Gcompositedef _ -> () + | Gtypedef (id,t) -> + let id = insert_type (TNamed (id,[])) in + let tid = insert_type t in + replace_typedef id (fun typ -> {typ with typ = Some tid;}); + | Genumdef _ -> () + | Gpragma _ -> () -- cgit From 5fc1db7170193a72f7bc6fc660a8e22090368994 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 15 Sep 2015 10:44:46 +0200 Subject: Started adding function information to the debug information. --- debug/DebugInformation.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 48 insertions(+), 3 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 42c229fa..4d340e57 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -317,7 +317,7 @@ let replace_typedef id f = (* Types for global definitions *) (* Information for a global variable *) -type global_variable = { +type global_variable_information = { gvar_name: string; gvar_atom: atom option; gvar_file_loc: location; @@ -326,8 +326,27 @@ type global_variable = { gvar_type: int; } +type parameter_information = + { + parameter_name: string; + parameter_atom: atom option; + parameter_type: int; +} + +type function_information = { + fun_name: string; + fun_atom: atom option; + fun_file_loc: location; + fun_external: bool; + fun_return_type: int option; (* Again the special case of void functions *) + fun_vararg: bool; + fun_parameter: parameter_information list; + fun_locals: int list; + } + type definition_type = - | GlobalVariable of global_variable + | GlobalVariable of global_variable_information + | Function of function_information (* All definitions encountered *) let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 @@ -340,6 +359,7 @@ let find_var_stamp id = let var = Hashtbl.find definitions id in match var with | GlobalVariable var -> id,var + | _ -> assert false let replace_var id var = let var = GlobalVariable var in @@ -374,7 +394,32 @@ let insert_declaration dec env = replace_var id ({var with gvar_declaration = false;}) end end - | Gfundef _ -> () + | Gfundef f -> + let ret = (match f.fd_ret with + | TVoid _ -> None + | _ -> Some (insert_type f.fd_ret)) in + let ext = (match f.fd_storage with + | Storage_static -> false + | _ -> true) in + let params = List.map (fun (p,ty) -> + let ty = insert_type ty in + { + parameter_name = p.name; + parameter_atom = None; + parameter_type = ty; + }) f.fd_params in + let fd = + { + fun_name = f.fd_name.name; + fun_atom = None; + fun_file_loc = dec.gloc; + fun_external = ext; + fun_return_type = ret; + fun_vararg = f.fd_vararg; + fun_parameter = params; + fun_locals = []; + } in + insert (Function fd) f.fd_name.stamp | Gcompositedecl (Struct,id,at) -> ignore (insert_type (TStruct (id,at))); let id = find_type (TStruct (id,[])) in -- cgit From 36fe88d4cc2022947474a2fcc0b650e22f41ee3e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 15 Sep 2015 18:42:04 +0200 Subject: Further function to add debug information. Added the rest of the global declarations and started adding functions to fill in the missing information about struct and union fields etc. --- debug/DebugInformation.ml | 98 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 67 insertions(+), 31 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 4d340e57..166a81e8 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -37,14 +37,15 @@ type composite_field = cfd_bit_offset: int option; cfd_byte_offset: int option; cfd_byte_size: int option; + cfd_bitfield: string option; } type composite_type = { ct_name: string; + ct_sou: struct_or_union; ct_file_loc: location option; ct_members: composite_field list; - ct_alignof: int option; ct_sizeof: int option; } @@ -72,9 +73,8 @@ type typedef = { } type enumerator = { - enumerator_file_loc: location option; enumerator_name: string; - enumerator_const: int; + enumerator_const: int64; } type enum_type = { @@ -108,8 +108,7 @@ type debug_types = | FloatType of float_type | PointerType of ptr_type | ArrayType of array_type - | StructType of composite_type - | UnionType of composite_type + | CompositeType of composite_type | EnumType of enum_type | FunctionType of function_type | Typedef of typedef @@ -244,22 +243,22 @@ let insert_type (ty: typ) = let str = { ct_name = id.name; + ct_sou = Struct; ct_file_loc = None; ct_members = []; - ct_alignof = None; ct_sizeof = None; } in - StructType str + CompositeType str | TUnion (id,_) -> let union = { ct_name = id.name; + ct_sou = Union; ct_file_loc = None; ct_members = []; - ct_alignof = None; ct_sizeof = None; } in - UnionType union + CompositeType union | TEnum (id,_) -> let enum = { @@ -290,20 +289,20 @@ let insert_type (ty: typ) = in attr_aux ty -(* Replace the struct information *) -let replace_struct id f = +(* Replace the composite information *) +let replace_composite id f = let str = Hashtbl.find all_types id in match str with - | StructType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (StructType comp') + | CompositeType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (CompositeType comp') | _ -> assert false (* This should never happen *) -(* Replace the union information *) -let replace_union id f = - let union = Hashtbl.find all_types id in - match union with - | UnionType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (UnionType comp') +(* Replace the enum information *) +let replace_enum id f = + let str = Hashtbl.find all_types id in + match str with + | EnumType comp -> let comp' = f comp in + if comp <> comp' then Hashtbl.replace all_types id (EnumType comp') | _ -> assert false (* This should never happen *) (* Replace the typdef information *) @@ -365,6 +364,12 @@ let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var +let gen_comp_typ sou id at = + if sou = Struct then + TStruct (id,at) + else + TUnion (id,at) + let insert_declaration dec env = let insert d_dec stamp = let id = next_id () in @@ -420,22 +425,53 @@ let insert_declaration dec env = fun_locals = []; } in insert (Function fd) f.fd_name.stamp - | Gcompositedecl (Struct,id,at) -> - ignore (insert_type (TStruct (id,at))); - let id = find_type (TStruct (id,[])) in - replace_struct id (fun comp -> if comp.ct_file_loc = None then + | Gcompositedecl (sou,id,at) -> + ignore (insert_type (gen_comp_typ sou id at)); + let id = find_type (gen_comp_typ sou id []) in + replace_composite id (fun comp -> if comp.ct_file_loc = None then {comp with ct_file_loc = Some (dec.gloc);} else comp) - | Gcompositedecl (Union,id,at) -> - ignore (insert_type (TUnion (id,at))); - let id = find_type (TUnion (id,[])) in - replace_union id (fun comp -> if comp.ct_file_loc = None then - {comp with ct_file_loc = Some (dec.gloc);} - else comp) - | Gcompositedef _ -> () + | Gcompositedef (sou,id,at,fi) -> + ignore (insert_type (gen_comp_typ sou id at)); + let id = find_type (gen_comp_typ sou id []) in + let fields = List.map (fun f -> + { + cfd_name = f.fld_name; + cfd_typ = insert_type f.fld_typ; + cfd_bit_size = None; + cfd_bit_offset = f.fld_bitfield; + cfd_byte_offset = None; + cfd_byte_size = None; + cfd_bitfield = None; + }) fi in + replace_composite id (fun comp -> + let loc = if comp.ct_file_loc = None then Some dec.gloc else comp.ct_file_loc in + {comp with ct_file_loc = loc; ct_members = fields;}) | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in replace_typedef id (fun typ -> {typ with typ = Some tid;}); - | Genumdef _ -> () + | Genumdef (n,at,e) -> + ignore(insert_type (TEnum (n,at))); + let id = find_type (TEnum (n,[])) in + let enumerator = List.map (fun (i,c,_) -> + { + enumerator_name = i.name; + enumerator_const = c; + }) e in + replace_enum id (fun en -> + {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () + +let set_offset str field (offset,byte_size) = + let id = find_type (TStruct (str,[])) in + replace_composite id (fun comp -> + let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in + let members = List.map (fun a -> if name a then + {a with cfd_byte_offset = Some offset; cfd_byte_size = Some byte_size;} + else a) comp.ct_members in + {comp with ct_members = members;}) + +let set_size comp sou size = + let id = find_type (gen_comp_typ sou comp []) in + replace_composite id (fun comp -> {comp with ct_sizeof = Some size;}) -- cgit From 3344bcf59acb1ae8d43a0d15acb4b824689e706d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 16 Sep 2015 11:10:28 +0200 Subject: Add the debug interface file. The new file Debug.ml contains the interface for generating and printing debug information. In order to generate debug information the init function initializes the necessary functions depending on the -g flag. If the -g is not there all functions are dummy functions which do nothing. --- debug/CtoDwarf.ml | 46 +++++++++++++++++++++++++++++++++-- debug/Debug.ml | 61 +++++++++++++++++++++++++++++++++++++++++++++++ debug/Debug.mli | 23 ++++++++++++++++++ debug/DebugInformation.ml | 58 ++++++++++++++++++++++++++++++++++++-------- driver/Driver.ml | 1 + 5 files changed, 177 insertions(+), 12 deletions(-) create mode 100644 debug/Debug.ml create mode 100644 debug/Debug.mli diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml index dce8d81e..3a325665 100644 --- a/debug/CtoDwarf.ml +++ b/debug/CtoDwarf.ml @@ -19,9 +19,8 @@ open DwarfTypes open DwarfUtil open Env open Set -open DebugInformation -(* Functions to translate a C Ast into Dwarf 2 debugging information *) +(* Functions to translate a C Ast into Dwarf 2 debugging information *) (* Hashtable from type name to entry id *) let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 @@ -40,6 +39,49 @@ module IntSet = Set.Make(struct type t = int let compare = compare end) (* Set of all declared composite_types *) let composite_defined: IntSet.t ref = ref IntSet.empty +(* Helper functions for the attributes *) +let strip_attributes typ = + let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + match typ with + | TVoid at -> TVoid (strip at) + | TInt (k,at) -> TInt (k,strip at) + | TFloat (k,at) -> TFloat(k,strip at) + | TPtr (t,at) -> TPtr(t,strip at) + | TArray (t,s,at) -> TArray(t,s,strip at) + | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) + | TNamed (n,at) -> TNamed(n,strip at) + | TStruct (n,at) -> TStruct(n,strip at) + | TUnion (n,at) -> TUnion(n,strip at) + | TEnum (n,at) -> TEnum(n,strip at) + +let strip_last_attribute typ = + let rec hd_opt l = match l with + [] -> None,[] + | AConst::rest -> Some AConst,rest + | AVolatile::rest -> Some AVolatile,rest + | _::rest -> hd_opt rest in + match typ with + | TVoid at -> let l,r = hd_opt at in + l,TVoid r + | TInt (k,at) -> let l,r = hd_opt at in + l,TInt (k,r) + | TFloat (k,at) -> let l,r = hd_opt at in + l,TFloat (k,r) + | TPtr (t,at) -> let l,r = hd_opt at in + l,TPtr(t,r) + | TArray (t,s,at) -> let l,r = hd_opt at in + l,TArray(t,s,r) + | TFun (t,arg,v,at) -> let l,r = hd_opt at in + l,TFun(t,arg,v,r) + | TNamed (n,at) -> let l,r = hd_opt at in + l,TNamed(n,r) + | TStruct (n,at) -> let l,r = hd_opt at in + l,TStruct(n,r) + | TUnion (n,at) -> let l,r = hd_opt at in + l,TUnion(n,r) + | TEnum (n,at) -> let l,r = hd_opt at in + l,TEnum(n,r) + (* Get the type id of a composite_type *) let get_composite_type (name: int): int = try diff --git a/debug/Debug.ml b/debug/Debug.ml new file mode 100644 index 00000000..eb195b33 --- /dev/null +++ b/debug/Debug.ml @@ -0,0 +1,61 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Camlcoq + +(* Interface for generating and printing debug information *) + +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: ident -> atom -> unit; + mutable set_composite_size: ident -> struct_or_union -> int -> unit; + mutable set_member_offset: ident -> string -> int -> int -> unit; + mutable insert_declaration: globdecl -> Env.t -> unit; + } + +let implem = + { + init = (fun _ -> ()); + atom_function = (fun _ _ -> ()); + atom_global_variable = (fun _ _ -> ()); + set_composite_size = (fun _ _ _ -> ()); + set_member_offset = (fun _ _ _ _ -> ()); + insert_declaration = (fun _ _ -> ()); + } + +let init () = + if !Clflags.option_g then begin + implem.init <- DebugInformation.init; + implem.atom_function <- DebugInformation.atom_function; + implem.atom_global_variable <- DebugInformation.atom_global_variable; + implem.set_composite_size <- DebugInformation.set_composite_size; + implem.set_member_offset <- DebugInformation.set_member_offset; + implem.insert_declaration <- DebugInformation.insert_declaration; + end else begin + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (fun _ _ -> ()); + implem.set_composite_size <- (fun _ _ _ -> ()); + implem.set_member_offset <- (fun _ _ _ _ -> ()); + implem.insert_declaration <- (fun _ _ -> ()) + end + +let init_compile_unit name = implem.init name +let atom_function id atom = implem.atom_function id atom +let atom_global_variable id atom = implem.atom_global_variable id atom +let set_composite_size id sou size = implem.set_composite_size id sou size +let set_member_offset id field off size = implem.set_member_offset id field off size +let insert_declaration dec env = implem.insert_declaration dec env diff --git a/debug/Debug.mli b/debug/Debug.mli new file mode 100644 index 00000000..ea72aeb4 --- /dev/null +++ b/debug/Debug.mli @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Camlcoq + + +val init: unit -> unit +val init_compile_unit: string -> unit +val atom_function: ident -> atom -> unit +val atom_global_variable: ident -> atom -> unit +val set_composite_size: ident -> struct_or_union -> int -> unit +val set_member_offset: ident -> string -> int -> int -> unit +val insert_declaration: globdecl -> Env.t -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 166a81e8..30d026c7 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -27,6 +27,9 @@ let next_id () = let reset_id () = id := 0 +(* The name of the current compilation unit *) +let file_name: string ref = ref "" + (* Types for the information of type info *) type composite_field = @@ -117,7 +120,7 @@ type debug_types = | Void (* All types encountered *) -let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 +let types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 (* Lookup table for types *) let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 @@ -193,7 +196,7 @@ let insert_type (ty: typ) = let insert d_ty ty = let id = next_id () and name = typ_to_string ty in - Hashtbl.add all_types id d_ty; + Hashtbl.add types id d_ty; Hashtbl.add lookup_types name id; id in (* We are only interrested in Const and Volatile *) @@ -291,26 +294,26 @@ let insert_type (ty: typ) = (* Replace the composite information *) let replace_composite id f = - let str = Hashtbl.find all_types id in + let str = Hashtbl.find types id in match str with | CompositeType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (CompositeType comp') + if comp <> comp' then Hashtbl.replace types id (CompositeType comp') | _ -> assert false (* This should never happen *) (* Replace the enum information *) let replace_enum id f = - let str = Hashtbl.find all_types id in + let str = Hashtbl.find types id in match str with | EnumType comp -> let comp' = f comp in - if comp <> comp' then Hashtbl.replace all_types id (EnumType comp') + if comp <> comp' then Hashtbl.replace types id (EnumType comp') | _ -> assert false (* This should never happen *) (* Replace the typdef information *) let replace_typedef id f = - let typdef = Hashtbl.find all_types id in + let typdef = Hashtbl.find types id in match typdef with | Typedef typ -> let typ' = f typ in - if typ <> typ' then Hashtbl.replace all_types id (Typedef typ') + if typ <> typ' then Hashtbl.replace types id (Typedef typ') | _ -> assert false (* This should never happen *) (* Types for global definitions *) @@ -353,6 +356,9 @@ let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 +(* Mapping from atom to debug id *) +let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 + let find_var_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in @@ -360,10 +366,22 @@ let find_var_stamp id = | GlobalVariable var -> id,var | _ -> assert false +let find_fun_stamp id = + let id = (Hashtbl.find stamp_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + + let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var +let replace_fun id f = + let f = Function f in + Hashtbl.replace definitions id f + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -463,7 +481,7 @@ let insert_declaration dec env = {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () -let set_offset str field (offset,byte_size) = +let set_member_offset str field offset byte_size = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in @@ -472,6 +490,26 @@ let set_offset str field (offset,byte_size) = else a) comp.ct_members in {comp with ct_members = members;}) -let set_size comp sou size = +let set_composite_size comp sou size = let id = find_type (gen_comp_typ sou comp []) in replace_composite id (fun comp -> {comp with ct_sizeof = Some size;}) + +let atom_global_variable id atom = + let id,var = find_var_stamp id.stamp in + replace_var id ({var with gvar_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + +let atom_function id atom = + let id,f = find_fun_stamp id.stamp in + replace_fun id ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + +let init name = + id := 0; + file_name := name; + Hashtbl.reset types; + Hashtbl.reset lookup_types; + Hashtbl.reset definitions; + Hashtbl.reset stamp_to_definition; + Hashtbl.reset atom_to_definition + diff --git a/driver/Driver.ml b/driver/Driver.ml index f53de821..04acf902 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -682,6 +682,7 @@ let _ = Builtins.set C2C.builtins; CPragmas.initialize(); parse_cmdline cmdline_actions; + Debug.init (); (* Initialize the debug functions *) let nolink = !option_c || !option_S || !option_E || !option_interp in if nolink && !option_o <> None && !num_source_files >= 2 then begin eprintf "Ambiguous '-o' option (multiple source files)\n"; -- cgit From 98cddc7ba45b34fbd71d9a80c27a8e5ec6b311b0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 16 Sep 2015 19:43:35 +0200 Subject: Move more functionality in the new interface. Added functions to add more information to the debuging interface, like the struct layout with offsets, bitifiled layout and removed the no longer needed mapping from stamp to atom. --- backend/PrintAsm.ml | 12 +++++------- cfrontend/C2C.ml | 11 +++++++---- cparser/Bitfields.ml | 1 + cparser/Cutil.ml | 21 ++++++++++++++++++++- cparser/Cutil.mli | 2 ++ cparser/Elab.ml | 28 +++++++++++++++------------- cparser/Parse.ml | 13 ++++--------- cparser/Parse.mli | 2 +- debug/Debug.ml | 38 ++++++++++++++++++++++++-------------- debug/Debug.mli | 8 +++++--- debug/DebugInformation.ml | 35 ++++++++++++++++++++++++++++++----- debug/DwarfPrinter.ml | 4 ---- debug/DwarfTypes.mli | 1 - driver/Driver.ml | 9 +++++---- lib/Camlcoq.ml | 10 +--------- 15 files changed, 120 insertions(+), 75 deletions(-) diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 29409b32..ea3d985a 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -27,11 +27,10 @@ module Printer(Target:TARGET) = let addr_mapping: (string, (int * int)) Hashtbl.t = Hashtbl.create 7 let get_fun_addr name = - let name = extern_atom name in - let start_addr = new_label () - and end_addr = new_label () in - Hashtbl.add addr_mapping name (start_addr,end_addr); - start_addr,end_addr + let s = new_label () + and e = new_label () in + Debug.add_fun_addr name (s,e); + s,e let print_debug_label oc l = if !Clflags.option_g && Configuration.advanced_debug then @@ -120,8 +119,7 @@ module Printer(Target:TARGET) = let get_stmt_list_addr = Target.get_stmt_list_addr let name_of_section = Target.name_of_section let get_fun_addr s = try Some (Hashtbl.find addr_mapping s) with Not_found -> None - let get_location a = try (Target.get_location (stamp_atom a)) with Not_found -> None - let get_segment_location a = try (Target.get_segment_location (stamp_atom a)) with Not_found -> None + let get_location a = None let get_frame_base a = None let symbol = Target.symbol end diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 1a6abb6e..e31da76b 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -524,6 +524,11 @@ let convertField env f = (intern_string f.fld_name, convertTyp env f.fld_typ) let convertCompositedef env su id attr members = + let t = match su with C.Struct -> + let layout = Cutil.struct_layout env members in + List.iter (fun (a,b) -> Debug.set_member_offset id a b) layout; + TStruct (id,attr) | C.Union -> TUnion (id,attr) in + Debug.set_composite_size id su (Cutil.sizeof env t); Composite(intern_string id.name, begin match su with C.Struct -> Struct | C.Union -> Union end, List.map (convertField env) members, @@ -1039,7 +1044,6 @@ let convertFundef loc env fd = List.map (fun (id, ty) -> let id' = intern_string id.name in - add_stamp id.stamp id'; (id', convertTyp env ty)) fd.fd_params in let vars = @@ -1050,7 +1054,6 @@ let convertFundef loc env fd = if init <> None then unsupported "initialized local variable"; let id' = intern_string id.name in - add_stamp id.stamp id'; (id', convertTyp env ty)) fd.fd_locals in let body' = convertStmt loc env fd.fd_body in @@ -1079,7 +1082,7 @@ let convertFundecl env (sto, id, ty, optinit) = | Tfunction(args, res, cconv) -> (args, res, cconv) | _ -> assert false in let id' = intern_string id.name in - add_stamp id.stamp id'; + Debug.atom_function id id'; let sg = signature_of_type args res cconv in let ef = if id.name = "malloc" then EF_malloc else @@ -1121,7 +1124,7 @@ let convertInitializer env ty i = let convertGlobvar loc env (sto, id, ty, optinit) = let id' = intern_string id.name in - add_stamp id.stamp id'; + Debug.atom_global_variable id id'; let ty' = convertTyp env ty in let sz = Ctypes.sizeof !comp_env ty' in let al = Ctypes.alignof !comp_env ty' in diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index 6569bb4c..8d43e689 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -134,6 +134,7 @@ let rec transf_members env id count = function if !config.bitfields_msb_first then sizeof_ikind carrier_ikind * 8 - pos - sz else pos in + Debug.set_bitfield_offset id name pos' carrier (sizeof_ikind carrier_ikind); Hashtbl.add bitfield_table (id, name) {bf_carrier = carrier; bf_carrier_typ = carrier_typ; diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index a3c05c34..90bbfe5a 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -427,7 +427,6 @@ let sizeof_union env members = We lay out fields consecutively, inserting padding to preserve their alignment. Not done here but in composite_info_decl: rounding size to alignment. *) - let sizeof_struct env members = let rec sizeof_rec ofs = function | [] -> @@ -449,6 +448,26 @@ let sizeof_struct env members = end in sizeof_rec 0 members +(* Simplified version to compute offsets on structs without bitfields *) +let struct_layout env members = + let rec struct_layout_rec mem ofs = function + | [] -> + mem + | [ { fld_typ = TArray(_, None, _) } as m ] -> + (* C99: ty[] allowed as last field *) + begin match alignof env m.fld_typ with + | Some a -> ( m.fld_name,align ofs a)::mem + | None -> [] + end + | m :: rem -> + match alignof env m.fld_typ, sizeof env m.fld_typ with + | Some a, Some s -> + let offset = align ofs a in + struct_layout_rec ((m.fld_name,offset)::mem) (offset + s) rem + | _, _ -> [] + in struct_layout_rec [] 0 members + + (* Determine whether a type is incomplete *) let incomplete_type env t = diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index b1f77944..b9879339 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -105,6 +105,8 @@ val composite_info_decl: Env.t -> struct_or_union -> attributes -> Env.composite_info val composite_info_def: Env.t -> struct_or_union -> attributes -> field list -> Env.composite_info +val struct_layout: + Env.t -> field list -> (string * int) list (* Type classification functions *) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index de24871f..ca5865dd 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -56,9 +56,11 @@ let elab_loc l = (l.filename, l.lineno) let top_declarations = ref ([] : globdecl list) -let emit_elab loc td = +let emit_elab env loc td = let loc = elab_loc loc in - top_declarations := { gdesc = td; gloc = loc } :: !top_declarations + let dec ={ gdesc = td; gloc = loc } in + Debug.insert_global_declaration env dec; + top_declarations := dec :: !top_declarations let reset() = top_declarations := [] @@ -730,7 +732,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* finishing the definition of an incomplete struct or union *) let (ci', env') = elab_struct_or_union_info kind loc env members attrs in (* Emit a global definition for it *) - emit_elab loc (Gcompositedef(kind, tag', attrs, ci'.ci_members)); + emit_elab env' loc (Gcompositedef(kind, tag', attrs, ci'.ci_members)); (* Replace infos but keep same ident *) (tag', Env.add_composite env' tag' ci') | Some(tag', {ci_sizeof = Some _}), Some _ @@ -745,7 +747,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* enter it with a new name *) let (tag', env') = Env.enter_composite env tag ci in (* emit it *) - emit_elab loc (Gcompositedecl(kind, tag', attrs)); + emit_elab env' loc (Gcompositedecl(kind, tag', attrs)); (tag', env') | _, Some members -> (* definition of a complete struct or union *) @@ -753,12 +755,12 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = (* enter it, incomplete, with a new name *) let (tag', env') = Env.enter_composite env tag ci1 in (* emit a declaration so that inner structs and unions can refer to it *) - emit_elab loc (Gcompositedecl(kind, tag', attrs)); + emit_elab env' loc (Gcompositedecl(kind, tag', attrs)); (* elaborate the members *) let (ci2, env'') = elab_struct_or_union_info kind loc env' members attrs in (* emit a definition *) - emit_elab loc (Gcompositedef(kind, tag', attrs, ci2.ci_members)); + emit_elab env'' loc (Gcompositedef(kind, tag', attrs, ci2.ci_members)); (* Replace infos but keep same ident *) (tag', Env.add_composite env'' tag' ci2) @@ -809,7 +811,7 @@ and elab_enum only loc tag optmembers attrs env = let (dcls, env') = elab_members env 0L members in let info = { ei_members = dcls; ei_attr = attrs } in let (tag', env'') = Env.enter_enum env' tag info in - emit_elab loc (Genumdef(tag', attrs, dcls)); + emit_elab env' loc (Genumdef(tag', attrs, dcls)); (tag', env'') (* Elaboration of a naked type, e.g. in a cast *) @@ -1312,7 +1314,7 @@ let elab_expr loc env a = let ty = TFun(TInt(IInt, []), None, false, []) in (* Emit an extern declaration for it *) let id = Env.fresh_ident n in - emit_elab loc (Gdecl(Storage_extern, id, ty, None)); + emit_elab env loc (Gdecl(Storage_extern, id, ty, None)); { edesc = EVar id; etyp = ty } | _ -> elab a1 in let bl = List.map elab al in @@ -1789,7 +1791,7 @@ let enter_typedefs loc env sto dl = if redef Env.lookup_ident env s then error loc "redefinition of identifier '%s' as different kind of symbol" s; let (id, env') = Env.enter_typedef env s ty in - emit_elab loc (Gtypedef(id, ty)); + emit_elab env loc (Gtypedef(id, ty)); env') env dl let enter_or_refine_ident local loc env s sto ty = @@ -1865,7 +1867,7 @@ let enter_decdefs local loc env sto dl = ((sto', id, ty', init') :: decls, env2) else begin (* Global definition *) - emit_elab loc (Gdecl(sto', id, ty', init')); + emit_elab env2 loc (Gdecl(sto', id, ty', init')); (decls, env2) end in let (decls, env') = List.fold_left enter_decdef ([], env) dl in @@ -1899,7 +1901,7 @@ let elab_fundef env spec name body loc = let (func_ty, func_init) = __func__type_and_init s in let (func_id, _, env3,func_ty) = enter_or_refine_ident true loc env2 "__func__" Storage_static func_ty in - emit_elab loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); + emit_elab env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); (* Elaborate function body *) let body' = !elab_funbody_f ty_ret env3 body in (* Special treatment of the "main" function *) @@ -1925,7 +1927,7 @@ let elab_fundef env spec name body loc = fd_vararg = vararg; fd_locals = []; fd_body = body'' } in - emit_elab loc (Gfundef fn); + emit_elab env1 loc (Gfundef fn); env1 let elab_kr_fundef env spec name params defs body loc = @@ -1997,7 +1999,7 @@ let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition) (* pragma *) | PRAGMA(s, loc) -> - emit_elab loc (Gpragma s); + emit_elab env loc (Gpragma s); ([], env) and elab_definitions local env = function diff --git a/cparser/Parse.ml b/cparser/Parse.ml index c9564c08..2be3a612 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -24,12 +24,7 @@ let transform_program t p name = (run_pass Unblock.program 'b' (run_pass Bitfields.program 'f' p)))) in - let debug = - if !Clflags.option_g && Configuration.advanced_debug then - Some (CtoDwarf.program_to_dwarf p p1 name) - else - None in - (Rename.program p1 (Filename.chop_suffix name ".c")),debug + (Rename.program p1 (Filename.chop_suffix name ".c")) let parse_transformations s = let t = ref CharSet.empty in @@ -46,7 +41,7 @@ let parse_transformations s = let preprocessed_file transfs name sourcefile = Cerrors.reset(); let ic = open_in sourcefile in - let p,d = + let p = try let t = parse_transformations transfs in let lb = Lexer.init name ic in @@ -65,6 +60,6 @@ let preprocessed_file transfs name sourcefile = Timing.time2 "Emulations" transform_program t p1 name with | Cerrors.Abort -> - [],None in + [] in close_in ic; - if Cerrors.check_errors() then None,None else Some p,d + if Cerrors.check_errors() then None else Some p diff --git a/cparser/Parse.mli b/cparser/Parse.mli index ac8feb70..58c3cfb9 100644 --- a/cparser/Parse.mli +++ b/cparser/Parse.mli @@ -15,7 +15,7 @@ (* Entry point for the library: parse, elaborate, and transform *) -val preprocessed_file: string -> string -> string -> C.program option * DwarfTypes.dw_entry option +val preprocessed_file: string -> string -> string -> C.program option (* first arg: desired transformations second arg: source file name before preprocessing diff --git a/debug/Debug.ml b/debug/Debug.ml index eb195b33..ab20f630 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -21,9 +21,11 @@ type implem = mutable init: string -> unit; mutable atom_function: ident -> atom -> unit; mutable atom_global_variable: ident -> atom -> unit; - mutable set_composite_size: ident -> struct_or_union -> int -> unit; - mutable set_member_offset: ident -> string -> int -> int -> unit; - mutable insert_declaration: globdecl -> Env.t -> unit; + mutable set_composite_size: ident -> struct_or_union -> int option -> unit; + mutable set_member_offset: ident -> string -> int -> unit; + mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + mutable insert_global_declaration: Env.t -> globdecl -> unit; + mutable add_fun_addr: atom -> (int * int) -> unit } let implem = @@ -32,8 +34,10 @@ let implem = atom_function = (fun _ _ -> ()); atom_global_variable = (fun _ _ -> ()); set_composite_size = (fun _ _ _ -> ()); - set_member_offset = (fun _ _ _ _ -> ()); - insert_declaration = (fun _ _ -> ()); + set_member_offset = (fun _ _ _ -> ()); + set_bitfield_offset = (fun _ _ _ _ _ -> ()); + insert_global_declaration = (fun _ _ -> ()); + add_fun_addr = (fun _ _ -> ()); } let init () = @@ -43,19 +47,25 @@ let init () = implem.atom_global_variable <- DebugInformation.atom_global_variable; implem.set_composite_size <- DebugInformation.set_composite_size; implem.set_member_offset <- DebugInformation.set_member_offset; - implem.insert_declaration <- DebugInformation.insert_declaration; + implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; + implem.insert_global_declaration <- DebugInformation.insert_global_declaration; + implem.add_fun_addr <- DebugInformation.add_fun_addr; end else begin - implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (fun _ _ -> ()); - implem.set_composite_size <- (fun _ _ _ -> ()); - implem.set_member_offset <- (fun _ _ _ _ -> ()); - implem.insert_declaration <- (fun _ _ -> ()) + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (fun _ _ -> ()); + implem.set_composite_size <- (fun _ _ _ -> ()); + implem.set_member_offset <- (fun _ _ _ -> ()); + implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); + implem.insert_global_declaration <- (fun _ _ -> ()); + implem.add_fun_addr <- (fun _ _ -> ()) end let init_compile_unit name = implem.init name let atom_function id atom = implem.atom_function id atom let atom_global_variable id atom = implem.atom_global_variable id atom let set_composite_size id sou size = implem.set_composite_size id sou size -let set_member_offset id field off size = implem.set_member_offset id field off size -let insert_declaration dec env = implem.insert_declaration dec env +let set_member_offset id field off = implem.set_member_offset id field off +let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size +let insert_global_declaration env dec = implem.insert_global_declaration env dec +let add_fun_addr atom addr = implem.add_fun_addr atom addr diff --git a/debug/Debug.mli b/debug/Debug.mli index ea72aeb4..ae32af5b 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -18,6 +18,8 @@ val init: unit -> unit val init_compile_unit: string -> unit val atom_function: ident -> atom -> unit val atom_global_variable: ident -> atom -> unit -val set_composite_size: ident -> struct_or_union -> int -> unit -val set_member_offset: ident -> string -> int -> int -> unit -val insert_declaration: globdecl -> Env.t -> unit +val set_composite_size: ident -> struct_or_union -> int option -> unit +val set_member_offset: ident -> string -> int -> unit +val set_bitfield_offset: ident -> string -> int -> string -> int -> unit +val insert_global_declaration: Env.t -> globdecl -> unit +val add_fun_addr: atom -> (int * int) -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 30d026c7..53f73115 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -343,7 +343,9 @@ type function_information = { fun_return_type: int option; (* Again the special case of void functions *) fun_vararg: bool; fun_parameter: parameter_information list; - fun_locals: int list; + fun_locals: int list; + fun_low_pc: int option; + fun_high_pc: int option; } type definition_type = @@ -373,6 +375,13 @@ let find_fun_stamp id = | Function f -> id,f | _ -> assert false +let find_fun_atom id = + let id = (Hashtbl.find atom_to_definition id) in + let f = Hashtbl.find definitions id in + match f with + | Function f -> id,f + | _ -> assert false + let replace_var id var = let var = GlobalVariable var in @@ -388,7 +397,7 @@ let gen_comp_typ sou id at = else TUnion (id,at) -let insert_declaration dec env = +let insert_global_declaration env dec= let insert d_dec stamp = let id = next_id () in Hashtbl.add definitions id d_dec; @@ -441,6 +450,8 @@ let insert_declaration dec env = fun_vararg = f.fd_vararg; fun_parameter = params; fun_locals = []; + fun_low_pc = None; + fun_high_pc = None; } in insert (Function fd) f.fd_name.stamp | Gcompositedecl (sou,id,at) -> @@ -481,18 +492,28 @@ let insert_declaration dec env = {en with enum_file_loc = Some dec.gloc; enum_enumerators = enumerator;}) | Gpragma _ -> () -let set_member_offset str field offset byte_size = +let set_member_offset str field offset = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in let members = List.map (fun a -> if name a then - {a with cfd_byte_offset = Some offset; cfd_byte_size = Some byte_size;} + {a with cfd_byte_offset = Some offset;} else a) comp.ct_members in {comp with ct_members = members;}) let set_composite_size comp sou size = let id = find_type (gen_comp_typ sou comp []) in - replace_composite id (fun comp -> {comp with ct_sizeof = Some size;}) + replace_composite id (fun comp -> {comp with ct_sizeof = size;}) + +let set_bitfield_offset str field offset underlying size = + let id = find_type (TStruct (str,[])) in + replace_composite id (fun comp -> + let name f = f.cfd_name = field in + let members = List.map (fun a -> if name a then + {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size} + else + a) comp.ct_members in + {comp with ct_members = members;}) let atom_global_variable id atom = let id,var = find_var_stamp id.stamp in @@ -504,6 +525,10 @@ let atom_function id atom = replace_fun id ({f with fun_atom = Some atom;}); Hashtbl.add atom_to_definition atom id +let add_fun_addr atom (high,low) = + let id,f = find_fun_atom atom in + replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + let init name = id := 0; file_name := name; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index c85a9efc..09cf72eb 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -130,7 +130,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); add_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; - add_location (get_segment_location e.formal_parameter_id) buf; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) | DW_TAG_label _ -> @@ -205,7 +204,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); add_location (get_location e.variable_id) buf; add_name buf; - add_location (get_segment_location e.variable_id) buf; add_type buf | DW_TAG_volatile_type _ -> prologue 0x35; @@ -367,7 +365,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc fp.formal_parameter_artificial print_flag; print_opt_value oc (get_location fp.formal_parameter_id) print_loc; print_opt_value oc fp.formal_parameter_name print_string; - print_opt_value oc (get_segment_location fp.formal_parameter_id) print_loc; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -441,7 +438,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc var.variable_external print_flag; print_opt_value oc (get_location var.variable_id) print_loc; print_string oc var.variable_name; - print_opt_value oc (get_segment_location var.variable_id) print_loc; print_ref oc var.variable_type let print_volatile_type oc vt = diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 174f2403..b852d1f4 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -270,7 +270,6 @@ module type DWARF_TARGET= val name_of_section: section_name -> string val get_fun_addr: string -> (int * int) option val get_location: int -> location_value option - val get_segment_location: int -> location_value option val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit end diff --git a/driver/Driver.ml b/driver/Driver.ml index 04acf902..47d6e81c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -108,6 +108,7 @@ let preprocess ifile ofile = (* From preprocessed C to Csyntax *) let parse_c_file sourcename ifile = + Debug.init_compile_unit sourcename; Sections.initialize(); (* Simplification options *) let simplifs = @@ -117,10 +118,10 @@ let parse_c_file sourcename ifile = ^ (if !option_fpacked_structs then "p" else "") in (* Parsing and production of a simplified C AST *) - let ast,debug = + let ast = match Parse.preprocessed_file simplifs sourcename ifile with - | None,_ -> exit 2 - | Some p,d -> p,d in + | None -> exit 2 + | Some p -> p in (* Save C AST if requested *) if !option_dparse then begin let ofile = output_filename sourcename ".c" ".parsed.c" in @@ -141,7 +142,7 @@ let parse_c_file sourcename ifile = PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax; close_out oc end; - csyntax,debug + csyntax,None (* Dump Asm code in binary format for the validator *) diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index 5eb52e88..c50b3230 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -284,7 +284,6 @@ let coqint_of_camlint64 : int64 -> Integers.Int64.int = Z.of_uint64 type atom = positive let atom_of_string = (Hashtbl.create 17 : (string, atom) Hashtbl.t) -let atom_of_stamp = (Hashtbl.create 17: (int, atom) Hashtbl.t) let string_of_atom = (Hashtbl.create 17 : (atom, string) Hashtbl.t) let next_atom = ref Coq_xH @@ -296,14 +295,7 @@ let intern_string s = next_atom := Pos.succ !next_atom; Hashtbl.add atom_of_string s a; Hashtbl.add string_of_atom a s; - a - -let add_stamp s a = - Hashtbl.add atom_of_stamp s a - -let stamp_atom s = - Hashtbl.find atom_of_stamp s - + a let extern_atom a = try Hashtbl.find string_of_atom a -- cgit From c8a0b76c6b9c3eb004a7fccdd2ad15cc8615ef93 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 17 Sep 2015 18:19:37 +0200 Subject: First version with computation of dwarf info from debug info. Introduced a new dwarf generation from the information collected in the DebugInformation and removed the old CtODwarf translation. --- backend/PrintAsm.ml | 9 +- backend/PrintAsmaux.ml | 6 - cfrontend/C2C.ml | 2 +- cparser/Bitfields.ml | 2 +- cparser/Elab.ml | 6 +- debug/CtoDwarf.ml | 540 ---------------------------------------------- debug/Debug.ml | 18 +- debug/Debug.mli | 3 + debug/DebugInformation.ml | 80 ++++--- debug/DwarfPrinter.ml | 52 +++-- debug/DwarfTypes.mli | 22 +- debug/DwarfUtil.ml | 12 +- debug/Dwarfgen.ml | 247 +++++++++++++++++++++ powerpc/TargetPrinter.ml | 7 +- 14 files changed, 370 insertions(+), 636 deletions(-) delete mode 100644 debug/CtoDwarf.ml create mode 100644 debug/Dwarfgen.ml diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index ea3d985a..9ffe3aa5 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -27,9 +27,9 @@ module Printer(Target:TARGET) = let addr_mapping: (string, (int * int)) Hashtbl.t = Hashtbl.create 7 let get_fun_addr name = - let s = new_label () - and e = new_label () in - Debug.add_fun_addr name (s,e); + let s = Target.new_label () + and e = Target.new_label () in + Debug.add_fun_addr name (e,s); s,e let print_debug_label oc l = @@ -118,7 +118,6 @@ module Printer(Target:TARGET) = let get_end_addr = Target.get_end_addr let get_stmt_list_addr = Target.get_stmt_list_addr let name_of_section = Target.name_of_section - let get_fun_addr s = try Some (Hashtbl.find addr_mapping s) with Not_found -> None let get_location a = None let get_frame_base a = None let symbol = Target.symbol @@ -140,7 +139,7 @@ let print_program oc p db = close_filenames (); if !Clflags.option_g && Configuration.advanced_debug then begin - match db with + match Debug.generate_debug_info () with | None -> () | Some db -> Printer.DebugPrinter.print_debug oc db diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 324e7e66..2daa2d56 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -143,12 +143,6 @@ let coqint oc n = fprintf oc "%ld" (camlint_of_coqint n) (* Printing annotations in asm syntax *) -(** All files used in the debug entries *) -module StringSet = Set.Make(String) -let all_files : StringSet.t ref = ref StringSet.empty -let add_file file = - all_files := StringSet.add file !all_files - let filename_info : (string, int * Printlines.filebuf option) Hashtbl.t = Hashtbl.create 7 diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index e31da76b..4ed1ded3 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1058,6 +1058,7 @@ let convertFundef loc env fd = fd.fd_locals in let body' = convertStmt loc env fd.fd_body in let id' = intern_string fd.fd_name.name in + Debug.atom_function fd.fd_name id'; Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; a_alignment = None; @@ -1082,7 +1083,6 @@ let convertFundecl env (sto, id, ty, optinit) = | Tfunction(args, res, cconv) -> (args, res, cconv) | _ -> assert false in let id' = intern_string id.name in - Debug.atom_function id id'; let sg = signature_of_type args res cconv in let ef = if id.name = "malloc" then EF_malloc else diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index 8d43e689..cae56f00 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -134,7 +134,7 @@ let rec transf_members env id count = function if !config.bitfields_msb_first then sizeof_ikind carrier_ikind * 8 - pos - sz else pos in - Debug.set_bitfield_offset id name pos' carrier (sizeof_ikind carrier_ikind); + Debug.set_bitfield_offset id name pos carrier (sizeof_ikind carrier_ikind); Hashtbl.add bitfield_table (id, name) {bf_carrier = carrier; bf_carrier_typ = carrier_typ; diff --git a/cparser/Elab.ml b/cparser/Elab.ml index ca5865dd..6839ac9f 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -56,10 +56,10 @@ let elab_loc l = (l.filename, l.lineno) let top_declarations = ref ([] : globdecl list) -let emit_elab env loc td = +let emit_elab ?(enter:bool=true) env loc td = let loc = elab_loc loc in let dec ={ gdesc = td; gloc = loc } in - Debug.insert_global_declaration env dec; + if enter then Debug.insert_global_declaration env dec; top_declarations := dec :: !top_declarations let reset() = top_declarations := [] @@ -1901,7 +1901,7 @@ let elab_fundef env spec name body loc = let (func_ty, func_init) = __func__type_and_init s in let (func_id, _, env3,func_ty) = enter_or_refine_ident true loc env2 "__func__" Storage_static func_ty in - emit_elab env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); + emit_elab ~enter:false env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); (* Elaborate function body *) let body' = !elab_funbody_f ty_ret env3 body in (* Special treatment of the "main" function *) diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml deleted file mode 100644 index 3a325665..00000000 --- a/debug/CtoDwarf.ml +++ /dev/null @@ -1,540 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -open Builtins -open C -open Cprint -open Cutil -open C2C -open DwarfTypes -open DwarfUtil -open Env -open Set - -(* Functions to translate a C Ast into Dwarf 2 debugging information *) - -(* Hashtable from type name to entry id *) -let type_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable for typedefname to entry id *) -let typedef_table: (string, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from composite table to entry id *) -let composite_types_table: (int, int) Hashtbl.t = Hashtbl.create 7 - -(* Hashtable from id of a defined composite types to minimal type info *) -let composite_declarations: (int, (struct_or_union * string * location)) Hashtbl.t = Hashtbl.create 7 - -module IntSet = Set.Make(struct type t = int let compare = compare end) - -(* Set of all declared composite_types *) -let composite_defined: IntSet.t ref = ref IntSet.empty - -(* Helper functions for the attributes *) -let strip_attributes typ = - let strip = List.filter (fun a -> a = AConst || a = AVolatile) in - match typ with - | TVoid at -> TVoid (strip at) - | TInt (k,at) -> TInt (k,strip at) - | TFloat (k,at) -> TFloat(k,strip at) - | TPtr (t,at) -> TPtr(t,strip at) - | TArray (t,s,at) -> TArray(t,s,strip at) - | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) - | TNamed (n,at) -> TNamed(n,strip at) - | TStruct (n,at) -> TStruct(n,strip at) - | TUnion (n,at) -> TUnion(n,strip at) - | TEnum (n,at) -> TEnum(n,strip at) - -let strip_last_attribute typ = - let rec hd_opt l = match l with - [] -> None,[] - | AConst::rest -> Some AConst,rest - | AVolatile::rest -> Some AVolatile,rest - | _::rest -> hd_opt rest in - match typ with - | TVoid at -> let l,r = hd_opt at in - l,TVoid r - | TInt (k,at) -> let l,r = hd_opt at in - l,TInt (k,r) - | TFloat (k,at) -> let l,r = hd_opt at in - l,TFloat (k,r) - | TPtr (t,at) -> let l,r = hd_opt at in - l,TPtr(t,r) - | TArray (t,s,at) -> let l,r = hd_opt at in - l,TArray(t,s,r) - | TFun (t,arg,v,at) -> let l,r = hd_opt at in - l,TFun(t,arg,v,r) - | TNamed (n,at) -> let l,r = hd_opt at in - l,TNamed(n,r) - | TStruct (n,at) -> let l,r = hd_opt at in - l,TStruct(n,r) - | TUnion (n,at) -> let l,r = hd_opt at in - l,TUnion(n,r) - | TEnum (n,at) -> let l,r = hd_opt at in - l,TEnum(n,r) - -(* Get the type id of a composite_type *) -let get_composite_type (name: int): int = - try - Hashtbl.find composite_types_table name - with Not_found -> - let id = next_id () in - Hashtbl.add composite_types_table name id; - id - -(* Translate a C.typ to a string needed for hashing *) -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) - - -(* Dwarf tag for the void type*) -let rec void_dwarf_tag = - let void = { - base_type_byte_size = 0; - base_type_encoding = None; - base_type_name = "void"; - } in - DW_TAG_base_type void - -(* Generate a dwarf tag for the given integer type *) -and int_to_dwarf_tag k = - let encoding = - (match k with - | IBool -> DW_ATE_boolean - | IChar -> - if !Machine.config.Machine.char_signed then - DW_ATE_signed_char - else - DW_ATE_unsigned_char - | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed_char - | _ -> DW_ATE_unsigned)in - let int = { - base_type_byte_size = sizeof_ikind k; - base_type_encoding = Some encoding; - base_type_name = typ_to_string (TInt (k,[]));} in - DW_TAG_base_type int - -(* Generate a dwarf tag for the given floating point type *) -and float_to_dwarf_tag k = - let byte_size = sizeof_fkind k in - let float = { - base_type_byte_size = byte_size; - base_type_encoding = Some DW_ATE_float; - base_type_name = typ_to_string (TFloat (k,[])); - } in - DW_TAG_base_type float - -(* Generate a dwarf tag for the given function type *) -and fun_to_dwarf_tag rt args = - let ret,et = (match rt with - | TVoid _ -> None,[] - | _ -> 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 (i,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_id = i.stamp; - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = 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 - s.id,((s::others)@et) - -(* Generate a dwarf tag for the given array type *) -and array_to_dwarf_tag child size = - let append_opt a b = - match a with - | None -> b - | Some a -> a::b in - let size_to_subrange s = - match s with - | None -> None - | Some i -> - let i = Int64.to_int (Int64.sub i Int64.one) in - let s = - { - subrange_type = None; - subrange_upper_bound = Some (BoundConst i); - } in - Some (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,append_opt 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 (append_opt 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 - arr.id,(arr::e) - -(* Translate a typ without attributes to a dwarf_tag *) -and type_to_dwarf_entry typ typ_string= - let id,entries = - (match typ with - | TVoid _ -> - let e = new_entry void_dwarf_tag in - e.id,[e] - | TInt (k,_) -> - let e = new_entry (int_to_dwarf_tag k) in - e.id,[e] - | TFloat (k,_) -> - let e = new_entry (float_to_dwarf_tag k) in - e.id,[e] - | TPtr (t,_) -> - let t,e = type_to_dwarf t in - let pointer = {pointer_type = t;} in - let t = new_entry (DW_TAG_pointer_type pointer) in - t.id,t::e - | TFun (rt,args,_,_) -> fun_to_dwarf_tag rt args - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | TNamed (i,at) -> - let t = Hashtbl.find typedef_table i.name in - t,[] - | TArray (child,size,_) -> array_to_dwarf_tag child size) - in - Hashtbl.add type_table typ_string id; - id,entries - -(* Tranlate type with attributes to their corresponding dwarf represenation *) -and attr_type_to_dwarf typ typ_string = - let l,t = strip_last_attribute typ in - match l with - | Some AConst -> let id,t = type_to_dwarf t in - let const_tag = DW_TAG_const_type ({const_type = id;}) in - let const_entry = new_entry const_tag in - let id = const_entry.id in - Hashtbl.add type_table typ_string id; - id,const_entry::t - | Some AVolatile -> let id,t = type_to_dwarf t in - let volatile_tag = DW_TAG_volatile_type ({volatile_type = id;}) in - let volatile_entry = new_entry volatile_tag in - let id = volatile_entry.id in - Hashtbl.add type_table typ_string id; - id,volatile_entry::t - | Some (ARestrict|AAlignas _| Attr(_,_)) -> type_to_dwarf t (* This should not happen *) - | None -> type_to_dwarf_entry typ typ_string - -(* Translate a given type to its dwarf representation *) -and type_to_dwarf (typ: typ): int * dw_entry list = - match typ with - | TStruct (i,_) - | TUnion (i,_) - | TEnum (i,_) -> - let t = get_composite_type i.stamp in - t,[] - | _ -> - let typ = strip_attributes typ in - let typ_string = typ_to_string typ in - try - Hashtbl.find type_table typ_string,[] - with Not_found -> - attr_type_to_dwarf typ typ_string - -(* Translate a typedef to its corresponding dwarf representation *) -let typedef_to_dwarf gloc (name,t) = - let i,t = type_to_dwarf t in - let td = { - typedef_file_loc = gloc; - typedef_name = name; - typedef_type = i; - } in - let td = new_entry (DW_TAG_typedef td) in - Hashtbl.add typedef_table name td.id; - td::t - -(* Translate a global var to its corresponding dwarf representation *) -let glob_var_to_dwarf (s,n,t,_) gloc = - let i,t = type_to_dwarf t in - let at_decl = (match s with - | Storage_extern -> true - | _ -> false) in - let ext = (match s with - | Storage_static -> false - | _ -> true) in - let decl = { - variable_id = n.stamp; - variable_file_loc = (Some gloc); - variable_declaration = Some at_decl; - variable_external = Some ext; - variable_name = n.name; - variable_type = i; - } in - let decl = new_entry (DW_TAG_variable decl) in - t,decl - -(* Translate a function definition to its corresponding dwarf representation *) -let fundef_to_dwarf f gloc = - let ret,e = (match f.fd_ret with - | TVoid _ -> None,[] - | _ -> let i,t = type_to_dwarf f.fd_ret in - Some i,t) in - let ext = (match f.fd_storage with - | Storage_static -> false - | _ -> true) in - let fdef = { - subprogram_id = f.fd_name.stamp; - subprogram_file_loc = (Some gloc); - subprogram_external = Some ext; - subprogram_name = f.fd_name.name; - subprogram_prototyped = true; - subprogram_type = ret; - } in - let fp,e = mmap (fun acc (p,t) -> - let t,e = type_to_dwarf t in - let fp = - { - formal_parameter_id = p.stamp; - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = (Some p.name); - formal_parameter_type = t; - formal_parameter_variable_parameter = None; - } in - let entry = new_entry (DW_TAG_formal_parameter fp) in - entry,(e@acc)) e f.fd_params in - let fdef = new_entry (DW_TAG_subprogram fdef) in - let fdef = add_children fdef fp in - e,fdef - -(* Translate a enum definition to its corresponding dwarf representation *) -let enum_to_dwarf (n,at,e) gloc = - let enumerator_to_dwarf (i,c,_)= - let tag = - { - enumerator_file_loc = None; - enumerator_value = Int64.to_int c; - enumerator_name = i.name; - } in - new_entry (DW_TAG_enumerator tag) in - let bs = sizeof_ikind enum_ikind in - let enum = { - enumeration_file_loc = Some gloc; - enumeration_byte_size = bs; - enumeration_declaration = Some false; - enumeration_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let child = List.map enumerator_to_dwarf e in - let enum = - { - tag = DW_TAG_enumeration_type enum; - children = child; - id = id; - } in - [enum] - -(* Translate a struct definition to its corresponding dwarf representation *) -let struct_to_dwarf (n,at,m) env gloc = - let info = Env.find_struct env n in - let tag =DW_TAG_structure_type { - structure_file_loc = Some gloc; - structure_byte_size = info.ci_sizeof; - structure_declaration = Some false; - structure_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let rec pack acc bcc l m = - match m with - | [] -> acc,bcc,[] - | m::ms as ml -> - (match m.fld_bitfield with - | None -> acc,bcc,ml - | Some n -> - if n = 0 then - acc,bcc,ms (* bit width 0 means end of pack *) - else if l + n > 8 * !Machine.config.Machine.sizeof_int then - acc,bcc,ml (* doesn't fit in current word *) - else - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = Some !Machine.config.Machine.sizeof_int; - member_bit_offset = Some l; - member_bit_size = Some n; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - pack ((new_entry (DW_TAG_member um))::acc) (e@bcc) (l + n) ms) - and translate acc bcc m = - match m with - [] -> acc,bcc - | m::ms as ml -> - (match m.fld_bitfield with - | None -> - let t,e = type_to_dwarf m.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if m.fld_name <> "" then Some m.fld_name else None; - member_type = t; - } in - translate ((new_entry (DW_TAG_member um))::acc) (e@bcc) ms - | Some _ -> let acc,bcc,rest = pack acc bcc 0 ml in - translate acc bcc rest) - in - let children,e = translate [] [] m in - let children,e = List.rev children,e in - let sou = { - tag = tag; - children = children; - id = id;} in - sou::e - -(* Translate a union definition to its corresponding dwarf representation *) -let union_to_dwarf (n,at,m) env gloc = - let info = Env.find_union env n in - let tag = DW_TAG_union_type { - union_file_loc = Some gloc; - union_byte_size = info.ci_sizeof; - union_declaration = Some false; - union_name = if n.name <> "" then Some n.name else None; - } in - let id = get_composite_type n.stamp in - let children,e = mmap - (fun acc f -> - let t,e = type_to_dwarf f.fld_typ in - let um = { - member_file_loc = None; - member_byte_size = None; - member_bit_offset = None; - member_bit_size = None; - member_data_member_location = None; - member_declaration = None; - member_name = if f.fld_name <> "" then Some f.fld_name else None; - member_type = t; - } in - new_entry (DW_TAG_member um),e@acc)[] m in - let sou = { - tag = tag; - children = children; - id = id;} in - sou::e - -(* Translate global declarations to there dwarf representation *) -let globdecl_to_dwarf env (typs,decls) decl = - PrintAsmaux.add_file (fst decl.gloc); - match decl.gdesc with - | Gtypedef (n,t) -> let ret = typedef_to_dwarf (Some decl.gloc) (n.name,t) in - typs@ret,decls - | Gdecl d -> let t,d = glob_var_to_dwarf d decl.gloc in - typs@t,d::decls - | Gfundef f -> let t,d = fundef_to_dwarf f decl.gloc in - typs@t,d::decls - | Genumdef (n,at,e) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = enum_to_dwarf (n,at,e) decl.gloc in - typs@ret,decls - | Gcompositedef (Struct,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = struct_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedef (Union,n,at,m) -> - composite_defined:= IntSet.add n.stamp !composite_defined; - let ret = union_to_dwarf (n,at,m) env decl.gloc in - typs@ret,decls - | Gcompositedecl (sou,i,_) -> Hashtbl.add composite_declarations i.stamp (sou,i.name,decl.gloc); - typs,decls - | Gpragma _ -> typs,decls - -let forward_declaration_to_dwarf sou name loc stamp = - let id = get_composite_type stamp in - let tag = match sou with - | Struct -> - DW_TAG_structure_type{ - structure_file_loc = Some loc; - structure_byte_size = None; - structure_declaration = Some true; - structure_name = if name <> "" then Some name else None; - } - | Union -> - DW_TAG_union_type { - union_file_loc = Some loc; - union_byte_size = None; - union_declaration = Some true; - union_name = if name <> "" then Some name else None; - } in - {tag = tag; children = []; id = id} - - -(* Compute the dwarf representations of global declarations. The second program argument is the - program after the bitfield and packed struct transformation *) -let program_to_dwarf prog prog1 name = - Hashtbl.reset type_table; - Hashtbl.reset composite_types_table; - Hashtbl.reset typedef_table; - let prog = cleanupGlobals (prog) in - let env = translEnv Env.empty prog1 in - reset_id (); - let typs = List.map (typedef_to_dwarf None) C2C.builtins.typedefs in - let typs = List.concat typs in - let typs,defs = List.fold_left (globdecl_to_dwarf env) (typs,[]) prog in - let typs = Hashtbl.fold (fun i (sou,name,loc) typs -> if not (IntSet.mem i !composite_defined) then - (forward_declaration_to_dwarf sou name loc i)::typs else typs) composite_declarations typs in - let defs = typs @ defs in - let cp = { - compile_unit_name = name; - } in - let cp = new_entry (DW_TAG_compile_unit cp) in - add_children cp defs diff --git a/debug/Debug.ml b/debug/Debug.ml index ab20f630..c45fd074 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -12,6 +12,8 @@ open C open Camlcoq +open Dwarfgen +open DwarfTypes (* Interface for generating and printing debug information *) @@ -25,7 +27,9 @@ type implem = mutable set_member_offset: ident -> string -> int -> unit; mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; mutable insert_global_declaration: Env.t -> globdecl -> unit; - mutable add_fun_addr: atom -> (int * int) -> unit + mutable add_fun_addr: atom -> (int * int) -> unit; + mutable generate_debug_info: unit -> dw_entry option; + mutable all_files_iter: (string -> unit) -> unit; } let implem = @@ -38,7 +42,9 @@ let implem = set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); add_fun_addr = (fun _ _ -> ()); - } + generate_debug_info = (fun _ -> None); + all_files_iter = (fun _ -> ()); +} let init () = if !Clflags.option_g then begin @@ -50,6 +56,8 @@ let init () = implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; implem.insert_global_declaration <- DebugInformation.insert_global_declaration; implem.add_fun_addr <- DebugInformation.add_fun_addr; + implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -58,7 +66,9 @@ let init () = implem.set_member_offset <- (fun _ _ _ -> ()); implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); implem.insert_global_declaration <- (fun _ _ -> ()); - implem.add_fun_addr <- (fun _ _ -> ()) + implem.add_fun_addr <- (fun _ _ -> ()); + implem.generate_debug_info <- (fun _ -> None); + implem.all_files_iter <- (fun _ -> ()); end let init_compile_unit name = implem.init name @@ -69,3 +79,5 @@ let set_member_offset id field off = implem.set_member_offset id field off let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size let insert_global_declaration env dec = implem.insert_global_declaration env dec let add_fun_addr atom addr = implem.add_fun_addr atom addr +let generate_debug_info () = implem.generate_debug_info () +let all_files_iter f = implem.all_files_iter f diff --git a/debug/Debug.mli b/debug/Debug.mli index ae32af5b..e712874c 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -12,6 +12,7 @@ open C open Camlcoq +open DwarfTypes val init: unit -> unit @@ -23,3 +24,5 @@ val set_member_offset: ident -> string -> int -> unit val set_bitfield_offset: ident -> string -> int -> string -> int -> unit val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit +val generate_debug_info: unit -> dw_entry option +val all_files_iter: (string -> unit) -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 53f73115..100f37e2 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -30,6 +30,11 @@ let reset_id () = (* The name of the current compilation unit *) let file_name: string ref = ref "" +(** All files used in the debug entries *) +module StringSet = Set.Make(String) +let all_files : StringSet.t ref = ref StringSet.empty +let add_file file = + all_files := StringSet.add file !all_files (* Types for the information of type info *) type composite_field = @@ -45,11 +50,12 @@ type composite_field = type composite_type = { - ct_name: string; - ct_sou: struct_or_union; - ct_file_loc: location option; - ct_members: composite_field list; - ct_sizeof: int option; + ct_name: string; + ct_sou: struct_or_union; + ct_file_loc: location option; + ct_members: composite_field list; + ct_sizeof: int option; + ct_declaration: bool; } type ptr_type = { @@ -57,22 +63,23 @@ type ptr_type = { } type const_type = { - const_type: int + cst_type: int } type volatile_type = { - volatile_type: int + vol_type: int } type array_type = { arr_type: int; - arr_size: int64 option; + arr_size: int64 option list; } type typedef = { - typedef_name: string; - typ: int option; + typedef_file_loc: location option; + typedef_name: string; + typ: int option; } type enumerator = { @@ -101,7 +108,7 @@ type parameter_type = { } type function_type = { - fun_return_type: int; + fun_return_type: int option; fun_prototyped: bool; fun_params: parameter_type list; } @@ -215,6 +222,11 @@ let insert_type (ty: typ) = let id = attr_aux t in PointerType ({pts = id}) | TArray (t,s,_) -> + let rec size acc t = (match t with + | TArray (child,s,_) -> + size (s::acc) child + | _ -> t,List.rev acc) in + let t,s = size [s] t in let id = attr_aux t in let arr = { arr_type = id; @@ -229,7 +241,9 @@ let insert_type (ty: typ) = param_type = t; param_name = i.name; }) p,true) in - let ret = attr_aux t in + let ret = (match t with + | TVoid _ -> None + | _ -> Some (attr_aux t)) in let ftype = { fun_return_type = ret; fun_prototyped = prot; @@ -238,6 +252,7 @@ let insert_type (ty: typ) = FunctionType ftype | TNamed (id,_) -> let t = { + typedef_file_loc = None; typedef_name = id.name; typ = None; } in @@ -249,6 +264,7 @@ let insert_type (ty: typ) = ct_sou = Struct; ct_file_loc = None; ct_members = []; + ct_declaration = false; ct_sizeof = None; } in CompositeType str @@ -259,6 +275,7 @@ let insert_type (ty: typ) = ct_sou = Union; ct_file_loc = None; ct_members = []; + ct_declaration = false; ct_sizeof = None; } in CompositeType union @@ -280,11 +297,11 @@ let insert_type (ty: typ) = match strip_last_attribute ty with | Some AConst,t -> let id = attr_aux t in - let const = { const_type = id} in + let const = { cst_type = id} in insert (ConstType const) ty | Some AVolatile,t -> let id = attr_aux t in - let volatile = {volatile_type = id} in + let volatile = {vol_type = id} in insert (VolatileType volatile) ty | Some (ARestrict|AAlignas _| Attr(_,_)),t -> attr_aux t @@ -398,6 +415,7 @@ let gen_comp_typ sou id at = TUnion (id,at) let insert_global_declaration env dec= + add_file (fst dec.gloc); let insert d_dec stamp = let id = next_id () in Hashtbl.add definitions id d_dec; @@ -463,23 +481,24 @@ let insert_global_declaration env dec= | Gcompositedef (sou,id,at,fi) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in + let fi = List.filter (fun f -> f.fld_name <> "") fi in (* Fields without names need no info *) let fields = List.map (fun f -> { cfd_name = f.fld_name; cfd_typ = insert_type f.fld_typ; - cfd_bit_size = None; - cfd_bit_offset = f.fld_bitfield; + cfd_bit_size = f.fld_bitfield; + cfd_bit_offset = None; cfd_byte_offset = None; cfd_byte_size = None; cfd_bitfield = None; }) fi in replace_composite id (fun comp -> let loc = if comp.ct_file_loc = None then Some dec.gloc else comp.ct_file_loc in - {comp with ct_file_loc = loc; ct_members = fields;}) + {comp with ct_file_loc = loc; ct_members = fields; ct_declaration = true;}) | Gtypedef (id,t) -> let id = insert_type (TNamed (id,[])) in let tid = insert_type t in - replace_typedef id (fun typ -> {typ with typ = Some tid;}); + replace_typedef id (fun typ -> {typ with typedef_file_loc = Some dec.gloc; typ = Some tid;}); | Genumdef (n,at,e) -> ignore(insert_type (TEnum (n,at))); let id = find_type (TEnum (n,[])) in @@ -516,18 +535,25 @@ let set_bitfield_offset str field offset underlying size = {comp with ct_members = members;}) let atom_global_variable id atom = - let id,var = find_var_stamp id.stamp in - replace_var id ({var with gvar_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id + try + let id,var = find_var_stamp id.stamp in + replace_var id ({var with gvar_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + with Not_found -> () let atom_function id atom = - let id,f = find_fun_stamp id.stamp in - replace_fun id ({f with fun_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id - + try + Printf.printf "Trying to add atom of function %s\n" id.name; + let id,f = find_fun_stamp id.stamp in + replace_fun id ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id + with Not_found -> () + let add_fun_addr atom (high,low) = - let id,f = find_fun_atom atom in - replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + try + let id,f = find_fun_atom atom in + replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) + with Not_found -> Printf.printf "Could not find function %s\n" (extern_atom atom); () let init name = id := 0; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 09cf72eb..a0b16463 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -62,11 +62,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_low_pc = add_abbr_entry (0x11,low_pc_type_abbr) - let add_fun_pc sp buf = - match get_fun_addr sp.subprogram_name with - | None ->() - | Some (a,b) -> add_high_pc buf; add_low_pc buf - let add_declaration = add_abbr_entry (0x3c,declaration_type_abbr) let add_location loc buf = @@ -128,7 +123,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0x5; add_attr_some e.formal_parameter_file_loc add_file_loc; add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); - add_location (get_location e.formal_parameter_id) buf; add_attr_some e.formal_parameter_name add_name; add_type buf; add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) @@ -144,15 +138,15 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0xd; add_attr_some e.member_file_loc add_file_loc; add_attr_some e.member_byte_size add_byte_size; - add_attr_some e.member_bit_offset (add_abbr_entry (0xd,bit_offset_type_abbr)); - add_attr_some e.member_bit_size (add_abbr_entry (0xc,bit_size_type_abbr)); + add_attr_some e.member_bit_offset (add_abbr_entry (0xc,bit_offset_type_abbr)); + add_attr_some e.member_bit_size (add_abbr_entry (0xd,bit_size_type_abbr)); + add_attr_some e.member_declaration add_declaration; + add_attr_some e.member_name add_name; + add_type buf; (match e.member_data_member_location with | None -> () | Some (DataLocBlock __) -> add_abbr_entry (0x38,data_location_block_type_abbr) buf - | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf); - add_attr_some e.member_declaration add_declaration; - add_attr_some e.member_name add_name; - add_type buf + | Some (DataLocRef _) -> add_abbr_entry (0x38,data_location_ref_type_abbr) buf) | DW_TAG_pointer_type _ -> prologue 0xf; add_type buf @@ -164,10 +158,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.structure_name add_name | DW_TAG_subprogram e -> prologue 0x2e; - add_attr_some e.subprogram_file_loc add_file_loc; + add_file_loc buf; add_attr_some e.subprogram_external (add_abbr_entry (0x3f,external_type_abbr)); - add_high_pc buf; - add_low_pc buf; + add_attr_some e.subprogram_high_pc add_high_pc; + add_attr_some e.subprogram_low_pc add_low_pc; add_name buf; add_abbr_entry (0x27,prototyped_type_abbr) buf; add_attr_some e.subprogram_type add_type; @@ -199,10 +193,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): add_attr_some e.unspecified_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)) | DW_TAG_variable e -> prologue 0x34; - add_attr_some e.variable_file_loc add_file_loc; + add_file_loc buf; add_attr_some e.variable_declaration add_declaration; add_attr_some e.variable_external (add_abbr_entry (0x3f,external_type_abbr)); - add_location (get_location e.variable_id) buf; + add_location e.variable_location buf; add_name buf; add_type buf | DW_TAG_volatile_type _ -> @@ -301,7 +295,12 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | _ -> () let print_data_location oc dl = - () + match dl with + | DataLocBlock [DW_OP_plus_uconst i] -> + fprintf oc " .sleb128 2\n"; + fprintf oc " .byte 0x23\n"; + fprintf oc " .byte %d\n" i + | _ -> () let print_ref oc r = let ref = entry_to_label r in @@ -363,7 +362,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_formal_parameter oc fp = print_file_loc oc fp.formal_parameter_file_loc; print_opt_value oc fp.formal_parameter_artificial print_flag; - print_opt_value oc (get_location fp.formal_parameter_id) print_loc; print_opt_value oc fp.formal_parameter_name print_string; print_ref oc fp.formal_parameter_type; print_opt_value oc fp.formal_parameter_variable_parameter print_flag @@ -381,10 +379,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc mb.member_byte_size print_byte; print_opt_value oc mb.member_bit_offset print_byte; print_opt_value oc mb.member_bit_size print_byte; - print_opt_value oc mb.member_data_member_location print_data_location; print_opt_value oc mb.member_declaration print_flag; print_opt_value oc mb.member_name print_string; - print_ref oc mb.member_type + print_ref oc mb.member_type; + print_opt_value oc mb.member_data_member_location print_data_location + let print_pointer oc pt = print_ref oc pt.pointer_type @@ -400,11 +399,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): fprintf oc " .4byte %a\n" label s let print_subprogram oc sp = - let addr = get_fun_addr sp.subprogram_name in - print_file_loc oc sp.subprogram_file_loc; + print_file_loc oc (Some sp.subprogram_file_loc); print_opt_value oc sp.subprogram_external print_flag; - print_opt_value oc (get_frame_base sp.subprogram_id) print_loc; - print_opt_value oc addr print_subprogram_addr; + print_opt_value oc sp.subprogram_high_pc print_addr; + print_opt_value oc sp.subprogram_low_pc print_addr; print_string oc sp.subprogram_name; print_flag oc sp.subprogram_prototyped; print_opt_value oc sp.subprogram_type print_ref @@ -433,10 +431,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_opt_value oc up.unspecified_parameter_artificial print_flag let print_variable oc var = - print_file_loc oc var.variable_file_loc; + print_file_loc oc (Some var.variable_file_loc); print_opt_value oc var.variable_declaration print_flag; print_opt_value oc var.variable_external print_flag; - print_opt_value oc (get_location var.variable_id) print_loc; + print_opt_value oc var.variable_location print_loc; print_string oc var.variable_name; print_ref oc var.variable_type diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index b852d1f4..eb7d4060 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -37,13 +37,18 @@ type address = int type block = string +type location_expression = + | DW_OP_plus_uconst of constant + | DW_OP + + type location_value = | LocSymbol of atom | LocConst of constant | LocBlock of block type data_location_value = - | DataLocBlock of block + | DataLocBlock of location_expression list | DataLocRef of reference type bound_value = @@ -94,7 +99,6 @@ type dw_tag_enumerator = type dw_tag_formal_parameter = { - formal_parameter_id: int; formal_parameter_file_loc: file_loc option; formal_parameter_artificial: flag option; formal_parameter_name: string option; @@ -141,12 +145,13 @@ type dw_tag_structure_type = type dw_tag_subprogram = { - subprogram_id: int; - subprogram_file_loc: file_loc option; - subprogram_external: flag option; + subprogram_file_loc: file_loc; + subprogram_external: flag option; subprogram_name: string; subprogram_prototyped: flag; - subprogram_type: reference option; + subprogram_type: reference option; + subprogram_high_pc: reference option; + subprogram_low_pc: reference option; } type dw_tag_subrange_type = @@ -184,12 +189,12 @@ type dw_tag_unspecified_parameter = type dw_tag_variable = { - variable_id: int; - variable_file_loc: file_loc option; + variable_file_loc: file_loc; variable_declaration: flag option; variable_external: flag option; variable_name: string; variable_type: reference; + variable_location: location_value option; } type dw_tag_volatile_type = @@ -268,7 +273,6 @@ module type DWARF_TARGET= val get_end_addr: unit -> int val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string - val get_fun_addr: string -> (int * int) option val get_location: int -> location_value option val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index e2c87a9d..d5e72adb 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -14,18 +14,8 @@ open DwarfTypes -let id = ref 0 - -let next_id () = - let nid = !id in - incr id; nid - -let reset_id () = - id := 0 - (* Generate a new entry from a given tag *) -let new_entry tag = - let id = next_id () in +let new_entry id tag = { tag = tag; children = []; diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml new file mode 100644 index 00000000..0acab05a --- /dev/null +++ b/debug/Dwarfgen.ml @@ -0,0 +1,247 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open C +open Cutil +open DebugInformation +open DwarfTypes +open DwarfUtil +(* Generate the dwarf DIE's from the information collected in DebugInformation *) + +(* Helper function to get values that must be set. *) +let get_opt_val = function + | Some a -> a + | None -> assert false + +(* Functions to translate the basetypes. *) +let int_type_to_entry id i = + let encoding = + (match i.int_kind with + | IBool -> DW_ATE_boolean + | IChar -> + if !Machine.config.Machine.char_signed then + DW_ATE_signed_char + else + DW_ATE_unsigned_char + | IInt | ILong | ILongLong | IShort | ISChar -> DW_ATE_signed + | _ -> DW_ATE_unsigned)in + let int = { + base_type_byte_size = sizeof_ikind i.int_kind; + base_type_encoding = Some encoding; + base_type_name = typ_to_string (TInt (i.int_kind,[]));} in + new_entry id (DW_TAG_base_type int) + +let float_type_to_entry id f = + let byte_size = sizeof_fkind f.float_kind in + let float = { + base_type_byte_size = byte_size; + base_type_encoding = Some DW_ATE_float; + base_type_name = typ_to_string (TFloat (f.float_kind,[])); + } in + new_entry id (DW_TAG_base_type float) + +let void_to_entry id = + let void = { + base_type_byte_size = 0; + base_type_encoding = None; + base_type_name = "void"; + } in + new_entry id (DW_TAG_base_type void) + +let typedef_to_entry id t = + let i = get_opt_val t.typ in + let td = { + typedef_file_loc = t.typedef_file_loc; + typedef_name = t.typedef_name; + typedef_type = i; + } in + new_entry id (DW_TAG_typedef td) + +let pointer_to_entry id p = + let p = {pointer_type = p.pts} in + new_entry id (DW_TAG_pointer_type p) + +let array_to_entry id arr = + let arr_tag = { + array_type_file_loc = None; + array_type = arr.arr_type; + } in + let arr_entry = new_entry id (DW_TAG_array_type arr_tag) in + let children = List.map (fun a -> + let r = match a with + | None -> None + | Some i -> + let bound = Int64.to_int (Int64.sub i Int64.one) in + Some (BoundConst bound) in + let s = { + subrange_type = None; + subrange_upper_bound = r; + } in + new_entry (next_id ()) (DW_TAG_subrange_type s)) arr.arr_size in + add_children arr_entry children + +let const_to_entry id c = + new_entry id (DW_TAG_const_type ({const_type = c.cst_type})) + +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 enumerator_to_entry e = + let tag = + { + enumerator_file_loc = None; + enumerator_value = Int64.to_int (e.enumerator_const); + enumerator_name = e.enumerator_name; + } in + 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_byte_size = bs; + enumeration_declaration = Some false; + enumeration_name = Some e.enum_name; + } in + let enum = new_entry id (DW_TAG_enumeration_type enum) in + let child = List.map enumerator_to_entry e.enum_enumerators in + add_children enum child + +let fun_type_to_entry id f = + let children = if f.fun_prototyped then + let u = { + unspecified_parameter_file_loc = None; + unspecified_parameter_artificial = None; + } in + [new_entry (next_id ()) (DW_TAG_unspecified_parameter u)] + else + List.map (fun p -> + let fp = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = if p.param_name <> "" then Some p.param_name else None; + formal_parameter_type = p.param_type; + formal_parameter_variable_parameter = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; + in + let s = { + subroutine_type = f.fun_return_type; + subroutine_prototyped = f.fun_prototyped + } in + let s = new_entry id (DW_TAG_subroutine_type s) in + add_children s children + +let member_to_entry mem = + let mem = { + member_file_loc = None; + member_byte_size = mem.cfd_byte_size; + member_bit_offset = mem.cfd_bit_offset; + member_bit_size = mem.cfd_bit_size; + member_data_member_location = Some (DataLocBlock [DW_OP_plus_uconst (get_opt_val mem.cfd_byte_offset)]); + member_declaration = None; + member_name = Some (mem.cfd_name); + member_type = mem.cfd_typ; + } in + new_entry (next_id ()) (DW_TAG_member mem) + +let struct_to_entry id s = + let tag = { + structure_file_loc = 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; + } in + let entry = new_entry id (DW_TAG_structure_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + +let union_to_entry id s = + let tag = { + union_file_loc = 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; + } in + let entry = new_entry id (DW_TAG_union_type tag) in + let child = List.map member_to_entry s.ct_members in + add_children entry child + +let composite_to_entry id s = + match s.ct_sou with + | Struct -> struct_to_entry id s + | Union -> union_to_entry id s + +let infotype_to_entry 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 + | FunctionType f -> fun_type_to_entry id f + | Typedef t -> typedef_to_entry id t + | ConstType c -> const_to_entry id c + | VolatileType v -> volatile_to_entry id v + | Void -> void_to_entry id + +let gen_types () = + List.rev (Hashtbl.fold (fun id t acc -> (infotype_to_entry id t)::acc) types []) + +let global_variable_to_entry id v = + let var = { + variable_file_loc = v.gvar_file_loc; + variable_declaration = Some v.gvar_declaration; + variable_external = Some v.gvar_external; + variable_name = v.gvar_name; + variable_type = v.gvar_type; + variable_location = match v.gvar_atom with Some a -> Some (LocSymbol a) | None -> None; + } in + new_entry id (DW_TAG_variable var) + +let function_parameter_to_entry p = + let p = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = Some p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + } in + new_entry (next_id ()) (DW_TAG_formal_parameter p) + +let function_to_entry id f = + let f_tag = { + subprogram_file_loc = f.fun_file_loc; + subprogram_external = Some f.fun_external; + subprogram_name = f.fun_name; + subprogram_prototyped = true; + subprogram_type = f.fun_return_type; + subprogram_high_pc = f.fun_high_pc; + subprogram_low_pc = f.fun_low_pc; + } in + let f_entry = new_entry id (DW_TAG_subprogram f_tag) in + let child = List.map function_parameter_to_entry f.fun_parameter in + add_children f_entry child + +let definition_to_entry id t = + match t with + | GlobalVariable g -> global_variable_to_entry id g + | Function f -> function_to_entry id f + +let gen_defs () = + List.rev (Hashtbl.fold (fun id t acc -> (definition_to_entry id t)::acc) definitions []) + +let gen_debug_info () = + let cp = { + compile_unit_name = !file_name; + } in + let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in + add_children cp ((gen_types ()) @ (gen_defs ())) diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 409f2cc0..c126f641 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -246,8 +246,9 @@ module Diab_System : SYSTEM = let filenum : (string,int) Hashtbl.t = Hashtbl.create 7 - let additional_debug_sections: StringSet.t ref = ref StringSet.empty + module StringSet = Set.Make(String) + let additional_debug_sections: StringSet.t ref = ref StringSet.empty let print_epilogue oc = if !Clflags.option_g then @@ -257,10 +258,10 @@ module Diab_System : SYSTEM = end_addr := label_end; fprintf oc "%a:\n" label label_end; fprintf oc " .text\n"; - StringSet.iter (fun file -> + Debug.all_files_iter (fun file -> let label = new_label () in Hashtbl.add filenum file label; - fprintf oc ".L%d: .d2filenum \"%s\"\n" label file) !all_files; + fprintf oc ".L%d: .d2filenum \"%s\"\n" label file); fprintf oc " .d2_line_end\n"; StringSet.iter (fun s -> fprintf oc " %s\n" s; -- cgit From 31aceeb1be64d529432f35bbea16ebafc3a21df0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 18 Sep 2015 16:42:05 +0200 Subject: Started implementing the scope for the Debug Informations. Scopes will be handled by a stack of all open scopes. This stack then can also be used to generate the debug directives to track the scopes through the rest of the passes. --- cfrontend/C2C.ml | 1 + cparser/Elab.ml | 4 ++- debug/Debug.ml | 10 ++++++ debug/Debug.mli | 2 ++ debug/DebugInformation.ml | 89 +++++++++++++++++++++++++++++++++++++++++------ debug/Dwarfgen.ml | 16 +++++++-- 6 files changed, 109 insertions(+), 13 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 4ed1ded3..b7012ef9 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1054,6 +1054,7 @@ let convertFundef loc env fd = if init <> None then unsupported "initialized local variable"; let id' = intern_string id.name in + Debug.atom_local_variable id id'; (id', convertTyp env ty)) fd.fd_locals in let body' = convertStmt loc env fd.fd_body in diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 6839ac9f..6c941a1f 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -2226,7 +2226,9 @@ and elab_block_body env ctx sl = | DEFINITION def :: sl1 -> let (dcl, env') = elab_definition true env def in let loc = elab_loc (get_definitionloc def) in - List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl + List.map (fun ((sto,id,ty,_) as d) -> + Debug.insert_local_declaration sto id ty loc; + {sdesc = Sdecl d; sloc = loc}) dcl @ elab_block_body env' ctx sl1 | s :: sl1 -> let s' = elab_stmt env ctx s in diff --git a/debug/Debug.ml b/debug/Debug.ml index c45fd074..bf3892d2 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,6 +30,8 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable atom_local_variable: ident -> atom -> unit; } let implem = @@ -44,6 +46,8 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); + insert_local_declaration = (fun _ _ _ _ -> ()); + atom_local_variable = (fun _ _ -> ()); } let init () = @@ -58,6 +62,8 @@ let init () = implem.add_fun_addr <- DebugInformation.add_fun_addr; implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + implem.insert_local_declaration <- DebugInformation.insert_local_declaration; + implem.atom_local_variable <- DebugInformation.atom_local_variable; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -69,6 +75,8 @@ let init () = implem.add_fun_addr <- (fun _ _ -> ()); implem.generate_debug_info <- (fun _ -> None); implem.all_files_iter <- (fun _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ -> ()); + implem.atom_local_variable <- (fun _ _ -> ()); end let init_compile_unit name = implem.init name @@ -81,3 +89,5 @@ let insert_global_declaration env dec = implem.insert_global_declaration env dec let add_fun_addr atom addr = implem.add_fun_addr atom addr let generate_debug_info () = implem.generate_debug_info () let all_files_iter f = implem.all_files_iter f +let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc +let atom_local_variable id atom = implem.atom_local_variable id atom diff --git a/debug/Debug.mli b/debug/Debug.mli index e712874c..69894ba7 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,3 +26,5 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit +val insert_local_declaration: storage -> ident -> typ -> location -> unit +val atom_local_variable: ident -> atom -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 100f37e2..38ce6e64 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -360,7 +360,6 @@ type function_information = { fun_return_type: int option; (* Again the special case of void functions *) fun_vararg: bool; fun_parameter: parameter_information list; - fun_locals: int list; fun_low_pc: int option; fun_high_pc: int option; } @@ -369,7 +368,8 @@ type definition_type = | GlobalVariable of global_variable_information | Function of function_information -(* All definitions encountered *) + +(* All global definitions encountered *) let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) @@ -378,7 +378,7 @@ let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 -let find_var_stamp id = +let find_gvar_stamp id = let id = (Hashtbl.find stamp_to_definition id) in let var = Hashtbl.find definitions id in match var with @@ -399,7 +399,6 @@ let find_fun_atom id = | Function f -> id,f | _ -> assert false - let replace_var id var = let var = GlobalVariable var in Hashtbl.replace definitions id var @@ -408,6 +407,45 @@ let replace_fun id f = let f = Function f in Hashtbl.replace definitions id f + +(* Information for local variables *) +type local_variable_information = { + lvar_name: string; + lvar_atom: atom option; + lvar_file_loc:location; + lvar_type: int; + lvar_static: bool; (* Static variable are mapped to symbols *) + } + +type scope_information = + { + scope_variables: int list; (* Variable and Scope ids *) + } + +type local_information = + | LocalVariable of local_variable_information + | Scope of scope_information + +(* All local variables *) +let local_variables: (int, local_information) Hashtbl.t = Hashtbl.create 7 + +(* Mapping from stampt to the debug id of the local variable *) +let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 + +(* Mapping form atom to the debug id of the local variable *) +let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 + +let find_lvar_stamp id = + let id = (Hashtbl.find stamp_to_local id) in + let v = Hashtbl.find local_variables id in + match v with + | LocalVariable v -> id,v + | _ -> assert false + +let replace_lvar id var = + let var = LocalVariable var in + Hashtbl.replace local_variables id var + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -440,7 +478,7 @@ let insert_global_declaration env dec= } in insert (GlobalVariable decl) id.stamp end else if init <> None || sto <> Storage_extern then begin (* It is a definition *) - let id,var = find_var_stamp id.stamp in + let id,var = find_gvar_stamp id.stamp in replace_var id ({var with gvar_declaration = false;}) end end @@ -467,7 +505,6 @@ let insert_global_declaration env dec= fun_return_type = ret; fun_vararg = f.fd_vararg; fun_parameter = params; - fun_locals = []; fun_low_pc = None; fun_high_pc = None; } in @@ -536,14 +573,13 @@ let set_bitfield_offset str field offset underlying size = let atom_global_variable id atom = try - let id,var = find_var_stamp id.stamp in + let id,var = find_gvar_stamp id.stamp in replace_var id ({var with gvar_atom = Some atom;}); Hashtbl.add atom_to_definition atom id with Not_found -> () let atom_function id atom = try - Printf.printf "Trying to add atom of function %s\n" id.name; let id,f = find_fun_stamp id.stamp in replace_fun id ({f with fun_atom = Some atom;}); Hashtbl.add atom_to_definition atom id @@ -553,7 +589,37 @@ let add_fun_addr atom (high,low) = try let id,f = find_fun_atom atom in replace_fun id ({f with fun_high_pc = Some high; fun_low_pc = Some low;}) - with Not_found -> Printf.printf "Could not find function %s\n" (extern_atom atom); () + with Not_found -> () + +let atom_local_variable id atom = + try + let id,var = find_lvar_stamp id.stamp in + replace_lvar id ({var with lvar_atom = Some atom;}); + Hashtbl.add atom_to_local atom id + with Not_found -> () + +let insert_local_declaration sto id ty loc = + let ty = find_type ty in + let var = { + lvar_name = id.name; + lvar_atom = None; + lvar_file_loc = loc; + lvar_type = ty; + lvar_static = sto = Storage_static; + } in + let id' = next_id () in + Hashtbl.add local_variables id' (LocalVariable var); + Hashtbl.add stamp_to_local id.stamp id' + +let scopes: (int * scope_information) Stack.t = Stack.create () + +let enter_scope id = + let empty_scope = {scope_variables = [];} in + Stack.push (id,empty_scope) scopes + +let enter_function_scope id = + Stack.clear scopes; + enter_scope id let init name = id := 0; @@ -562,5 +628,8 @@ let init name = Hashtbl.reset lookup_types; Hashtbl.reset definitions; Hashtbl.reset stamp_to_definition; - Hashtbl.reset atom_to_definition + Hashtbl.reset atom_to_definition; + Hashtbl.reset local_variables; + Hashtbl.reset stamp_to_local; + Hashtbl.reset atom_to_local diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 0acab05a..bb0ab5f2 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -217,6 +217,17 @@ let function_parameter_to_entry p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p) +let local_variable_to_entry v id = + let var = { + variable_file_loc = v.lvar_file_loc; + variable_declaration = None; + variable_external = None; + variable_name = v.lvar_name; + variable_type = v.lvar_type; + variable_location = None; + } in + new_entry id (DW_TAG_variable var) + let function_to_entry id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; @@ -228,8 +239,9 @@ let function_to_entry id f = subprogram_low_pc = f.fun_low_pc; } in let f_entry = new_entry id (DW_TAG_subprogram f_tag) in - let child = List.map function_parameter_to_entry f.fun_parameter in - add_children f_entry child + let params = List.map function_parameter_to_entry f.fun_parameter in +(* let vars = List.map local_variable_to_entry f.fun_locals in*) + add_children f_entry params let definition_to_entry id t = match t with -- cgit From 9147350fdb47f3471ce6d9202b7c996f79ffab2d Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 20 Sep 2015 15:23:38 +0200 Subject: Experiment: track the scopes of local variables via __builtin_debug. C2C: the code that insert debug builtins with the line numbers is now in Unblock. Handle calls to __builtin_debug. Unblock: generate __builtin_debug(1) for line numbers, carrying the list of active scopes as extra arguments. Generate __builtin_debug(6) for local variable declarations, carrying the corresponding scope number as extra argument. Constprop: avoid duplicating debug arguments that are constants already. PrintAsmaux: show this extra debug info as comments. --- backend/Constprop.v | 6 +- backend/Constpropproof.v | 6 +- backend/PrintAsmaux.ml | 5 ++ cfrontend/C2C.ml | 74 +++++++++++---------- cparser/Unblock.ml | 164 ++++++++++++++++++++++++++++++++++++++--------- 5 files changed, 181 insertions(+), 74 deletions(-) diff --git a/backend/Constprop.v b/backend/Constprop.v index cd844d30..8f4cb76d 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -144,9 +144,9 @@ Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) := | a :: al => let a' := builtin_arg_reduction ae a in let al' := a :: debug_strength_reduction ae al in - match a' with - | BA_int _ | BA_long _ | BA_float _ | BA_single _ => a' :: al' - | _ => al' + match a, a' with + | BA _, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => a' :: al' + | _, _ => al' end end. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index d9005f5e..eafefed5 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -243,7 +243,11 @@ Proof. induction 2; simpl. - exists (@nil val); constructor. - destruct IHlist_forall2 as (vl' & A). - destruct (builtin_arg_reduction ae a1); repeat (eauto; econstructor). + assert (eval_builtin_args ge (fun r => rs#r) sp m + (a1 :: debug_strength_reduction ae al) (b1 :: vl')) + by (constructor; eauto). + destruct a1; try (econstructor; eassumption). + destruct (builtin_arg_reduction ae (BA x)); repeat (eauto; econstructor). Qed. Lemma builtin_strength_reduction_correct: diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 67e53aea..13daa644 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -269,6 +269,8 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args = args in match kind with | 1 -> (* line number *) + fprintf oc "%s debug: current scopes%a\n" + comment print_debug_args args; if Str.string_match re_file_line txt 0 then print_line oc (Str.matched_group 1 txt) (int_of_string (Str.matched_group 2 txt)) @@ -283,6 +285,9 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args = | 5 -> (* local variable preallocated in stack *) fprintf oc "%s debug: %s resides at%a\n" comment txt print_debug_args args + | 6 -> (* declaration of a local variable *) + fprintf oc "%s debug: %s declared in scope%a\n" + comment txt print_debug_args args | _ -> () diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 5cd5997d..f5e550f3 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -741,6 +741,22 @@ let rec convertExpr env e = | C.ECompound(ty1, ie) -> unsupported "compound literals"; ezero + | C.ECall({edesc = C.EVar {name = "__builtin_debug"}}, args) -> + let (kind, args1) = + match args with + | {edesc = C.EConst(CInt(n,_,_))} :: args1 -> (n, args1) + | _ -> error "ill_formed __builtin_debug"; (0L, args) in + let (text, args2) = + match args1 with + | {edesc = C.EConst(CStr(txt))} :: args2 -> (txt, args2) + | {edesc = C.EVar id} :: args2 -> (id.name, args2) + | _ -> error "ill_formed __builtin_debug"; ("", args1) in + let targs2 = convertTypArgs env [] args2 in + Ebuiltin( + EF_debug(P.of_int64 kind, intern_string text, + typlist_of_typelist targs2), + targs2, convertExprList env args2, convertTyp env e.etyp) + | C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) -> begin match args with | {edesc = C.EConst(CStr txt)} :: args1 -> @@ -922,16 +938,6 @@ let rec contains_case s = (** Annotations for line numbers *) -let add_lineno prev_loc this_loc s = - if !Clflags.option_g && prev_loc <> this_loc && this_loc <> Cutil.no_loc - then begin - let txt = sprintf "#line:%s:%d" (fst this_loc) (snd this_loc) in - Ssequence(Sdo(Ebuiltin(EF_debug(P.one, intern_string txt, []), - Tnil, Enil, Tvoid)), - s) - end else - s - (** Statements *) let swrap = function @@ -939,36 +945,31 @@ let swrap = function | Errors.Error msg -> error ("retyping error: " ^ string_of_errmsg msg); Sskip -let rec convertStmt ploc env s = +let rec convertStmt env s = updateLoc s.sloc; match s.sdesc with | C.Sskip -> Sskip | C.Sdo e -> - add_lineno ploc s.sloc (swrap (Ctyping.sdo (convertExpr env e))) + swrap (Ctyping.sdo (convertExpr env e)) | C.Sseq(s1, s2) -> - let s1' = convertStmt ploc env s1 in - let s2' = convertStmt s1.sloc env s2 in + let s1' = convertStmt env s1 in + let s2' = convertStmt env s2 in Ssequence(s1', s2') | C.Sif(e, s1, s2) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sifthenelse te - (convertStmt s.sloc env s1) (convertStmt s.sloc env s2))) + swrap (Ctyping.sifthenelse te (convertStmt env s1) (convertStmt env s2)) | C.Swhile(e, s1) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.swhile te (convertStmt s.sloc env s1))) + swrap (Ctyping.swhile te (convertStmt env s1)) | C.Sdowhile(s1, e) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sdowhile te (convertStmt s.sloc env s1))) + swrap (Ctyping.sdowhile te (convertStmt env s1)) | C.Sfor(s1, e, s2, s3) -> let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sfor - (convertStmt s.sloc env s1) te - (convertStmt s.sloc env s2) (convertStmt s.sloc env s3))) + swrap (Ctyping.sfor + (convertStmt env s1) te + (convertStmt env s2) (convertStmt env s3)) | C.Sbreak -> Sbreak | C.Scontinue -> @@ -981,22 +982,20 @@ let rec convertStmt ploc env s = contains_case init end; let te = convertExpr env e in - add_lineno ploc s.sloc - (swrap (Ctyping.sswitch te - (convertSwitch s.sloc env (is_longlong env e.etyp) cases))) + swrap (Ctyping.sswitch te + (convertSwitch env (is_longlong env e.etyp) cases)) | C.Slabeled(C.Slabel lbl, s1) -> - add_lineno ploc s.sloc - (Slabel(intern_string lbl, convertStmt s.sloc env s1)) + Slabel(intern_string lbl, convertStmt env s1) | C.Slabeled(C.Scase _, _) -> unsupported "'case' outside of 'switch'"; Sskip | C.Slabeled(C.Sdefault, _) -> unsupported "'default' outside of 'switch'"; Sskip | C.Sgoto lbl -> - add_lineno ploc s.sloc (Sgoto(intern_string lbl)) + Sgoto(intern_string lbl) | C.Sreturn None -> - add_lineno ploc s.sloc (Sreturn None) + Sreturn None | C.Sreturn(Some e) -> - add_lineno ploc s.sloc (Sreturn(Some(convertExpr env e))) + Sreturn(Some(convertExpr env e)) | C.Sblock _ -> unsupported "nested blocks"; Sskip | C.Sdecl _ -> @@ -1004,10 +1003,9 @@ let rec convertStmt ploc env s = | C.Sasm(attrs, txt, outputs, inputs, clobber) -> if not !Clflags.option_finline_asm then unsupported "inline 'asm' statement (consider adding option -finline-asm)"; - add_lineno ploc s.sloc - (Sdo (convertAsm s.sloc env txt outputs inputs clobber)) + Sdo (convertAsm s.sloc env txt outputs inputs clobber) -and convertSwitch ploc env is_64 = function +and convertSwitch env is_64 = function | [] -> LSnil | (lbl, s) :: rem -> @@ -1024,7 +1022,7 @@ and convertSwitch ploc env is_64 = function then Z.of_uint64 v else Z.of_uint32 (Int64.to_int32 v)) in - LScons(lbl', convertStmt ploc env s, convertSwitch s.sloc env is_64 rem) + LScons(lbl', convertStmt env s, convertSwitch env is_64 rem) (** Function definitions *) @@ -1049,7 +1047,7 @@ let convertFundef loc env fd = unsupported "initialized local variable"; (intern_string id.name, convertTyp env ty)) fd.fd_locals in - let body' = convertStmt loc env fd.fd_body in + let body' = convertStmt env fd.fd_body in let id' = intern_string fd.fd_name.name in Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index 91f50552..b5f945d4 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -177,74 +177,173 @@ and expand_init islocal env i = in expand i +(* Insertion of debug annotation, for -g mode *) + +let debug_id = Env.fresh_ident "__builtin_debug" +let debug_ty = + TFun(TVoid [], Some [Env.fresh_ident "kind", TInt(IInt, [])], true, []) + +let debug_annot kind args = + { sloc = no_loc; + sdesc = Sdo { + etyp = TVoid []; + edesc = ECall({edesc = EVar debug_id; etyp = debug_ty}, + intconst kind IInt :: args) + } + } + +let string_const str = + let c = CStr str in { edesc = EConst c; etyp = type_of_constant c } + +let integer_const n = + intconst (Int64.of_int n) IInt + +(* Line number annotation: + __builtin_debug(1, "#line:filename:lineno", scope1, ..., scopeN) *) +(* TODO: consider + __builtin_debug(1, "filename", lineno, scope1, ..., scopeN) + instead. *) + +let debug_lineno ctx (filename, lineno) = + debug_annot 1L + (string_const (Printf.sprintf "#line:%s:%d" filename lineno) :: + List.rev_map integer_const ctx) + +let add_lineno ctx prev_loc this_loc s = + if !Clflags.option_g && this_loc <> prev_loc && this_loc <> no_loc + then sseq no_loc (debug_lineno ctx this_loc) s + else s + +(* Variable declaration annotation: + __builtin_debug(6, var, scope) *) + +let debug_var_decl ctx id ty = + let scope = match ctx with [] -> 0 | sc :: _ -> sc in + debug_annot 6L + [ {edesc = EVar id; etyp = ty}; integer_const scope ] + +let add_var_decl ctx id ty s = + if !Clflags.option_g + then sseq no_loc (debug_var_decl ctx id ty) s + else s + +let add_param_decls params body = + if !Clflags.option_g then + List.fold_right + (fun (id, ty) s -> sseq no_loc (debug_var_decl [] id ty) s) + params body + else body + +(* Generate fresh scope identifiers, for blocks that contain at least + one declaration *) + +let block_contains_decl sl = + List.exists + (function {sdesc = Sdecl _} -> true | _ -> false) + sl + +let next_scope_id = ref 0 + +let new_scope_id () = + incr next_scope_id; !next_scope_id + (* Process a block-scoped variable declaration. The variable is entered in [local_variables]. The initializer, if any, is converted into assignments and prepended to [k]. *) -let process_decl loc env (sto, id, ty, optinit) k = +let process_decl loc env ctx (sto, id, ty, optinit) k = let ty' = remove_const env ty in local_variables := (sto, id, ty', None) :: !local_variables; - match optinit with - | None -> k - | Some init -> - let init' = expand_init true env init in - let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in - add_inits_stmt loc l k + add_var_decl ctx id ty + (match optinit with + | None -> + k + | Some init -> + let init' = expand_init true env init in + let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in + add_inits_stmt loc l k) (* Simplification of blocks within a statement *) -let rec unblock_stmt env s = +let rec unblock_stmt env ctx ploc s = match s.sdesc with | Sskip -> s | Sdo e -> - {s with sdesc = Sdo(expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdo(expand_expr true env e)} | Sseq(s1, s2) -> - {s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)} + {s with sdesc = Sseq(unblock_stmt env ctx ploc s1, + unblock_stmt env ctx s1.sloc s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(expand_expr true env e, - unblock_stmt env s1, unblock_stmt env s2)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sif(expand_expr true env e, + unblock_stmt env ctx s.sloc s1, + unblock_stmt env ctx s.sloc s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Swhile(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(unblock_stmt env s1, expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdowhile(unblock_stmt env ctx s.sloc s1, + expand_expr true env e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(unblock_stmt env s1, - expand_expr true env e, - unblock_stmt env s2, - unblock_stmt env s3)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sfor(unblock_stmt env ctx s.sloc s1, + expand_expr true env e, + unblock_stmt env ctx s.sloc s2, + unblock_stmt env ctx s.sloc s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sswitch(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Slabeled(lbl, s1) -> - {s with sdesc = Slabeled(lbl, unblock_stmt env s1)} - | Sgoto lbl -> s - | Sreturn None -> s + add_lineno ctx ploc s.sloc + {s with sdesc = Slabeled(lbl, unblock_stmt env ctx s.sloc s1)} + | Sgoto lbl -> + add_lineno ctx ploc s.sloc s + | Sreturn None -> + add_lineno ctx ploc s.sloc s | Sreturn (Some e) -> - {s with sdesc = Sreturn(Some (expand_expr true env e))} - | Sblock sl -> unblock_block env sl - | Sdecl d -> assert false + add_lineno ctx ploc s.sloc + {s with sdesc = Sreturn(Some (expand_expr true env e))} + | Sblock sl -> + let ctx' = + if block_contains_decl sl + then new_scope_id () :: ctx + else ctx in + unblock_block env ctx' ploc sl + | Sdecl d -> + assert false | Sasm(attr, template, outputs, inputs, clob) -> let expand_asm_operand (lbl, cstr, e) = (lbl, cstr, expand_expr true env e) in - {s with sdesc = Sasm(attr, template, - List.map expand_asm_operand outputs, - List.map expand_asm_operand inputs, clob)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sasm(attr, template, + List.map expand_asm_operand outputs, + List.map expand_asm_operand inputs, clob)} -and unblock_block env = function +and unblock_block env ctx ploc = function | [] -> sskip | {sdesc = Sdecl d; sloc = loc} :: sl -> - process_decl loc env d (unblock_block env sl) + add_lineno ctx ploc loc + (process_decl loc env ctx d + (unblock_block env ctx loc sl)) | s :: sl -> - sseq s.sloc (unblock_stmt env s) (unblock_block env sl) + sseq s.sloc (unblock_stmt env ctx ploc s) + (unblock_block env ctx s.sloc sl) (* Simplification of blocks and compound literals within a function *) let unblock_fundef env f = local_variables := []; - let body = unblock_stmt env f.fd_body in + next_scope_id := 0; + let body = + add_param_decls f.fd_params (unblock_stmt env [] no_loc f.fd_body) in let decls = !local_variables in local_variables := []; { f with fd_locals = f.fd_locals @ decls; fd_body = body } @@ -299,4 +398,5 @@ let rec unblock_glob env accu = function (* Entry point *) let program p = + {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} :: unblock_glob (Builtins.environment()) [] p -- cgit From a34b64ee2e7a535ebc0fc731243ab520c4ba430f Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 20 Sep 2015 15:36:42 +0200 Subject: New version of adding scopes etc. Instead of reimplementing the whole scope handling in the debug information use the existing functionality and fill the scopes explicitly in the functions. --- cparser/Elab.ml | 2 +- debug/Debug.ml | 18 ++++++++++++---- debug/Debug.mli | 4 +++- debug/DebugInformation.ml | 55 ++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 63 insertions(+), 16 deletions(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 6c941a1f..e802085d 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -2227,7 +2227,7 @@ and elab_block_body env ctx sl = let (dcl, env') = elab_definition true env def in let loc = elab_loc (get_definitionloc def) in List.map (fun ((sto,id,ty,_) as d) -> - Debug.insert_local_declaration sto id ty loc; + Debug.insert_local_declaration (-1) sto id ty loc;(* Dummy scope *) {sdesc = Sdecl d; sloc = loc}) dcl @ elab_block_body env' ctx sl1 | s :: sl1 -> diff --git a/debug/Debug.ml b/debug/Debug.ml index bf3892d2..10b4e68f 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,8 +30,10 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable insert_local_declaration: int -> storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; + mutable enter_scope: int -> int -> unit; + mutable enter_function_scope: ident -> int -> unit; } let implem = @@ -46,8 +48,10 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); - insert_local_declaration = (fun _ _ _ _ -> ()); + insert_local_declaration = (fun _ _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); + enter_scope = (fun _ _ -> ()); + enter_function_scope = (fun _ _ -> ()); } let init () = @@ -64,6 +68,8 @@ let init () = implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); implem.insert_local_declaration <- DebugInformation.insert_local_declaration; implem.atom_local_variable <- DebugInformation.atom_local_variable; + implem.enter_scope <- DebugInformation.enter_scope; + implem.enter_function_scope <- DebugInformation.enter_function_scope; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -75,8 +81,10 @@ let init () = implem.add_fun_addr <- (fun _ _ -> ()); implem.generate_debug_info <- (fun _ -> None); implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ -> ()); + implem.enter_function_scope <- (fun _ _ -> ()); end let init_compile_unit name = implem.init name @@ -89,5 +97,7 @@ let insert_global_declaration env dec = implem.insert_global_declaration env dec let add_fun_addr atom addr = implem.add_fun_addr atom addr let generate_debug_info () = implem.generate_debug_info () let all_files_iter f = implem.all_files_iter f -let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc +let insert_local_declaration scope sto id ty loc = implem.insert_local_declaration scope sto id ty loc let atom_local_variable id atom = implem.atom_local_variable id atom +let enter_scope p_id id = implem.enter_scope p_id id +let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id diff --git a/debug/Debug.mli b/debug/Debug.mli index 69894ba7..087f073f 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,5 +26,7 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit -val insert_local_declaration: storage -> ident -> typ -> location -> unit +val insert_local_declaration: int -> storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit +val enter_scope: int -> int -> unit +val enter_function_scope: ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 38ce6e64..a85f2081 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -362,6 +362,7 @@ type function_information = { fun_parameter: parameter_information list; fun_low_pc: int option; fun_high_pc: int option; + fun_scope: int option; } type definition_type = @@ -435,6 +436,9 @@ let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 (* Mapping form atom to the debug id of the local variable *) let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 +(* Map from scope id to debug id *) +let scope_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 + let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in let v = Hashtbl.find local_variables id in @@ -446,6 +450,17 @@ let replace_lvar id var = let var = LocalVariable var in Hashtbl.replace local_variables id var +let find_scope_id id = + let id = (Hashtbl.find scope_to_local id) in + let v = Hashtbl.find local_variables id in + match v with + | Scope v -> id,v + | _ -> assert false + +let replace_scope id var = + let var = Scope var in + Hashtbl.replace local_variables id var + let gen_comp_typ sou id at = if sou = Struct then TStruct (id,at) @@ -507,6 +522,7 @@ let insert_global_declaration env dec= fun_parameter = params; fun_low_pc = None; fun_high_pc = None; + fun_scope = None; } in insert (Function fd) f.fd_name.stamp | Gcompositedecl (sou,id,at) -> @@ -598,7 +614,13 @@ let atom_local_variable id atom = Hashtbl.add atom_to_local atom id with Not_found -> () -let insert_local_declaration sto id ty loc = +let add_lvar_scope var_id s_id = + try + let s_id',scope = find_scope_id s_id in + replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) + with Not_found -> () + +let insert_local_declaration scope sto id ty loc = let ty = find_type ty in let var = { lvar_name = id.name; @@ -609,17 +631,29 @@ let insert_local_declaration sto id ty loc = } in let id' = next_id () in Hashtbl.add local_variables id' (LocalVariable var); - Hashtbl.add stamp_to_local id.stamp id' + Hashtbl.add stamp_to_local id.stamp id'; + add_lvar_scope id' scope -let scopes: (int * scope_information) Stack.t = Stack.create () +let new_scope sc_id = + let scope = {scope_variables = [];} in + let id = next_id () in + Hashtbl.add local_variables id (Scope scope); + Hashtbl.add scope_to_local sc_id id; + id -let enter_scope id = - let empty_scope = {scope_variables = [];} in - Stack.push (id,empty_scope) scopes +let enter_function_scope fun_id sc_id = + try + let id = new_scope sc_id in + let fun_id,f = find_fun_stamp fun_id.stamp in + replace_fun id ({f with fun_scope = Some id}) + with Not_found -> () -let enter_function_scope id = - Stack.clear scopes; - enter_scope id +let enter_scope p_id id = + try + let id' = new_scope id in + let p_id',scope = find_scope_id p_id in + replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) + with Not_found -> () let init name = id := 0; @@ -631,5 +665,6 @@ let init name = Hashtbl.reset atom_to_definition; Hashtbl.reset local_variables; Hashtbl.reset stamp_to_local; - Hashtbl.reset atom_to_local + Hashtbl.reset atom_to_local; + Hashtbl.reset scope_to_local; -- cgit From d8aac95c8d1767bf3b10990599b0f32687994182 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 21 Sep 2015 14:45:28 +0200 Subject: Continuing experiment: track the scopes of local variables via __builtin_debug As observed by B. Schommer, it is not enough to track scopes for every source line, as blocks can occur on a single line (think macros). Hence: - Revert debug annotations of kind 1 to contain only line number info. Generate them only when the line number changes. - Use debug annotations of kind 6 to record the list of active scopes (as BA_int integer arguments to __builtin_annot). Generate them before every nontrivial statement, even if on the same line as others. - Remove the generation of "variable x is declared in scope N" debug annotations. This can be tracked separately and more efficiently. --- backend/PrintAsmaux.ml | 8 +++---- cparser/Unblock.ml | 62 +++++++++++++++++++++++--------------------------- 2 files changed, 31 insertions(+), 39 deletions(-) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 13daa644..a67c85d2 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -269,8 +269,6 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args = args in match kind with | 1 -> (* line number *) - fprintf oc "%s debug: current scopes%a\n" - comment print_debug_args args; if Str.string_match re_file_line txt 0 then print_line oc (Str.matched_group 1 txt) (int_of_string (Str.matched_group 2 txt)) @@ -285,9 +283,9 @@ let print_debug_info comment print_line print_preg sp_name oc kind txt args = | 5 -> (* local variable preallocated in stack *) fprintf oc "%s debug: %s resides at%a\n" comment txt print_debug_args args - | 6 -> (* declaration of a local variable *) - fprintf oc "%s debug: %s declared in scope%a\n" - comment txt print_debug_args args + | 6 -> (* scope annotations *) + fprintf oc "%s debug: current scopes%a\n" + comment print_debug_args args; | _ -> () diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index b5f945d4..bad5002b 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -199,40 +199,34 @@ let integer_const n = intconst (Int64.of_int n) IInt (* Line number annotation: - __builtin_debug(1, "#line:filename:lineno", scope1, ..., scopeN) *) + __builtin_debug(1, "#line:filename:lineno") *) (* TODO: consider - __builtin_debug(1, "filename", lineno, scope1, ..., scopeN) + __builtin_debug(1, "filename", lineno) instead. *) -let debug_lineno ctx (filename, lineno) = +let debug_lineno (filename, lineno) = debug_annot 1L - (string_const (Printf.sprintf "#line:%s:%d" filename lineno) :: - List.rev_map integer_const ctx) + [string_const (Printf.sprintf "#line:%s:%d" filename lineno)] -let add_lineno ctx prev_loc this_loc s = - if !Clflags.option_g && this_loc <> prev_loc && this_loc <> no_loc - then sseq no_loc (debug_lineno ctx this_loc) s - else s +(* Scope annotation: + __builtin_debug(6, "", scope1, scope2, ..., scopeN) +*) -(* Variable declaration annotation: - __builtin_debug(6, var, scope) *) +let empty_string = string_const "" -let debug_var_decl ctx id ty = - let scope = match ctx with [] -> 0 | sc :: _ -> sc in - debug_annot 6L - [ {edesc = EVar id; etyp = ty}; integer_const scope ] +let debug_scope ctx = + debug_annot 6L (empty_string :: List.rev_map integer_const ctx) -let add_var_decl ctx id ty s = - if !Clflags.option_g - then sseq no_loc (debug_var_decl ctx id ty) s - else s +(* Add line number debug annotation if the line number changes. + Add scope debug annotation regardless. *) -let add_param_decls params body = +let add_lineno ctx prev_loc this_loc s = if !Clflags.option_g then - List.fold_right - (fun (id, ty) s -> sseq no_loc (debug_var_decl [] id ty) s) - params body - else body + sseq no_loc (debug_scope ctx) + (if this_loc <> prev_loc && this_loc <> no_loc + then sseq no_loc (debug_lineno this_loc) s + else s) + else s (* Generate fresh scope identifiers, for blocks that contain at least one declaration *) @@ -255,14 +249,14 @@ let new_scope_id () = let process_decl loc env ctx (sto, id, ty, optinit) k = let ty' = remove_const env ty in local_variables := (sto, id, ty', None) :: !local_variables; - add_var_decl ctx id ty - (match optinit with - | None -> - k - | Some init -> - let init' = expand_init true env init in - let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in - add_inits_stmt loc l k) + (* TODO: register the fact that id is declared in scope ctx *) + match optinit with + | None -> + k + | Some init -> + let init' = expand_init true env init in + let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in + add_inits_stmt loc l k (* Simplification of blocks within a statement *) @@ -342,8 +336,8 @@ and unblock_block env ctx ploc = function let unblock_fundef env f = local_variables := []; next_scope_id := 0; - let body = - add_param_decls f.fd_params (unblock_stmt env [] no_loc f.fd_body) in + (* TODO: register the parameters as being declared in function scope *) + let body = unblock_stmt env [] no_loc f.fd_body in let decls = !local_variables in local_variables := []; { f with fd_locals = f.fd_locals @ decls; fd_body = body } -- cgit From d7f75509c290d871cb8cd8aa11a0be2923c9ef17 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 22 Sep 2015 19:44:47 +0200 Subject: Record the scope structure during unblocking. Instead of creating separate annotations for the local variables we call the Debug.add_lvar_scope and we construct a mapping from function id + scope id to scope information. --- arm/TargetPrinter.ml | 2 + backend/PrintAsmaux.ml | 1 + cparser/Cprint.ml | 6 ++- cparser/Cprint.mli | 1 + cparser/Elab.ml | 2 +- cparser/Unblock.ml | 20 ++++---- debug/Debug.ml | 19 +++++--- debug/Debug.mli | 5 +- debug/DebugInformation.ml | 39 ++++++++-------- debug/DwarfPrinter.ml | 12 ++--- debug/DwarfTypes.mli | 4 +- debug/Dwarfgen.ml | 117 +++++++++++++++++++++++++++++++++++++++------- ia32/TargetPrinter.ml | 2 + powerpc/TargetPrinter.ml | 8 ++++ 14 files changed, 173 insertions(+), 65 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 028ff6ed..5f16fc9e 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -905,6 +905,8 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = let get_end_addr () = -1 (* Dummy constant *) let get_stmt_list_addr () = -1 (* Dummy constant *) + + let get_debug_start_addr () = -1 (* Dummy constant *) module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index ed0fe524..a0474003 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -48,6 +48,7 @@ module type TARGET = val get_start_addr: unit -> int val get_end_addr: unit -> int val get_stmt_list_addr: unit -> int + val get_debug_start_addr: unit -> int val new_label: unit -> int val label: out_channel -> int -> unit val print_file_loc: out_channel -> file_loc -> unit diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml index 4ceaa016..1af5af1e 100644 --- a/cparser/Cprint.ml +++ b/cparser/Cprint.ml @@ -20,6 +20,8 @@ open C let print_idents_in_full = ref false +let print_debug_idents = ref false + let print_line_numbers = ref false let location pp (file, lineno) = @@ -27,7 +29,9 @@ let location pp (file, lineno) = fprintf pp "# %d \"%s\"@ " lineno file let ident pp i = - if !print_idents_in_full + if !print_debug_idents + then fprintf pp "$%d" i.stamp + else if !print_idents_in_full then fprintf pp "%s$%d" i.name i.stamp else fprintf pp "%s" i.name diff --git a/cparser/Cprint.mli b/cparser/Cprint.mli index d63e341c..349b5f9a 100644 --- a/cparser/Cprint.mli +++ b/cparser/Cprint.mli @@ -15,6 +15,7 @@ val print_idents_in_full : bool ref val print_line_numbers : bool ref +val print_debug_idents : bool ref val location : Format.formatter -> C.location -> unit val attributes : Format.formatter -> C.attributes -> unit diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 021dc512..33c4822d 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -2227,7 +2227,7 @@ and elab_block_body env ctx sl = let (dcl, env') = elab_definition true env def in let loc = elab_loc (get_definitionloc def) in List.map (fun ((sto,id,ty,_) as d) -> - Debug.insert_local_declaration (-1) sto id ty loc;(* Dummy scope *) + Debug.insert_local_declaration sto id ty loc; {sdesc = Sdecl d; sloc = loc}) dcl @ elab_block_body env' ctx sl1 | s :: sl1 -> diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index b5f945d4..4f5056bb 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -217,8 +217,11 @@ let add_lineno ctx prev_loc this_loc s = (* Variable declaration annotation: __builtin_debug(6, var, scope) *) +let curr_fun_id = ref 0 + let debug_var_decl ctx id ty = let scope = match ctx with [] -> 0 | sc :: _ -> sc in + Debug.add_lvar_scope !curr_fun_id id scope; debug_annot 6L [ {edesc = EVar id; etyp = ty}; integer_const scope ] @@ -227,13 +230,6 @@ let add_var_decl ctx id ty s = then sseq no_loc (debug_var_decl ctx id ty) s else s -let add_param_decls params body = - if !Clflags.option_g then - List.fold_right - (fun (id, ty) s -> sseq no_loc (debug_var_decl [] id ty) s) - params body - else body - (* Generate fresh scope identifiers, for blocks that contain at least one declaration *) @@ -313,7 +309,10 @@ let rec unblock_stmt env ctx ploc s = | Sblock sl -> let ctx' = if block_contains_decl sl - then new_scope_id () :: ctx + then + let id = new_scope_id () in + Debug.enter_scope !curr_fun_id (List.hd ctx) id; + id:: ctx else ctx in unblock_block env ctx' ploc sl | Sdecl d -> @@ -342,8 +341,11 @@ and unblock_block env ctx ploc = function let unblock_fundef env f = local_variables := []; next_scope_id := 0; + curr_fun_id := f.fd_name.stamp; + let id = new_scope_id () in + Debug.enter_function_scope f.fd_name id; let body = - add_param_decls f.fd_params (unblock_stmt env [] no_loc f.fd_body) in + (unblock_stmt env [id] no_loc f.fd_body) in let decls = !local_variables in local_variables := []; { f with fd_locals = f.fd_locals @ decls; fd_body = body } diff --git a/debug/Debug.ml b/debug/Debug.ml index 10b4e68f..eb616dab 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,10 +30,11 @@ type implem = mutable add_fun_addr: atom -> (int * int) -> unit; mutable generate_debug_info: unit -> dw_entry option; mutable all_files_iter: (string -> unit) -> unit; - mutable insert_local_declaration: int -> storage -> ident -> typ -> location -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; - mutable enter_scope: int -> int -> unit; + mutable enter_scope: int -> int -> int -> unit; mutable enter_function_scope: ident -> int -> unit; + mutable add_lvar_scope: int -> ident -> int -> unit; } let implem = @@ -48,10 +49,11 @@ let implem = add_fun_addr = (fun _ _ -> ()); generate_debug_info = (fun _ -> None); all_files_iter = (fun _ -> ()); - insert_local_declaration = (fun _ _ _ _ _ -> ()); + insert_local_declaration = (fun _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); - enter_scope = (fun _ _ -> ()); + enter_scope = (fun _ _ _ -> ()); enter_function_scope = (fun _ _ -> ()); + add_lvar_scope = (fun _ _ _ -> ()); } let init () = @@ -70,6 +72,7 @@ let init () = implem.atom_local_variable <- DebugInformation.atom_local_variable; implem.enter_scope <- DebugInformation.enter_scope; implem.enter_function_scope <- DebugInformation.enter_function_scope; + implem.add_lvar_scope <- DebugInformation.add_lvar_scope; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -81,10 +84,11 @@ let init () = implem.add_fun_addr <- (fun _ _ -> ()); implem.generate_debug_info <- (fun _ -> None); implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); - implem.enter_scope <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ _ -> ()); implem.enter_function_scope <- (fun _ _ -> ()); + implem.add_lvar_scope <- (fun _ _ _ -> ()); end let init_compile_unit name = implem.init name @@ -97,7 +101,8 @@ let insert_global_declaration env dec = implem.insert_global_declaration env dec let add_fun_addr atom addr = implem.add_fun_addr atom addr let generate_debug_info () = implem.generate_debug_info () let all_files_iter f = implem.all_files_iter f -let insert_local_declaration scope sto id ty loc = implem.insert_local_declaration scope sto id ty loc +let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc let atom_local_variable id atom = implem.atom_local_variable id atom let enter_scope p_id id = implem.enter_scope p_id id let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id +let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id diff --git a/debug/Debug.mli b/debug/Debug.mli index 087f073f..a7d40382 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,7 +26,8 @@ val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit -val insert_local_declaration: int -> storage -> ident -> typ -> location -> unit +val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit -val enter_scope: int -> int -> unit +val enter_scope: int -> int -> int -> unit val enter_function_scope: ident -> int -> unit +val add_lvar_scope: int -> ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index a85f2081..d8d608af 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -136,10 +136,9 @@ let lookup_types: (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 - let old = !Cprint.print_idents_in_full in - Cprint.print_idents_in_full := true; + Cprint.print_debug_idents := true; Cprint.typ chan ty; - Cprint.print_idents_in_full := old; + Cprint.print_debug_idents := false; Format.pp_print_flush chan (); Buffer.contents buf @@ -436,8 +435,10 @@ let stamp_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 (* Mapping form atom to the debug id of the local variable *) let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 -(* Map from scope id to debug id *) -let scope_to_local: (int,int) Hashtbl.t = Hashtbl.create 7 +(* Map from scope id + function id to debug id *) +let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 + +(* Map from scope id + function atom to debug id *) let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -450,8 +451,8 @@ let replace_lvar id var = let var = LocalVariable var in Hashtbl.replace local_variables id var -let find_scope_id id = - let id = (Hashtbl.find scope_to_local id) in +let find_scope_id fid id = + let id = Hashtbl.find scope_to_local (fid,id) in let v = Hashtbl.find local_variables id in match v with | Scope v -> id,v @@ -614,14 +615,15 @@ let atom_local_variable id atom = Hashtbl.add atom_to_local atom id with Not_found -> () -let add_lvar_scope var_id s_id = +let add_lvar_scope f_id var_id s_id = try - let s_id',scope = find_scope_id s_id in + let s_id',scope = find_scope_id f_id s_id in + let var_id,_ = find_lvar_stamp var_id.stamp in replace_scope s_id' ({scope_variables = var_id::scope.scope_variables;}) with Not_found -> () -let insert_local_declaration scope sto id ty loc = - let ty = find_type ty in +let insert_local_declaration sto id ty loc = + let ty = insert_type ty in let var = { lvar_name = id.name; lvar_atom = None; @@ -631,27 +633,26 @@ let insert_local_declaration scope sto id ty loc = } in let id' = next_id () in Hashtbl.add local_variables id' (LocalVariable var); - Hashtbl.add stamp_to_local id.stamp id'; - add_lvar_scope id' scope + Hashtbl.add stamp_to_local id.stamp id' -let new_scope sc_id = +let new_scope f_id sc_id = let scope = {scope_variables = [];} in let id = next_id () in Hashtbl.add local_variables id (Scope scope); - Hashtbl.add scope_to_local sc_id id; + Hashtbl.add scope_to_local (f_id,sc_id) id; id let enter_function_scope fun_id sc_id = try - let id = new_scope sc_id in + let id = new_scope fun_id.stamp sc_id in let fun_id,f = find_fun_stamp fun_id.stamp in replace_fun id ({f with fun_scope = Some id}) with Not_found -> () -let enter_scope p_id id = +let enter_scope f_id p_id id = try - let id' = new_scope id in - let p_id',scope = find_scope_id p_id in + let id' = new_scope f_id id in + let p_id',scope = find_scope_id f_id p_id in replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 5e58e365..f3cfdc6e 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -132,10 +132,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): prologue 0xa; add_low_pc buf; add_name buf; - | DW_TAG_lexical_block _ -> + | DW_TAG_lexical_block a -> prologue 0xb; - add_high_pc buf; - add_low_pc buf + add_attr_some a.lexical_block_high_pc add_high_pc; + add_attr_some a.lexical_block_low_pc add_low_pc | DW_TAG_member e -> prologue 0xd; add_attr_some e.member_file_loc add_file_loc; @@ -373,8 +373,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_string oc tl.label_name let print_lexical_block oc lb = - print_ref oc lb.lexical_block_high_pc; - print_ref oc lb.lexical_block_low_pc + print_opt_value oc lb.lexical_block_high_pc print_ref; + print_opt_value oc lb.lexical_block_low_pc print_ref let print_member oc mb = print_file_loc oc mb.member_file_loc; @@ -488,7 +488,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_abbrev oc (* Print the debug info section *) - let print_debug_info oc entry = + let print_debug_info oc entry = let debug_start = new_label () in debug_start_addr:= debug_start; fprintf oc" .section %s\n" (name_of_section Section_debug_info); diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index b5be3121..1d41403b 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -114,8 +114,8 @@ type dw_tag_label = type dw_tag_lexical_block = { - lexical_block_high_pc: address; - lexical_block_low_pc: address; + lexical_block_high_pc: address option; + lexical_block_low_pc: address option; } type dw_tag_member = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index bb0ab5f2..8e29fcaf 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -22,6 +22,19 @@ let get_opt_val = function | Some a -> a | None -> assert false +(* Auxiliary data structures and functions *) +module IntSet = Set.Make(struct + type t = int + let compare (x:int) (y:int) = compare x y +end) + +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) + (* Functions to translate the basetypes. *) let int_type_to_entry id i = let encoding = @@ -146,7 +159,10 @@ let member_to_entry mem = member_byte_size = mem.cfd_byte_size; member_bit_offset = mem.cfd_bit_offset; member_bit_size = mem.cfd_bit_size; - member_data_member_location = Some (DataLocBlock [DW_OP_plus_uconst (get_opt_val mem.cfd_byte_offset)]); + member_data_member_location = + (match mem.cfd_byte_offset with + | None -> None + | Some s -> Some (DataLocBlock [DW_OP_plus_uconst s])); member_declaration = None; member_name = Some (mem.cfd_name); member_type = mem.cfd_typ; @@ -193,10 +209,57 @@ let infotype_to_entry id = function | VolatileType v -> volatile_to_entry id v | Void -> void_to_entry id -let gen_types () = - List.rev (Hashtbl.fold (fun id t acc -> (infotype_to_entry id t)::acc) types []) +let needs_types id d = + let add_type id d = + if not (IntSet.mem id d) then + IntSet.add id d,true + else + d,false in + let t = Hashtbl.find types id in + match t with + | IntegerType _ + | FloatType _ + | Void + | EnumType _ -> d,false + | Typedef t -> + add_type (get_opt_val t.typ) d + | PointerType p -> + add_type p.pts d + | ArrayType arr -> + add_type arr.arr_type d + | ConstType c -> + add_type c.cst_type d + | VolatileType v -> + add_type v.vol_type d + | FunctionType f -> + let d,c = match f.fun_return_type with + | Some t -> add_type t d + | None -> d,false in + List.fold_left (fun (d,c) p -> + let d,c' = add_type p.param_type d in + d,c||c') (d,c) f.fun_params + | CompositeType c -> + List.fold_left (fun (d,c) f -> + let d,c' = add_type f.cfd_typ d in + d,c||c') (d,false) c.ct_members + +let gen_types needed = + let rec aux d = + let d,c = IntSet.fold (fun id (d,c) -> + let d,c' = needs_types id d in + d,c||c') d (d,false) in + if c then + aux d + else + d in + 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 + else + acc) types []) -let global_variable_to_entry id v = +let global_variable_to_entry acc id v = let var = { variable_file_loc = v.gvar_file_loc; variable_declaration = Some v.gvar_declaration; @@ -205,9 +268,9 @@ let global_variable_to_entry id v = variable_type = v.gvar_type; variable_location = match v.gvar_atom with Some a -> Some (LocSymbol a) | None -> None; } in - new_entry id (DW_TAG_variable var) + new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc -let function_parameter_to_entry p = +let function_parameter_to_entry acc p = let p = { formal_parameter_file_loc = None; formal_parameter_artificial = None; @@ -215,9 +278,9 @@ let function_parameter_to_entry p = formal_parameter_type = p.parameter_type; formal_parameter_variable_parameter = None; } in - new_entry (next_id ()) (DW_TAG_formal_parameter p) + new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let local_variable_to_entry v id = +let rec local_variable_to_entry acc v id = let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -226,9 +289,23 @@ let local_variable_to_entry v id = variable_type = v.lvar_type; variable_location = None; } in - new_entry id (DW_TAG_variable var) + new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc + +and scope_to_entry acc sc id = + let scope = { + lexical_block_high_pc = None; + lexical_block_low_pc = None; + } in + let vars,acc = mmap local_to_entry 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 acc id = + match Hashtbl.find local_variables id with + | LocalVariable v -> local_variable_to_entry acc v id + | Scope v -> scope_to_entry acc v id -let function_to_entry id f = +let function_to_entry acc id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -238,22 +315,26 @@ let function_to_entry id f = subprogram_high_pc = f.fun_high_pc; subprogram_low_pc = f.fun_low_pc; } in - let f_entry = new_entry id (DW_TAG_subprogram f_tag) in - let params = List.map function_parameter_to_entry f.fun_parameter in + 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 = mmap function_parameter_to_entry acc f.fun_parameter in (* let vars = List.map local_variable_to_entry f.fun_locals in*) - add_children f_entry params + add_children f_entry params,acc -let definition_to_entry id t = +let definition_to_entry acc id t = match t with - | GlobalVariable g -> global_variable_to_entry id g - | Function f -> function_to_entry id f + | GlobalVariable g -> global_variable_to_entry acc id g + | Function f -> function_to_entry acc id f let gen_defs () = - List.rev (Hashtbl.fold (fun id t acc -> (definition_to_entry id t)::acc) definitions []) + let defs,typ = 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 let gen_debug_info () = let cp = { compile_unit_name = !file_name; } in let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in - add_children cp ((gen_types ()) @ (gen_defs ())) + let defs,ty = gen_defs () in + add_children cp ((gen_types ty) @ defs) diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index d1e213e2..b06f6f97 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -770,6 +770,8 @@ module Target(System: SYSTEM):TARGET = let get_stmt_list_addr () = -1 (* Dummy constant *) + let get_debug_start_addr () = -1 (* Dummy constant *) + module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) let label = label diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 58117ee7..2faaf2e3 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -78,6 +78,8 @@ let end_addr = ref (-1) let stmt_list_addr = ref (-1) +let debug_start_addr = ref (-1) + let label = elf_label module Linux_System : SYSTEM = @@ -241,6 +243,9 @@ module Diab_System : SYSTEM = let label_start = new_label () in start_addr := label_start; fprintf oc "%a:\n" label label_start; + let d_start = new_label() in + debug_start_addr := d_start; + fprintf oc " .0byte %a\n" label d_start; fprintf oc " .d2_line_start .debug_line\n"; end @@ -284,6 +289,7 @@ module Diab_System : SYSTEM = fprintf oc " .section %s,,n\n" name; fprintf oc " .sectionlink .debug_line\n"; section oc sec; + fprintf oc " .0byte %a\n" label !debug_start_addr; fprintf oc " .d2_line_start %s\n" name end | _ -> () (* Only the case of a user section is interresting *) @@ -856,6 +862,8 @@ module Target (System : SYSTEM):TARGET = let get_stmt_list_addr () = !stmt_list_addr + let get_debug_start_addr () = !debug_start_addr + module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs let new_label = new_label -- cgit From b448fbba97c1008599610d0c9bc834881b9dc219 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 23 Sep 2015 16:49:13 +0200 Subject: Added support for printing local variables and fixed issue with .text Local variables are now added with bogus lexical scopes to reflect the actually lexical scopes. Also this commit fixes assembler problems of the das when a user section with the name ".text" is defined. --- cparser/Unblock.ml | 1 + debug/Debug.ml | 2 +- debug/Debug.mli | 2 +- debug/DebugInformation.ml | 8 +++++--- debug/Dwarfgen.ml | 16 +++++++++++++--- powerpc/TargetPrinter.ml | 9 ++++++--- 6 files changed, 27 insertions(+), 11 deletions(-) diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index ad4b5497..c6646b5c 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -255,6 +255,7 @@ let new_scope_id () = let process_decl loc env ctx (sto, id, ty, optinit) k = let ty' = remove_const env ty in local_variables := (sto, id, ty', None) :: !local_variables; + debug_var_decl ctx id; (* TODO: register the fact that id is declared in scope ctx *) match optinit with | None -> diff --git a/debug/Debug.ml b/debug/Debug.ml index eb616dab..c2b48618 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -33,7 +33,7 @@ type implem = mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; mutable enter_scope: int -> int -> int -> unit; - mutable enter_function_scope: ident -> int -> unit; + mutable enter_function_scope: int -> int -> unit; mutable add_lvar_scope: int -> ident -> int -> unit; } diff --git a/debug/Debug.mli b/debug/Debug.mli index a7d40382..1fabb943 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -29,5 +29,5 @@ val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit val enter_scope: int -> int -> int -> unit -val enter_function_scope: ident -> int -> unit +val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index d8d608af..ef8993ea 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -439,6 +439,7 @@ let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 (* Map from scope id + function atom to debug id *) +let atom_to_scope: (atom, int) Hashtbl.t = Hashtbl.create 7 let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -477,6 +478,7 @@ let insert_global_declaration env dec= in match dec.gdesc with | Gdecl (sto,id,ty,init) -> + Printf.printf "Entering information for %s\n" id.name; if not (is_function_type env ty) then begin if not (Hashtbl.mem stamp_to_definition id.stamp) then begin let at_decl,ext = (match sto with @@ -644,9 +646,9 @@ let new_scope f_id sc_id = let enter_function_scope fun_id sc_id = try - let id = new_scope fun_id.stamp sc_id in - let fun_id,f = find_fun_stamp fun_id.stamp in - replace_fun id ({f with fun_scope = Some id}) + let id = new_scope fun_id sc_id in + let fun_id,f = find_fun_stamp fun_id in + replace_fun fun_id ({f with fun_scope = Some id}) with Not_found -> () let enter_scope f_id p_id id = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 8e29fcaf..15c63b66 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -305,7 +305,17 @@ and local_to_entry acc id = | LocalVariable v -> local_variable_to_entry acc v id | Scope v -> scope_to_entry acc v id +let fun_scope_to_entries 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 acc sc.scope_variables + | _ -> assert false) + let function_to_entry acc id f = + Printf.printf "Generating information for %s with id %d\n" f.fun_name id; let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -318,8 +328,8 @@ let function_to_entry acc 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 = mmap function_parameter_to_entry acc f.fun_parameter in -(* let vars = List.map local_variable_to_entry f.fun_locals in*) - add_children f_entry params,acc + let vars,acc = fun_scope_to_entries acc f.fun_scope in + add_children f_entry (params@vars),acc let definition_to_entry acc id t = match t with @@ -327,7 +337,7 @@ let definition_to_entry acc id t = | Function f -> function_to_entry acc id f let gen_defs () = - let defs,typ = Hashtbl.fold (fun id t (acc,bcc) -> let t,bcc = definition_to_entry bcc id t in + let defs,typ = 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 diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 2faaf2e3..21181215 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -269,8 +269,11 @@ module Diab_System : SYSTEM = fprintf oc ".L%d: .d2filenum \"%s\"\n" label file); fprintf oc " .d2_line_end\n"; StringSet.iter (fun s -> - fprintf oc " %s\n" s; - fprintf oc " .d2_line_end\n") !additional_debug_sections + if s <> (name_of_section Section_text) then + begin + fprintf oc " %s\n" s; + fprintf oc " .d2_line_end\n" + end) !additional_debug_sections end let print_file_loc oc (file,col) = @@ -282,7 +285,7 @@ module Diab_System : SYSTEM = match sec with | Section_user (name,_,_) -> let sec_name = name_of_section sec in - if not (StringSet.mem sec_name !additional_debug_sections) then + if not (StringSet.mem sec_name !additional_debug_sections) && name <> ".text" then begin let name = ".debug_line"^name in additional_debug_sections := StringSet.add sec_name !additional_debug_sections; -- cgit From dccd211b1be1fd80f3804b0586286566c874d523 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 23 Sep 2015 19:45:44 +0200 Subject: Also convert the fun stamp + scope id to debug id Hashtable in an atom + scope id Hashtable. --- debug/DebugInformation.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index ef8993ea..80d71dfd 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -439,7 +439,7 @@ let atom_to_local: (atom, int) Hashtbl.t = Hashtbl.create 7 let scope_to_local: (int * int,int) Hashtbl.t = Hashtbl.create 7 (* Map from scope id + function atom to debug id *) -let atom_to_scope: (atom, int) Hashtbl.t = Hashtbl.create 7 +let atom_to_scope: (atom * int, int) Hashtbl.t = Hashtbl.create 7 let find_lvar_stamp id = let id = (Hashtbl.find stamp_to_local id) in @@ -599,9 +599,11 @@ let atom_global_variable id atom = let atom_function id atom = try - let id,f = find_fun_stamp id.stamp in - replace_fun id ({f with fun_atom = Some atom;}); - Hashtbl.add atom_to_definition atom id + let id',f = find_fun_stamp id.stamp in + replace_fun id' ({f with fun_atom = Some atom;}); + Hashtbl.add atom_to_definition atom id'; + Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then + Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local with Not_found -> () let add_fun_addr atom (high,low) = -- cgit From fc8afb9287ab7b1607e5a7d2a03b0078fd9867d0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Thu, 24 Sep 2015 20:11:48 +0200 Subject: Added placing labels for live ranges etc. In order to avoid the usage of too many labels we replace the debug statements during the Asmexpand phase. --- debug/Debug.ml | 27 ++++++++++++ debug/Debug.mli | 7 +++ debug/DebugInformation.ml | 17 +++++++- debug/Dwarfgen.ml | 1 - powerpc/Asmexpand.ml | 109 +++++++++++++++++++++++++++++++++++++++++++--- 5 files changed, 152 insertions(+), 9 deletions(-) diff --git a/debug/Debug.ml b/debug/Debug.ml index c2b48618..fba921e1 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -10,6 +10,8 @@ (* *) (* *********************************************************************) +open AST +open BinNums open C open Camlcoq open Dwarfgen @@ -35,6 +37,11 @@ type implem = mutable enter_scope: int -> int -> int -> unit; mutable enter_function_scope: int -> int -> unit; mutable add_lvar_scope: int -> ident -> int -> unit; + mutable open_scope: atom -> int -> positive -> unit; + mutable close_scope: atom -> int -> positive -> unit; + mutable start_live_range: atom -> positive -> string builtin_arg -> unit; + mutable end_live_range: atom -> positive -> unit; + mutable stack_variable: atom -> string builtin_arg -> unit } let implem = @@ -54,6 +61,11 @@ let implem = enter_scope = (fun _ _ _ -> ()); enter_function_scope = (fun _ _ -> ()); add_lvar_scope = (fun _ _ _ -> ()); + open_scope = (fun _ _ _ -> ()); + close_scope = (fun _ _ _ -> ()); + start_live_range = (fun _ _ _ -> ()); + end_live_range = (fun _ _ -> ()); + stack_variable = (fun _ _ -> ()); } let init () = @@ -73,6 +85,11 @@ let init () = implem.enter_scope <- DebugInformation.enter_scope; implem.enter_function_scope <- DebugInformation.enter_function_scope; implem.add_lvar_scope <- DebugInformation.add_lvar_scope; + implem.open_scope <- DebugInformation.open_scope; + implem.close_scope <- DebugInformation.close_scope; + implem.start_live_range <- DebugInformation.start_live_range; + implem.end_live_range <- DebugInformation.end_live_range; + implem.stack_variable <- DebugInformation.stack_variable; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -89,6 +106,11 @@ let init () = implem.enter_scope <- (fun _ _ _ -> ()); implem.enter_function_scope <- (fun _ _ -> ()); implem.add_lvar_scope <- (fun _ _ _ -> ()); + implem.open_scope <- (fun _ _ _ -> ()); + implem.close_scope <- (fun _ _ _ -> ()); + implem.start_live_range <- (fun _ _ _ -> ()); + implem.end_live_range <- (fun _ _ -> ()); + implem.stack_variable <- (fun _ _ -> ()); end let init_compile_unit name = implem.init name @@ -106,3 +128,8 @@ let atom_local_variable id atom = implem.atom_local_variable id atom let enter_scope p_id id = implem.enter_scope p_id id let enter_function_scope fun_id sc_id = implem.enter_function_scope fun_id sc_id let add_lvar_scope fun_id var_id s_id = implem.add_lvar_scope fun_id var_id s_id +let open_scope atom id lbl = implem.open_scope atom id lbl +let close_scope atom id lbl = implem.close_scope atom id lbl +let start_live_range atom lbl loc = implem.start_live_range atom lbl loc +let end_live_range atom lbl = implem.end_live_range atom lbl +let stack_variable atom loc = implem.stack_variable atom loc diff --git a/debug/Debug.mli b/debug/Debug.mli index 1fabb943..42a0cee7 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -10,9 +10,11 @@ (* *) (* *********************************************************************) +open AST open C open Camlcoq open DwarfTypes +open BinNums val init: unit -> unit @@ -31,3 +33,8 @@ val atom_local_variable: ident -> atom -> unit val enter_scope: int -> int -> int -> unit val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit +val open_scope: atom -> int -> positive -> unit +val close_scope: atom -> int -> positive -> unit +val start_live_range: atom -> positive -> string builtin_arg -> unit +val end_live_range: atom -> positive -> unit +val stack_variable: atom -> string builtin_arg -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 80d71dfd..f12853c9 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -478,7 +478,6 @@ let insert_global_declaration env dec= in match dec.gdesc with | Gdecl (sto,id,ty,init) -> - Printf.printf "Entering information for %s\n" id.name; if not (is_function_type env ty) then begin if not (Hashtbl.mem stamp_to_definition id.stamp) then begin let at_decl,ext = (match sto with @@ -660,6 +659,21 @@ let enter_scope f_id p_id id = replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () +let open_scope atom s_id lbl = + () + +let close_scope atom s_id lbl = + () + +let start_live_range atom lbl loc = + () + +let end_live_range atom lbl = + () + +let stack_variable atom loc = + () + let init name = id := 0; file_name := name; @@ -672,4 +686,3 @@ let init name = Hashtbl.reset stamp_to_local; Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; - diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 15c63b66..6c10b362 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -315,7 +315,6 @@ let fun_scope_to_entries acc id = | _ -> assert false) let function_to_entry acc id f = - Printf.printf "Generating information for %s with id %d\n" f.fun_name id; let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index b9fe1d7f..d4675e5f 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -512,7 +512,7 @@ let num_crbit = function | CRbit_3 -> 3 | CRbit_6 -> 6 -let expand_instruction instr = +let expand_instruction_simple instr = match instr with | Pallocframe(sz, ofs,retofs) -> let variadic = (!current_function).fn_sig.sig_cc.cc_vararg in @@ -586,22 +586,119 @@ let expand_instruction instr = | _ -> emit instr -let expand_function fn = +let preg_to_string p = + "" + +let rec translate_annot a = + match a with + | BA x -> BA (preg_to_string x) + | BA_int n -> BA_int n + | BA_long n -> BA_long n + | BA_float n -> BA_float n + | BA_single n -> BA_single n + | BA_loadstack (chunk,ofs) -> BA_loadstack (chunk,ofs) + | BA_addrstack ofs -> BA_addrstack ofs + | BA_loadglobal (chunk,id,ofs) -> BA_loadglobal (chunk,id,ofs) + | BA_addrglobal (id,ofs) -> BA_addrglobal (id,ofs) + | BA_splitlong (hi,lo) -> BA_splitlong (translate_annot hi,translate_annot lo) + +let expand_stack_loc txt = function + | [a] -> Debug.stack_variable txt (translate_annot a) + | _ -> assert false + +let expand_start_live_range txt lbl = function + | [a] -> Debug.start_live_range txt lbl (translate_annot a) + | _ -> assert false + +let expand_end_live_range = + Debug.end_live_range + +let expand_scope id lbl oldscopes newscopes = + let opening = List.filter (fun a -> List.mem a oldscopes) newscopes + and closing = List.filter (fun a -> List.mem a newscopes) oldscopes in + List.iter (fun i -> Debug.open_scope id i lbl) opening; + List.iter (fun i -> Debug.close_scope id i lbl) closing + +let expand_instruction id l = + let get_lbl = function + | None -> + let lbl = new_label () in + emit (Plabel lbl); + lbl + | Some lbl -> lbl in + let rec aux lbl scopes = function + | [] -> () + | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> + let kind = (P.to_int kind) in + begin + match kind with + | 1 -> + emit i; aux lbl scopes rest + | 2 -> + aux lbl scopes rest + | 3 -> + let lbl = get_lbl lbl in + expand_start_live_range txt lbl args; + aux (Some lbl) scopes rest + | 4 -> + let lbl = get_lbl lbl in + expand_end_live_range txt lbl; + aux (Some lbl) scopes rest + | 5 -> + expand_stack_loc txt args; + aux lbl scopes rest + | 6 -> + let lbl = get_lbl lbl in + let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in + expand_scope id lbl scopes scopes'; + aux (Some lbl) scopes' rest + | _ -> + emit i; aux None scopes rest + end + | i::rest -> expand_instruction_simple i; aux None scopes rest in + aux None [] l + + +let expand_function id fn = try set_current_function fn; - List.iter expand_instruction fn.fn_code; + if !Clflags.option_g then + expand_instruction id fn.fn_code + else + List.iter expand_instruction_simple fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) -let expand_fundef = function +let expand_fundef id = function | Internal f -> - begin match expand_function f with + begin match expand_function id f with | Errors.OK tf -> Errors.OK (Internal tf) | Errors.Error msg -> Errors.Error msg end | External ef -> Errors.OK (External ef) +let rec transform_partial_prog transfun p = + match p with + | [] -> Errors.OK [] + | (id,Gvar v)::l -> + (match transform_partial_prog transfun l with + | Errors.OK x -> Errors.OK ((id,Gvar v)::x) + | Errors.Error msg -> Errors.Error msg) + | (id,Gfun f)::l -> + (match transfun id f with + | Errors.OK tf -> + (match transform_partial_prog transfun l with + | Errors.OK x -> Errors.OK ((id,Gfun tf)::x) + | Errors.Error msg -> Errors.Error msg) + | Errors.Error msg -> + Errors.Error ((Errors.MSG (coqstring_of_camlstring "In function"))::((Errors.CTX + id) :: (Errors.MSG (coqstring_of_camlstring ": ") :: msg)))) + let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program expand_fundef p + match transform_partial_prog expand_fundef p.prog_defs with + | Errors.OK x-> + Errors.OK { prog_defs = x; prog_public = p.prog_public; prog_main = + p.prog_main } + | Errors.Error msg -> Errors.Error msg -- cgit From aff813685455559f6d6a88158dd3d605893ba3a3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 25 Sep 2015 16:43:18 +0200 Subject: Added support for the locations of stack allocated local variables. This commit adds furher support for location information for local variables and starts with the implementation of the debug_loc section. --- arm/TargetPrinter.ml | 1 + backend/PrintAsm.ml | 8 ++-- common/Sections.ml | 1 + common/Sections.mli | 1 + debug/Debug.ml | 16 +++++-- debug/Debug.mli | 8 ++-- debug/DebugInformation.ml | 88 +++++++++++++++++++++++++++++++++--- debug/DwarfPrinter.ml | 75 ++++++++++++++++++++++++------- debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 26 +++++++---- debug/DwarfUtil.ml | 9 +++- debug/Dwarfgen.ml | 61 ++++++++++++++++++------- ia32/TargetPrinter.ml | 1 + powerpc/AsmToJSON.ml | 3 +- powerpc/Asmexpand.ml | 112 +++++++++++++++++++++++++++++----------------- powerpc/TargetPrinter.ml | 4 +- 16 files changed, 318 insertions(+), 98 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 5f16fc9e..30166215 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -153,6 +153,7 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = sprintf ".section \"%s\",\"a%s%s\",%%progbits" s (if wr then "w" else "") (if ex then "x" else "") | Section_debug_info + | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) let section oc sec = diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 9ffe3aa5..104440c6 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -66,7 +66,9 @@ module Printer(Target:TARGET) = print_debug_label oc e; Target.print_fun_info oc name; Target.emit_constants oc lit; - Target.print_jumptable oc jmptbl + Target.print_jumptable oc jmptbl; + if !Clflags.option_g then + Hashtbl.iter (fun p i -> Debug.add_label name p i) current_function_labels let print_init_data oc name id = if Str.string_match PrintCsyntax.re_string_literal (extern_atom name) 0 @@ -141,6 +143,6 @@ let print_program oc p db = begin match Debug.generate_debug_info () with | None -> () - | Some db -> - Printer.DebugPrinter.print_debug oc db + | Some (db,loc) -> + Printer.DebugPrinter.print_debug oc db loc end diff --git a/common/Sections.ml b/common/Sections.ml index c0c95848..8e569389 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -29,6 +29,7 @@ type section_name = | Section_user of string * bool (*writable*) * bool (*executable*) | Section_debug_info | Section_debug_abbrev + | Section_debug_loc type access_mode = | Access_default diff --git a/common/Sections.mli b/common/Sections.mli index e878b9e5..eca9a993 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -28,6 +28,7 @@ type section_name = | Section_user of string * bool (*writable*) * bool (*executable*) | Section_debug_info | Section_debug_abbrev + | Section_debug_loc type access_mode = | Access_default diff --git a/debug/Debug.ml b/debug/Debug.ml index fba921e1..7155ae0f 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,7 +30,7 @@ type implem = mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; mutable insert_global_declaration: Env.t -> globdecl -> unit; mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: unit -> dw_entry option; + mutable generate_debug_info: unit -> (dw_entry * dw_locations) option; mutable all_files_iter: (string -> unit) -> unit; mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; @@ -39,9 +39,11 @@ type implem = mutable add_lvar_scope: int -> ident -> int -> unit; mutable open_scope: atom -> int -> positive -> unit; mutable close_scope: atom -> int -> positive -> unit; - mutable start_live_range: atom -> positive -> string builtin_arg -> unit; + mutable start_live_range: atom -> positive -> int * int builtin_arg -> unit; mutable end_live_range: atom -> positive -> unit; - mutable stack_variable: atom -> string builtin_arg -> unit + mutable stack_variable: atom -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; } let implem = @@ -66,6 +68,8 @@ let implem = start_live_range = (fun _ _ _ -> ()); end_live_range = (fun _ _ -> ()); stack_variable = (fun _ _ -> ()); + function_end = (fun _ _ -> ()); + add_label = (fun _ _ _ -> ()); } let init () = @@ -90,6 +94,8 @@ let init () = implem.start_live_range <- DebugInformation.start_live_range; implem.end_live_range <- DebugInformation.end_live_range; implem.stack_variable <- DebugInformation.stack_variable; + implem.function_end <- DebugInformation.function_end; + implem.add_label <- DebugInformation.add_label; end else begin implem.init <- (fun _ -> ()); implem.atom_function <- (fun _ _ -> ()); @@ -111,6 +117,8 @@ let init () = implem.start_live_range <- (fun _ _ _ -> ()); implem.end_live_range <- (fun _ _ -> ()); implem.stack_variable <- (fun _ _ -> ()); + implem.function_end <- (fun _ _ -> ()); + implem.add_label <- (fun _ _ _ -> ()); end let init_compile_unit name = implem.init name @@ -133,3 +141,5 @@ let close_scope atom id lbl = implem.close_scope atom id lbl let start_live_range atom lbl loc = implem.start_live_range atom lbl loc let end_live_range atom lbl = implem.end_live_range atom lbl let stack_variable atom loc = implem.stack_variable atom loc +let function_end atom loc = implem.function_end atom loc +let add_label atom p lbl = implem.add_label atom p lbl diff --git a/debug/Debug.mli b/debug/Debug.mli index 42a0cee7..2954c300 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -26,7 +26,6 @@ val set_member_offset: ident -> string -> int -> unit val set_bitfield_offset: ident -> string -> int -> string -> int -> unit val insert_global_declaration: Env.t -> globdecl -> unit val add_fun_addr: atom -> (int * int) -> unit -val generate_debug_info: unit -> dw_entry option val all_files_iter: (string -> unit) -> unit val insert_local_declaration: storage -> ident -> typ -> location -> unit val atom_local_variable: ident -> atom -> unit @@ -35,6 +34,9 @@ val enter_function_scope: int -> int -> unit val add_lvar_scope: int -> ident -> int -> unit val open_scope: atom -> int -> positive -> unit val close_scope: atom -> int -> positive -> unit -val start_live_range: atom -> positive -> string builtin_arg -> unit +val start_live_range: atom -> positive -> (int * int builtin_arg) -> unit val end_live_range: atom -> positive -> unit -val stack_variable: atom -> string builtin_arg -> unit +val stack_variable: atom -> int * int builtin_arg -> unit +val function_end: atom -> positive -> unit +val add_label: atom -> positive -> int -> unit +val generate_debug_info: unit -> (dw_entry * dw_locations) option diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index f12853c9..459c4e9d 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -10,6 +10,8 @@ (* *) (* *********************************************************************) +open AST +open BinNums open C open Camlcoq open Cutil @@ -659,20 +661,94 @@ let enter_scope f_id p_id id = replace_scope p_id' ({scope_variables = id'::scope.scope_variables;}) with Not_found -> () + +type scope_range = + { + start_addr: positive option; + end_addr: positive option; + } + +type var_range = + { + range_start: positive option; + range_end: positive option; + var_loc: int * int builtin_arg; + } + +type var_location = + | RangeLoc of var_range list + | FunctionLoc of int * int builtin_arg (* Stack allocated variables *) + +let var_locations: (atom,var_location) Hashtbl.t = Hashtbl.create 7 + +let scope_ranges: (int,scope_range list) Hashtbl.t = Hashtbl.create 7 + +let label_translation: (atom * positive, int) Hashtbl.t = Hashtbl.create 7 + +let add_label atom p i = + Hashtbl.add label_translation (atom,p) i + +(* Auxiliary data structures and functions *) +module IntSet = Set.Make(struct + type t = int + let compare (x:int) (y:int) = compare x y +end) + +let open_scopes: IntSet.t ref = ref IntSet.empty + let open_scope atom s_id lbl = - () + try + let s_id = Hashtbl.find atom_to_scope (atom,s_id) in + let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in + let n_scop = { start_addr = Some lbl; end_addr = None;} in + open_scopes := IntSet.add s_id !open_scopes; + Hashtbl.replace scope_ranges s_id (n_scop::old_r) + with Not_found -> () let close_scope atom s_id lbl = - () + try + let s_id = Hashtbl.find atom_to_scope (atom,s_id) in + let old_r = try Hashtbl.find scope_ranges s_id with Not_found -> [] in + let last_r,rest = + begin + match old_r with + | a::rest -> a,rest + | _ -> assert false (* We must have an opening scope *) + end in + let new_r = ({last_r with end_addr = Some lbl;})::rest in + open_scopes := IntSet.remove s_id !open_scopes; + Hashtbl.replace scope_ranges s_id new_r + with Not_found -> () let start_live_range atom lbl loc = - () + try + let old_r = Hashtbl.find var_locations atom in + match old_r with + | RangeLoc old_r -> + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> assert false + with Not_found -> () + let end_live_range atom lbl = - () + try + let old_r = Hashtbl.find var_locations atom in + match old_r with + | RangeLoc (n_r::old_r) -> + let n_r = {n_r with range_end = Some lbl} in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> assert false + with Not_found -> () + + +let stack_variable atom (sp,loc) = + Hashtbl.add var_locations atom (FunctionLoc (sp,loc)) + +let function_end atom loc = + IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; + open_scopes := IntSet.empty -let stack_variable atom loc = - () let init name = id := 0; diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index f3cfdc6e..5f459a57 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -21,7 +21,7 @@ open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> dw_entry -> dw_locations -> unit end = struct @@ -36,6 +36,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_label oc lbl = fprintf oc "%a:\n" label lbl + (* Print a positive label *) + let print_plabel oc lbl = + print_label oc (transl_label lbl) + (* Helper functions for abbreviation printing *) let add_byte buf value = Buffer.add_string buf (string_of_byte value) @@ -69,9 +73,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let add_location loc buf = match loc with | None -> () - | Some (LocSymbol _) ->add_abbr_entry (0x2,location_block_type_abbr) buf - | Some (LocConst _) -> add_abbr_entry (0x2,location_const_type_abbr) buf - | Some (LocBlock _) -> add_abbr_entry (0x2,location_block_type_abbr) buf + | Some (LocRef _) -> add_abbr_entry (0x2,location_ref_type_abbr) buf + | Some (LocList _ ) + | Some (LocSymbol _) + | Some (LocSimple _) -> add_abbr_entry (0x2,location_block_type_abbr) buf (* Dwarf entity to string function *) let abbrev_string_of_entity entity has_sibling = @@ -101,8 +106,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_TAG_compile_unit e -> prologue 0x11; add_abbr_entry (0x1b,comp_dir_type_abbr) buf; - add_high_pc buf; add_low_pc buf; + add_high_pc buf; add_abbr_entry (0x13,language_type_abbr) buf; add_name buf; add_abbr_entry (0x25,producer_type_abbr) buf; @@ -288,20 +293,43 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_byte oc b = fprintf oc " .byte 0x%X\n" b + + let size_of_loc_expr = function + | DW_OP_bregx _ -> 3 + | DW_OP_plus_uconst _ -> 2 + | DW_OP_piece _ -> 2 + + let print_loc_expr oc = function + | DW_OP_bregx (a,b) -> + print_byte oc dw_op_bregx; + print_uleb128 oc a; + fprintf oc " .sleb128 %ld\n" b + | DW_OP_plus_uconst i -> + print_byte oc dw_op_plus_uconst; + print_byte oc i + | DW_OP_piece i -> + print_byte oc dw_op_piece; + print_uleb128 oc i + let print_loc oc loc = match loc with | LocSymbol s -> - fprintf oc " .sleb128 5\n"; - fprintf oc " .byte 3\n"; + print_sleb128 oc 5; + print_byte oc dw_op_addr; fprintf oc " .4byte %a\n" symbol s + | LocSimple e -> + print_sleb128 oc (size_of_loc_expr e); + print_loc_expr oc e + | LocList e -> + let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in + print_sleb128 oc size; + List.iter (print_loc_expr oc) e | _ -> () let print_data_location oc dl = match dl with - | DataLocBlock [DW_OP_plus_uconst i] -> - fprintf oc " .sleb128 2\n"; - fprintf oc " .byte 0x23\n"; - fprintf oc " .byte %d\n" i + | DataLocBlock e -> + print_loc_expr oc e | _ -> () let print_ref oc r = @@ -340,8 +368,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let print_compilation_unit oc tag = let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in print_string oc (Sys.getcwd ()); - print_addr oc (get_end_addr ()); print_addr oc (get_start_addr ()); + print_addr oc (get_end_addr ()); print_uleb128 oc 1; print_string oc tag.compile_unit_name; print_string oc prod_name; @@ -372,9 +400,10 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_ref oc tl.label_low_pc; print_string oc tl.label_name + let print_lexical_block oc lb = - print_opt_value oc lb.lexical_block_high_pc print_ref; - print_opt_value oc lb.lexical_block_low_pc print_ref + print_opt_value oc lb.lexical_block_high_pc print_addr; + print_opt_value oc lb.lexical_block_low_pc print_addr let print_member oc mb = print_file_loc oc mb.member_file_loc; @@ -504,10 +533,24 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_sleb128 oc 0; print_label oc debug_end (* End of the debug section *) + let print_location_entry oc l = + let c_low = get_start_addr () in + print_label oc (entry_to_label l.loc_id); + List.iter (fun (b,e,loc) -> + fprintf oc " .4byte %a-%a\n" label b label c_low; + fprintf oc " .4byte %a-%a\n" label e label c_low; + print_loc oc loc) l.loc; + fprintf oc " .4byte 0\n"; + fprintf oc " .4byte 0\n" + + let print_location_list oc l = + List.iter (print_location_entry oc) l (* Print the debug info and abbrev section *) - let print_debug oc entry = + let print_debug oc entry loc = print_debug_abbrev oc entry; - print_debug_info oc entry + print_debug_info oc entry; + print_location_list oc loc + end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 9e0e6693..ab9ab264 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -14,5 +14,5 @@ open DwarfTypes module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> sig - val print_debug: out_channel -> dw_entry -> unit + val print_debug: out_channel -> dw_entry -> dw_locations -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 1d41403b..f01e550a 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -12,8 +12,9 @@ (* Types used for writing dwarf debug information *) -open Sections +open BinNums open Camlcoq +open Sections (* Basic types for the value of attributes *) @@ -39,16 +40,17 @@ type block = string type location_expression = | DW_OP_plus_uconst of constant - | DW_OP - + | DW_OP_bregx of int * int32 + | DW_OP_piece of int type location_value = | LocSymbol of atom - | LocConst of constant - | LocBlock of block - + | LocRef of address + | LocSimple of location_expression + | LocList of location_expression list + type data_location_value = - | DataLocBlock of location_expression list + | DataLocBlock of location_expression | DataLocRef of reference type bound_value = @@ -233,6 +235,14 @@ type dw_entry = id: reference; } +(* The type for the location list. *) +type location_entry = + { + loc: (int * int * location_value) list; + loc_id: reference; + } +type dw_locations = location_entry list + (* Module type for a matching from type to dwarf encoding *) module type DWARF_ABBREVS = sig @@ -257,7 +267,7 @@ module type DWARF_ABBREVS = val artificial_type_abbr: int val variable_parameter_type_abbr: int val bit_size_type_abbr: int - val location_const_type_abbr: int + val location_ref_type_abbr: int val location_block_type_abbr: int val data_location_block_type_abbr: int val data_location_ref_type_abbr: int diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 4cd838b6..954324f1 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -76,6 +76,13 @@ let dw_form_ref8 = 0x14 let dw_ref_udata = 0x15 let dw_ref_indirect = 0x16 +(* Operation encoding *) +let dw_op_addr = 0x3 +let dw_op_plus_uconst = 0x23 +let dw_op_bregx = 0x92 +let dw_op_piece = 0x93 + + (* Default corresponding encoding for the different abbreviations *) module DefaultAbbrevs = struct @@ -100,7 +107,7 @@ module DefaultAbbrevs = let artificial_type_abbr = dw_form_flag let variable_parameter_type_abbr = dw_form_flag let bit_size_type_abbr = dw_form_data1 - let location_const_type_abbr = dw_form_data4 + let location_ref_type_abbr = dw_form_data4 let location_block_type_abbr = dw_form_block let data_location_block_type_abbr = dw_form_block let data_location_ref_type_abbr = dw_form_ref4 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 6c10b362..7b155419 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -10,7 +10,9 @@ (* *) (* *********************************************************************) +open AST open C +open Camlcoq open Cutil open DebugInformation open DwarfTypes @@ -162,7 +164,7 @@ let member_to_entry mem = member_data_member_location = (match mem.cfd_byte_offset with | None -> None - | Some s -> Some (DataLocBlock [DW_OP_plus_uconst s])); + | Some s -> Some (DataLocBlock (DW_OP_plus_uconst s))); member_declaration = None; member_name = Some (mem.cfd_name); member_type = mem.cfd_typ; @@ -280,38 +282,66 @@ let function_parameter_to_entry acc p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let rec local_variable_to_entry acc v id = +let rec local_variable_to_entry f_id acc v id = + let loc = try + begin + match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with + | FunctionLoc (a,BA_addrstack (ofs)) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))) + | FunctionLoc (a,BA_splitlong ((BA_addrstack hi),(BA_addrstack lo))) -> + let hi = camlint_of_coqint hi + and lo = camlint_of_coqint lo in + if lo = Int32.add hi 4l then + Some (LocSimple (DW_OP_bregx (a,hi))) + else + Some (LocList [DW_OP_bregx (a,hi);DW_OP_piece 4;DW_OP_bregx (a,lo);DW_OP_piece 4]) + | _ -> None + end + with Not_found -> None in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; variable_external = None; variable_name = v.lvar_name; variable_type = v.lvar_type; - variable_location = None; + variable_location = loc; } in new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc -and scope_to_entry acc sc id = +and scope_to_entry 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 + | Some l -> Some (Hashtbl.find label_translation (f_id,l)) + | None -> None in + begin + match r with + | [] -> None,None + | [a] -> lbl a.start_addr, lbl a.end_addr + | a::rest -> lbl (List.hd (List.rev rest)).start_addr,lbl a.end_addr + end + with Not_found -> None,None in let scope = { - lexical_block_high_pc = None; - lexical_block_low_pc = None; + lexical_block_high_pc = h_pc; + lexical_block_low_pc = l_pc; } in - let vars,acc = mmap local_to_entry acc sc.scope_variables in + let vars,acc = mmap (local_to_entry 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 acc id = +and local_to_entry f_id acc id = match Hashtbl.find local_variables id with - | LocalVariable v -> local_variable_to_entry acc v id - | Scope v -> scope_to_entry acc v id + | LocalVariable v -> local_variable_to_entry f_id acc v id + | Scope v -> scope_to_entry f_id acc v id -let fun_scope_to_entries acc id = +let fun_scope_to_entries 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 acc sc.scope_variables + | Scope sc ->mmap (local_to_entry f_id) acc sc.scope_variables | _ -> assert false) let function_to_entry acc id f = @@ -324,10 +354,11 @@ let function_to_entry acc id f = subprogram_high_pc = f.fun_high_pc; subprogram_low_pc = f.fun_low_pc; } in + let f_id = get_opt_val f.fun_atom in 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 = mmap function_parameter_to_entry acc f.fun_parameter in - let vars,acc = fun_scope_to_entries acc f.fun_scope in + let vars,acc = fun_scope_to_entries f_id acc f.fun_scope in add_children f_entry (params@vars),acc let definition_to_entry acc id t = @@ -340,10 +371,10 @@ let gen_defs () = t::acc,bcc) definitions ([],IntSet.empty) in List.rev defs,typ -let gen_debug_info () = +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 = gen_defs () in - add_children cp ((gen_types ty) @ defs) + add_children cp ((gen_types ty) @ defs),[] diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index b06f6f97..215eb4b8 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -102,6 +102,7 @@ module Cygwin_System : SYSTEM = sprintf ".section \"%s\", \"%s\"\n" s (if ex then "xr" else if wr then "d" else "dr") | Section_debug_info + | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index a7e66701..136c9e41 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -331,7 +331,8 @@ let p_section oc = function | Section_jumptable -> fprintf oc "{\"Section Name\":\"Jumptable\"}" | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":%s,\"Writable\":%B,\"Executable\":%B}" s w e | Section_debug_info - | Section_debug_abbrev -> () (* There should be no info in the debug sections *) + | Section_debug_abbrev + | Section_debug_loc -> () (* There should be no info in the debug sections *) let p_int_opt oc = function | None -> fprintf oc "0" diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index d4675e5f..d44f709e 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -586,36 +586,57 @@ let expand_instruction_simple instr = | _ -> emit instr -let preg_to_string p = - "" - -let rec translate_annot a = - match a with - | BA x -> BA (preg_to_string x) - | BA_int n -> BA_int n - | BA_long n -> BA_long n - | BA_float n -> BA_float n - | BA_single n -> BA_single n - | BA_loadstack (chunk,ofs) -> BA_loadstack (chunk,ofs) - | BA_addrstack ofs -> BA_addrstack ofs - | BA_loadglobal (chunk,id,ofs) -> BA_loadglobal (chunk,id,ofs) - | BA_addrglobal (id,ofs) -> BA_addrglobal (id,ofs) - | BA_splitlong (hi,lo) -> BA_splitlong (translate_annot hi,translate_annot lo) - -let expand_stack_loc txt = function - | [a] -> Debug.stack_variable txt (translate_annot a) - | _ -> assert false - -let expand_start_live_range txt lbl = function - | [a] -> Debug.start_live_range txt lbl (translate_annot a) - | _ -> assert false - -let expand_end_live_range = - Debug.end_live_range +(* Translate to the integer identifier of the register as + the EABI specifies *) + +let int_reg_to_dwarf = function + | GPR0 -> 0 | GPR1 -> 1 | GPR2 -> 2 | GPR3 -> 3 + | GPR4 -> 4 | GPR5 -> 5 | GPR6 -> 6 | GPR7 -> 7 + | GPR8 -> 8 | GPR9 -> 9 | GPR10 -> 10 | GPR11 -> 11 + | GPR12 -> 12 | GPR13 -> 13 | GPR14 -> 14 | GPR15 -> 15 + | GPR16 -> 16 | GPR17 -> 17 | GPR18 -> 18 | GPR19 -> 19 + | GPR20 -> 20 | GPR21 -> 21 | GPR22 -> 22 | GPR23 -> 23 + | GPR24 -> 24 | GPR25 -> 25 | GPR26 -> 26 | GPR27 -> 27 + | GPR28 -> 28 | GPR29 -> 29 | GPR30 -> 30 | GPR31 -> 31 + +let float_reg_to_dwarf = function + | FPR0 -> 32 | FPR1 -> 33 | FPR2 -> 34 | FPR3 -> 35 + | FPR4 -> 36 | FPR5 -> 37 | FPR6 -> 38 | FPR7 -> 39 + | FPR8 -> 40 | FPR9 -> 41 | FPR10 -> 42 | FPR11 -> 43 + | FPR12 -> 44 | FPR13 -> 45 | FPR14 -> 46 | FPR15 -> 47 + | FPR16 -> 48 | FPR17 -> 49 | FPR18 -> 50 | FPR19 -> 51 + | FPR20 -> 52 | FPR21 -> 53 | FPR22 -> 54| FPR23 -> 55 + | FPR24 -> 56 | FPR25 -> 57 | FPR26 -> 58 | FPR27 -> 59 + | FPR28 -> 60 | FPR29 -> 61 | FPR30 -> 62 | FPR31 -> 63 + +let preg_to_dwarf_int = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + + +let translate_annot a = + let rec aux = function + | BA x -> Some (BA (preg_to_dwarf_int x)) + | BA_int _ + | BA_long _ + | BA_float _ + | BA_single _ + | BA_loadglobal _ + | BA_addrglobal _ + | BA_loadstack _ -> None + | BA_addrstack ofs -> Some (BA_addrstack ofs) + | BA_splitlong (hi,lo) -> + begin + match (aux hi,aux lo) with + | Some hi ,Some lo -> Some (BA_splitlong (hi,lo)) + | _,_ -> None + end in + aux (List.hd a) let expand_scope id lbl oldscopes newscopes = - let opening = List.filter (fun a -> List.mem a oldscopes) newscopes - and closing = List.filter (fun a -> List.mem a newscopes) oldscopes in + let opening = List.filter (fun a -> not (List.mem a oldscopes)) newscopes + and closing = List.filter (fun a -> not (List.mem a newscopes)) oldscopes in List.iter (fun i -> Debug.open_scope id i lbl) opening; List.iter (fun i -> Debug.close_scope id i lbl) closing @@ -627,31 +648,42 @@ let expand_instruction id l = lbl | Some lbl -> lbl in let rec aux lbl scopes = function - | [] -> () + | [] -> let lbl = get_lbl lbl in + Debug.function_end id lbl | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> let kind = (P.to_int kind) in begin match kind with - | 1 -> - emit i; aux lbl scopes rest + | 1-> + aux lbl scopes rest | 2 -> aux lbl scopes rest | 3 -> - let lbl = get_lbl lbl in - expand_start_live_range txt lbl args; - aux (Some lbl) scopes rest + begin + match translate_annot args with + | Some a -> + let lbl = get_lbl lbl in + Debug.start_live_range txt lbl (1,a); + aux (Some lbl) scopes rest + | None -> aux lbl scopes rest + end | 4 -> let lbl = get_lbl lbl in - expand_end_live_range txt lbl; + Debug.end_live_range txt lbl; aux (Some lbl) scopes rest - | 5 -> - expand_stack_loc txt args; - aux lbl scopes rest - | 6 -> + | 5 -> + begin + match translate_annot args with + | Some a-> + Debug.stack_variable txt (1,a); + aux lbl scopes rest + | _ -> aux lbl scopes rest + end + | 6 -> let lbl = get_lbl lbl in let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in expand_scope id lbl scopes scopes'; - aux (Some lbl) scopes' rest + emit i;aux (Some lbl) scopes' rest | _ -> emit i; aux None scopes rest end diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 21181215..e53f56a9 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -133,7 +133,8 @@ module Linux_System : SYSTEM = s (if wr then "w" else "") (if ex then "x" else "") | Section_debug_info -> ".debug_info,\"\",@progbits" | Section_debug_abbrev -> ".debug_abbrev,\"\",@progbits" - + | Section_debug_loc -> ".debug_loc,\"\",@progbits" + let section oc sec = let name = name_of_section sec in assert (name <> "COMM"); @@ -211,6 +212,7 @@ module Diab_System : SYSTEM = | false, false -> 'r') (* const *) | Section_debug_info -> ".debug_info,,n" | Section_debug_abbrev -> ".debug_abbrev,,n" + | Section_debug_loc -> ".debug_loc,,n" let section oc sec = let name = name_of_section sec in -- cgit From 3e070cae6a316b7e3363c8159096c3bbc4bf21b2 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 25 Sep 2015 21:12:48 +0200 Subject: Added translation of the range lists to location entries. --- debug/DebugInformation.ml | 32 ++++++++++++----- debug/DwarfPrinter.ml | 11 +++++- debug/DwarfTypes.mli | 1 + debug/DwarfUtil.ml | 2 ++ debug/Dwarfgen.ml | 88 +++++++++++++++++++++++++++++++++-------------- powerpc/Asmexpand.ml | 2 +- 6 files changed, 99 insertions(+), 37 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 459c4e9d..ec16f64e 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -695,6 +695,7 @@ module IntSet = Set.Make(struct end) let open_scopes: IntSet.t ref = ref IntSet.empty +let open_vars: atom list ref = ref [] let open_scope atom s_id lbl = try @@ -721,33 +722,46 @@ let close_scope atom s_id lbl = with Not_found -> () let start_live_range atom lbl loc = + let old_r = try + begin + match Hashtbl.find var_locations atom with + | RangeLoc old_r -> old_r + | _ -> assert false + end + with Not_found -> [] in + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + open_vars := atom::!open_vars; + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + +let end_live_range atom lbl = try let old_r = Hashtbl.find var_locations atom in match old_r with - | RangeLoc old_r -> - let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + | RangeLoc (n_r::old_r) -> + let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false with Not_found -> () - - -let end_live_range atom lbl = + +let close_range lbl atom = try let old_r = Hashtbl.find var_locations atom in match old_r with | RangeLoc (n_r::old_r) -> - let n_r = {n_r with range_end = Some lbl} in - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + if n_r.range_end = None then + let n_r = {n_r with range_end = Some lbl} in + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false with Not_found -> () - let stack_variable atom (sp,loc) = Hashtbl.add var_locations atom (FunctionLoc (sp,loc)) let function_end atom loc = IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; - open_scopes := IntSet.empty + open_scopes := IntSet.empty; + List.iter (close_range loc) !open_vars; + open_vars:= [] let init name = diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 5f459a57..3e98f0dd 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -298,7 +298,8 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_OP_bregx _ -> 3 | DW_OP_plus_uconst _ -> 2 | DW_OP_piece _ -> 2 - + | DW_OP_reg i -> if i < 32 then 1 else 2 + let print_loc_expr oc = function | DW_OP_bregx (a,b) -> print_byte oc dw_op_bregx; @@ -310,6 +311,13 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): | DW_OP_piece i -> print_byte oc dw_op_piece; print_uleb128 oc i + | DW_OP_reg i -> + if i < 32 then + print_byte oc (dw_op_reg0 + i) + else begin + print_byte oc dw_op_regx; + print_uleb128 oc i + end let print_loc oc loc = match loc with @@ -544,6 +552,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): fprintf oc " .4byte 0\n" let print_location_list oc l = + fprintf oc" .section %s\n" (name_of_section Section_debug_loc); List.iter (print_location_entry oc) l (* Print the debug info and abbrev section *) diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index f01e550a..ce00474a 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -42,6 +42,7 @@ type location_expression = | DW_OP_plus_uconst of constant | DW_OP_bregx of int * int32 | DW_OP_piece of int + | DW_OP_reg of int type location_value = | LocSymbol of atom diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index 954324f1..b0b80924 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -79,6 +79,8 @@ let dw_ref_indirect = 0x16 (* Operation encoding *) let dw_op_addr = 0x3 let dw_op_plus_uconst = 0x23 +let dw_op_reg0 = 0x50 +let dw_op_regx = 0x90 let dw_op_bregx = 0x92 let dw_op_piece = 0x93 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 7b155419..4e531ca9 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -282,23 +282,58 @@ let function_parameter_to_entry acc p = } in new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc -let rec local_variable_to_entry f_id acc v id = - let loc = try +let gen_splitlong op_hi op_lo = + let op_piece = DW_OP_piece 4 in + op_piece::op_hi@(op_piece::op_lo) + +let translate_function_loc a = function + | BA_addrstack (ofs) -> + let ofs = camlint_of_coqint ofs in + Some (LocSimple (DW_OP_bregx (a,ofs))),[] + | BA_splitlong (BA_addrstack hi,BA_addrstack lo)-> + let hi = camlint_of_coqint hi + and lo = camlint_of_coqint lo in + if lo = Int32.add hi 4l then + Some (LocSimple (DW_OP_bregx (a,hi))),[] + else + let op_hi = [DW_OP_bregx (a,hi)] + and op_lo = [DW_OP_bregx (a,lo)] in + Some (LocList (gen_splitlong op_hi op_lo)),[] + | _ -> None,[] + +let range_entry_loc (sp,l) = + let rec aux = function + | BA i -> [DW_OP_reg i] + | BA_addrstack ofs -> + let ofs = camlint_of_coqint ofs in + [DW_OP_bregx (sp,ofs)] + | BA_splitlong (hi,lo) -> + let hi = aux hi + and lo = aux lo in + gen_splitlong hi lo + | _ -> assert false in + match aux l with + | [] -> assert false + | [a] -> LocSimple a + | a::rest -> LocList (a::rest) + +let rec local_variable_to_entry f_id (acc,bcc) v id = + let loc,loc_list = try begin match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with - | FunctionLoc (a,BA_addrstack (ofs)) -> - let ofs = camlint_of_coqint ofs in - Some (LocSimple (DW_OP_bregx (a,ofs))) - | FunctionLoc (a,BA_splitlong ((BA_addrstack hi),(BA_addrstack lo))) -> - let hi = camlint_of_coqint hi - and lo = camlint_of_coqint lo in - if lo = Int32.add hi 4l then - Some (LocSimple (DW_OP_bregx (a,hi))) - else - Some (LocList [DW_OP_bregx (a,hi);DW_OP_piece 4;DW_OP_bregx (a,lo);DW_OP_piece 4]) - | _ -> None + | FunctionLoc (a,r) -> + translate_function_loc a r + | RangeLoc l -> + let l = List.map (fun i -> + let hi = get_opt_val i.range_start + and lo = get_opt_val i.range_end in + let hi = Hashtbl.find label_translation (f_id,hi) + and lo = Hashtbl.find label_translation (f_id,lo) in + hi,lo,range_entry_loc i.var_loc) l in + let id = next_id () in + Some (LocRef id),[{loc = l;loc_id = id;}] end - with Not_found -> None in + with Not_found -> None,[] in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -307,7 +342,7 @@ let rec local_variable_to_entry f_id acc v id = variable_type = v.lvar_type; variable_location = loc; } in - new_entry id (DW_TAG_variable var),IntSet.add v.lvar_type acc + 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 = let l_pc,h_pc = try @@ -344,7 +379,7 @@ let fun_scope_to_entries f_id acc id = | Scope sc ->mmap (local_to_entry f_id) acc sc.scope_variables | _ -> assert false) -let function_to_entry acc id f = +let function_to_entry (acc,bcc) id f = let f_tag = { subprogram_file_loc = f.fun_file_loc; subprogram_external = Some f.fun_external; @@ -358,23 +393,24 @@ let function_to_entry acc 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 = mmap function_parameter_to_entry acc f.fun_parameter in - let vars,acc = fun_scope_to_entries f_id acc f.fun_scope in - add_children f_entry (params@vars),acc + let vars,(acc,bcc) = fun_scope_to_entries f_id (acc,bcc) f.fun_scope in + add_children f_entry (params@vars),(acc,bcc) -let definition_to_entry acc id t = +let definition_to_entry (acc,bcc) id t = match t with - | GlobalVariable g -> global_variable_to_entry acc id g - | Function f -> function_to_entry acc id f + | GlobalVariable g -> let e,acc = global_variable_to_entry acc id g in + e,(acc,bcc) + | Function f -> function_to_entry (acc,bcc) id f let gen_defs () = - let defs,typ = 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 + 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 = gen_defs () in - add_children cp ((gen_types ty) @ defs),[] + let defs,ty,locs = gen_defs () in + add_children cp ((gen_types ty) @ defs),locs diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index d44f709e..b40a9e53 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -683,7 +683,7 @@ let expand_instruction id l = let lbl = get_lbl lbl in let scopes' = List.map (function BA_int x -> Int32.to_int (camlint_of_coqint x) | _ -> assert false) args in expand_scope id lbl scopes scopes'; - emit i;aux (Some lbl) scopes' rest + aux (Some lbl) scopes' rest | _ -> emit i; aux None scopes rest end -- cgit From 91ed1b752d2661478840e40a0d977b068d99490d Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 27 Sep 2015 20:13:19 +0200 Subject: Added printing the reference address for the LocRef and started refactoring old Debuging code. The old functions to store the symbol for the Global variables and retrive this is no longer needed since the atom is stored in DebugInformation. Also the Debug.Abbrev module is no longer needed. --- arm/TargetPrinter.ml | 10 +-------- backend/PrintAsm.ml | 7 +----- backend/PrintAsmaux.ml | 4 ---- debug/DwarfPrinter.ml | 14 ++++++------ debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 34 ----------------------------- debug/DwarfUtil.ml | 57 +++++++++++++++++++++++------------------------- ia32/TargetPrinter.ml | 8 ------- powerpc/TargetPrinter.ml | 12 ---------- 9 files changed, 37 insertions(+), 111 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 30166215..a7188206 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -908,20 +908,12 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = let get_stmt_list_addr () = -1 (* Dummy constant *) let get_debug_start_addr () = -1 (* Dummy constant *) - - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) - + let label = elf_label let new_label = new_label let print_file_loc _ _ = () (* Dummy function *) - - let get_location _ = None (* Dummy function *) - - let get_segment_location _ = None (* Dummy function *) - - let add_var_location _ = () (* Dummy function *) end let sel_target () = diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 104440c6..59570957 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -79,7 +79,6 @@ module Printer(Target:TARGET) = List.iter (Target.print_init oc) id let print_var oc name v = - if !Clflags.option_g && Configuration.advanced_debug then Target.add_var_location name; match v.gvar_init with | [] -> () | _ -> @@ -120,14 +119,10 @@ module Printer(Target:TARGET) = let get_end_addr = Target.get_end_addr let get_stmt_list_addr = Target.get_stmt_list_addr let name_of_section = Target.name_of_section - let get_location a = None - let get_frame_base a = None let symbol = Target.symbol end - module DebugPrinter = DwarfPrinter (DwarfTarget) (Target.DwarfAbbrevs) - - + module DebugPrinter = DwarfPrinter (DwarfTarget) end let print_program oc p db = diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 3f0b3ea3..1c3b47b5 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -52,10 +52,6 @@ module type TARGET = val new_label: unit -> int val label: out_channel -> int -> unit val print_file_loc: out_channel -> file_loc -> unit - val get_location: P.t -> location_value option - val get_segment_location: P.t -> location_value option - val add_var_location: P.t -> unit - module DwarfAbbrevs: DWARF_ABBREVS end (* On-the-fly label renaming *) diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 3e98f0dd..13c0640d 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -19,14 +19,13 @@ open PrintAsmaux open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) -module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): +module DwarfPrinter(Target: DWARF_TARGET): sig val print_debug: out_channel -> dw_entry -> dw_locations -> unit end = struct open Target - open DwarfAbbrevs (* Byte value to string *) let string_of_byte value = @@ -318,6 +317,11 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_byte oc dw_op_regx; print_uleb128 oc i end + + + let print_ref oc r = + let ref = entry_to_label r in + fprintf oc " .4byte %a\n" label ref let print_loc oc loc = match loc with @@ -332,7 +336,7 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in print_sleb128 oc size; List.iter (print_loc_expr oc) e - | _ -> () + | LocRef f -> print_ref oc f let print_data_location oc dl = match dl with @@ -340,10 +344,6 @@ module DwarfPrinter(Target: DWARF_TARGET)(DwarfAbbrevs:DWARF_ABBREVS): print_loc_expr oc e | _ -> () - let print_ref oc r = - let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref - let print_addr oc a = fprintf oc " .4byte %a\n" label a diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index ab9ab264..8b206a00 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -12,7 +12,7 @@ open DwarfTypes -module DwarfPrinter: functor (Target: DWARF_TARGET) -> functor (DwarfAbbrevs: DWARF_ABBREVS) -> +module DwarfPrinter: functor (Target: DWARF_TARGET) -> sig val print_debug: out_channel -> dw_entry -> dw_locations -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index ce00474a..86a14163 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -244,38 +244,6 @@ type location_entry = } type dw_locations = location_entry list -(* Module type for a matching from type to dwarf encoding *) -module type DWARF_ABBREVS = - sig - val sibling_type_abbr: int - val file_loc_type_abbr: int * int - val type_abbr: int - val name_type_abbr: int - val encoding_type_abbr: int - val byte_size_type_abbr: int - val member_size_abbr: int - val high_pc_type_abbr: int - val low_pc_type_abbr: int - val stmt_list_type_abbr: int - val declaration_type_abbr: int - val external_type_abbr: int - val prototyped_type_abbr: int - val bit_offset_type_abbr: int - val comp_dir_type_abbr: int - val language_type_abbr: int - val producer_type_abbr: int - val value_type_abbr: int - val artificial_type_abbr: int - val variable_parameter_type_abbr: int - val bit_size_type_abbr: int - val location_ref_type_abbr: int - val location_block_type_abbr: int - val data_location_block_type_abbr: int - val data_location_ref_type_abbr: int - val bound_const_type_abbr: int - val bound_ref_type_abbr: int - end - (* The target specific functions for printing the debug information *) module type DWARF_TARGET= sig @@ -285,7 +253,5 @@ module type DWARF_TARGET= val get_end_addr: unit -> int val get_stmt_list_addr: unit -> int val name_of_section: section_name -> string - val get_location: int -> location_value option - val get_frame_base: int -> location_value option val symbol: out_channel -> atom -> unit end diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index b0b80924..e1869281 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -86,33 +86,30 @@ let dw_op_piece = 0x93 (* Default corresponding encoding for the different abbreviations *) -module DefaultAbbrevs = - struct - let sibling_type_abbr = dw_form_ref4 - let file_loc_type_abbr = dw_form_data4,dw_form_udata - let type_abbr = dw_form_ref_addr - let name_type_abbr = dw_form_string - let encoding_type_abbr = dw_form_data1 - let byte_size_type_abbr = dw_form_data1 - let member_size_abbr = dw_form_udata - let high_pc_type_abbr = dw_form_addr - let low_pc_type_abbr = dw_form_addr - let stmt_list_type_abbr = dw_form_data4 - let declaration_type_abbr = dw_form_flag - let external_type_abbr = dw_form_flag - let prototyped_type_abbr = dw_form_flag - let bit_offset_type_abbr = dw_form_data1 - let comp_dir_type_abbr = dw_form_string - let language_type_abbr = dw_form_udata - let producer_type_abbr = dw_form_string - let value_type_abbr = dw_form_sdata - let artificial_type_abbr = dw_form_flag - let variable_parameter_type_abbr = dw_form_flag - let bit_size_type_abbr = dw_form_data1 - let location_ref_type_abbr = dw_form_data4 - let location_block_type_abbr = dw_form_block - let data_location_block_type_abbr = dw_form_block - let data_location_ref_type_abbr = dw_form_ref4 - let bound_const_type_abbr = dw_form_udata - let bound_ref_type_abbr=dw_form_ref4 - end +let sibling_type_abbr = dw_form_ref4 +let file_loc_type_abbr = dw_form_data4,dw_form_udata +let type_abbr = dw_form_ref_addr +let name_type_abbr = dw_form_string +let encoding_type_abbr = dw_form_data1 +let byte_size_type_abbr = dw_form_data1 +let member_size_abbr = dw_form_udata +let high_pc_type_abbr = dw_form_addr +let low_pc_type_abbr = dw_form_addr +let stmt_list_type_abbr = dw_form_data4 +let declaration_type_abbr = dw_form_flag +let external_type_abbr = dw_form_flag +let prototyped_type_abbr = dw_form_flag +let bit_offset_type_abbr = dw_form_data1 +let comp_dir_type_abbr = dw_form_string +let language_type_abbr = dw_form_udata +let producer_type_abbr = dw_form_string +let value_type_abbr = dw_form_sdata +let artificial_type_abbr = dw_form_flag +let variable_parameter_type_abbr = dw_form_flag +let bit_size_type_abbr = dw_form_data1 +let location_ref_type_abbr = dw_form_data4 +let location_block_type_abbr = dw_form_block +let data_location_block_type_abbr = dw_form_block +let data_location_ref_type_abbr = dw_form_ref4 +let bound_const_type_abbr = dw_form_udata +let bound_ref_type_abbr=dw_form_ref4 diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 215eb4b8..c4045e63 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -773,19 +773,11 @@ module Target(System: SYSTEM):TARGET = let get_debug_start_addr () = -1 (* Dummy constant *) - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs (* Dummy Abbrev types *) - let label = label let new_label = new_label let print_file_loc _ _ = () (* Dummy function *) - - let get_location _ = None (* Dummy function *) - - let get_segment_location _ = None (* Dummy function *) - - let add_var_location _ = () (* Dummy function *) end diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index e53f56a9..c05c995a 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -869,23 +869,11 @@ module Target (System : SYSTEM):TARGET = let get_debug_start_addr () = !debug_start_addr - module DwarfAbbrevs = DwarfUtil.DefaultAbbrevs - let new_label = new_label let section oc sec = section oc sec; debug_section oc sec - - let locations = (Hashtbl.create 17 : (atom,DwarfTypes.location_value) Hashtbl.t) - - let get_location a = try Some (Hashtbl.find locations a) with Not_found -> None - - let get_segment_location _ = None - - let add_var_location a = - if !Clflags.option_g && Configuration.advanced_debug then - Hashtbl.add locations a (DwarfTypes.LocSymbol a); end let sel_target () = -- cgit From 78df4fe4fad46fee83f5044525fd8e530d8da6ff Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 27 Sep 2015 20:25:21 +0200 Subject: More refactoring of the Debug Information. In order to remove unnecessary dependecies the implemenation type is made and the DebugInit file initializes the fields in the record. This allows it to move more functions behind the Debug interface without introducing circular dependencies. --- debug/Debug.ml | 49 ------------------------------------ debug/Debug.mli | 30 +++++++++++++++++++++- debug/DebugInit.ml | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ driver/Driver.ml | 2 +- 4 files changed, 103 insertions(+), 51 deletions(-) create mode 100644 debug/DebugInit.ml diff --git a/debug/Debug.ml b/debug/Debug.ml index 7155ae0f..a496b610 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -72,55 +72,6 @@ let implem = add_label = (fun _ _ _ -> ()); } -let init () = - if !Clflags.option_g then begin - implem.init <- DebugInformation.init; - implem.atom_function <- DebugInformation.atom_function; - implem.atom_global_variable <- DebugInformation.atom_global_variable; - implem.set_composite_size <- DebugInformation.set_composite_size; - implem.set_member_offset <- DebugInformation.set_member_offset; - implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; - implem.insert_global_declaration <- DebugInformation.insert_global_declaration; - implem.add_fun_addr <- DebugInformation.add_fun_addr; - implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); - implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); - implem.insert_local_declaration <- DebugInformation.insert_local_declaration; - implem.atom_local_variable <- DebugInformation.atom_local_variable; - implem.enter_scope <- DebugInformation.enter_scope; - implem.enter_function_scope <- DebugInformation.enter_function_scope; - implem.add_lvar_scope <- DebugInformation.add_lvar_scope; - implem.open_scope <- DebugInformation.open_scope; - implem.close_scope <- DebugInformation.close_scope; - implem.start_live_range <- DebugInformation.start_live_range; - implem.end_live_range <- DebugInformation.end_live_range; - implem.stack_variable <- DebugInformation.stack_variable; - implem.function_end <- DebugInformation.function_end; - implem.add_label <- DebugInformation.add_label; - end else begin - implem.init <- (fun _ -> ()); - implem.atom_function <- (fun _ _ -> ()); - implem.atom_global_variable <- (fun _ _ -> ()); - implem.set_composite_size <- (fun _ _ _ -> ()); - implem.set_member_offset <- (fun _ _ _ -> ()); - implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); - implem.insert_global_declaration <- (fun _ _ -> ()); - implem.add_fun_addr <- (fun _ _ -> ()); - implem.generate_debug_info <- (fun _ -> None); - implem.all_files_iter <- (fun _ -> ()); - implem.insert_local_declaration <- (fun _ _ _ _ -> ()); - implem.atom_local_variable <- (fun _ _ -> ()); - implem.enter_scope <- (fun _ _ _ -> ()); - implem.enter_function_scope <- (fun _ _ -> ()); - implem.add_lvar_scope <- (fun _ _ _ -> ()); - implem.open_scope <- (fun _ _ _ -> ()); - implem.close_scope <- (fun _ _ _ -> ()); - implem.start_live_range <- (fun _ _ _ -> ()); - implem.end_live_range <- (fun _ _ -> ()); - implem.stack_variable <- (fun _ _ -> ()); - implem.function_end <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()); - end - let init_compile_unit name = implem.init name let atom_function id atom = implem.atom_function id atom let atom_global_variable id atom = implem.atom_global_variable id atom diff --git a/debug/Debug.mli b/debug/Debug.mli index 2954c300..5ef1e7f5 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -17,7 +17,35 @@ open DwarfTypes open BinNums -val init: unit -> unit +(* Record used for stroring references to the actual implementation functions *) +type implem = + { + mutable init: string -> unit; + mutable atom_function: ident -> atom -> unit; + mutable atom_global_variable: ident -> atom -> unit; + mutable set_composite_size: ident -> struct_or_union -> int option -> unit; + mutable set_member_offset: ident -> string -> int -> unit; + mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; + mutable insert_global_declaration: Env.t -> globdecl -> unit; + mutable add_fun_addr: atom -> (int * int) -> unit; + mutable generate_debug_info: unit -> (dw_entry * dw_locations) option; + mutable all_files_iter: (string -> unit) -> unit; + mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; + mutable atom_local_variable: ident -> atom -> unit; + mutable enter_scope: int -> int -> int -> unit; + mutable enter_function_scope: int -> int -> unit; + mutable add_lvar_scope: int -> ident -> int -> unit; + mutable open_scope: atom -> int -> positive -> unit; + mutable close_scope: atom -> int -> positive -> unit; + mutable start_live_range: atom -> positive -> int * int builtin_arg -> unit; + mutable end_live_range: atom -> positive -> unit; + mutable stack_variable: atom -> int * int builtin_arg -> unit; + mutable function_end: atom -> positive -> unit; + mutable add_label: atom -> positive -> int -> unit; + } + +val implem: implem + val init_compile_unit: string -> unit val atom_function: ident -> atom -> unit val atom_global_variable: ident -> atom -> unit diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml new file mode 100644 index 00000000..40be9f42 --- /dev/null +++ b/debug/DebugInit.ml @@ -0,0 +1,73 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +open AST +open BinNums +open C +open Camlcoq +open Dwarfgen +open DwarfTypes +open Debug + +let init_debug () = + implem.init <- DebugInformation.init; + implem.atom_function <- DebugInformation.atom_function; + implem.atom_global_variable <- DebugInformation.atom_global_variable; + implem.set_composite_size <- DebugInformation.set_composite_size; + implem.set_member_offset <- DebugInformation.set_member_offset; + implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; + implem.insert_global_declaration <- DebugInformation.insert_global_declaration; + implem.add_fun_addr <- DebugInformation.add_fun_addr; + implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); + implem.insert_local_declaration <- DebugInformation.insert_local_declaration; + implem.atom_local_variable <- DebugInformation.atom_local_variable; + implem.enter_scope <- DebugInformation.enter_scope; + implem.enter_function_scope <- DebugInformation.enter_function_scope; + implem.add_lvar_scope <- DebugInformation.add_lvar_scope; + implem.open_scope <- DebugInformation.open_scope; + implem.close_scope <- DebugInformation.close_scope; + implem.start_live_range <- DebugInformation.start_live_range; + implem.end_live_range <- DebugInformation.end_live_range; + implem.stack_variable <- DebugInformation.stack_variable; + implem.function_end <- DebugInformation.function_end; + implem.add_label <- DebugInformation.add_label + +let init_none () = + implem.init <- (fun _ -> ()); + implem.atom_function <- (fun _ _ -> ()); + implem.atom_global_variable <- (fun _ _ -> ()); + implem.set_composite_size <- (fun _ _ _ -> ()); + implem.set_member_offset <- (fun _ _ _ -> ()); + implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); + implem.insert_global_declaration <- (fun _ _ -> ()); + implem.add_fun_addr <- (fun _ _ -> ()); + implem.generate_debug_info <- (fun _ -> None); + implem.all_files_iter <- (fun _ -> ()); + implem.insert_local_declaration <- (fun _ _ _ _ -> ()); + implem.atom_local_variable <- (fun _ _ -> ()); + implem.enter_scope <- (fun _ _ _ -> ()); + implem.enter_function_scope <- (fun _ _ -> ()); + implem.add_lvar_scope <- (fun _ _ _ -> ()); + implem.open_scope <- (fun _ _ _ -> ()); + implem.close_scope <- (fun _ _ _ -> ()); + implem.start_live_range <- (fun _ _ _ -> ()); + implem.end_live_range <- (fun _ _ -> ()); + implem.stack_variable <- (fun _ _ -> ()); + implem.function_end <- (fun _ _ -> ()); + implem.add_label <- (fun _ _ _ -> ()) + +let init () = + if !Clflags.option_g then + init_debug () + else + init_none () diff --git a/driver/Driver.ml b/driver/Driver.ml index 47d6e81c..9b1a6e70 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -683,7 +683,7 @@ let _ = Builtins.set C2C.builtins; CPragmas.initialize(); parse_cmdline cmdline_actions; - Debug.init (); (* Initialize the debug functions *) + DebugInit.init (); (* Initialize the debug functions *) let nolink = !option_c || !option_S || !option_E || !option_interp in if nolink && !option_o <> None && !num_source_files >= 2 then begin eprintf "Ambiguous '-o' option (multiple source files)\n"; -- cgit From f2350a3a112950bea11af821754d8f674dda9f9e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Sun, 27 Sep 2015 20:31:56 +0200 Subject: Added back again the emitting of the debuging annotations for debuging purpose. --- powerpc/Asmexpand.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index b40a9e53..013d3f0a 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -652,6 +652,7 @@ let expand_instruction id l = Debug.function_end id lbl | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> let kind = (P.to_int kind) in + emit i; begin match kind with | 1-> @@ -665,7 +666,7 @@ let expand_instruction id l = let lbl = get_lbl lbl in Debug.start_live_range txt lbl (1,a); aux (Some lbl) scopes rest - | None -> aux lbl scopes rest + | None -> aux lbl scopes rest end | 4 -> let lbl = get_lbl lbl in @@ -677,7 +678,7 @@ let expand_instruction id l = | Some a-> Debug.stack_variable txt (1,a); aux lbl scopes rest - | _ -> aux lbl scopes rest + | _ -> aux lbl scopes rest end | 6 -> let lbl = get_lbl lbl in @@ -685,7 +686,7 @@ let expand_instruction id l = expand_scope id lbl scopes scopes'; aux (Some lbl) scopes' rest | _ -> - emit i; aux None scopes rest + aux None scopes rest end | i::rest -> expand_instruction_simple i; aux None scopes rest in aux None [] l -- cgit From 89476ea80ecfc7af02ef5026d0f45b61d243e3b0 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 09:48:07 +0200 Subject: Changed the size expression to 2byte for debug_loc entries. --- debug/DwarfPrinter.ml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 13c0640d..63ba4cd0 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -292,6 +292,9 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_byte oc b = fprintf oc " .byte 0x%X\n" b + let print_2byte oc b = + fprintf oc " .2byte 0x%X\n" b + let size_of_loc_expr = function | DW_OP_bregx _ -> 3 @@ -338,6 +341,20 @@ module DwarfPrinter(Target: DWARF_TARGET): List.iter (print_loc_expr oc) e | LocRef f -> print_ref oc f + let print_list_loc oc = function + | LocSymbol s -> + print_2byte oc 5; + print_byte oc dw_op_addr; + fprintf oc " .4byte %a\n" symbol s + | LocSimple e -> + print_2byte oc (size_of_loc_expr e); + print_loc_expr oc e + | LocList e -> + let size = List.fold_left (fun acc a -> acc + size_of_loc_expr a) 0 e in + print_2byte oc size; + List.iter (print_loc_expr oc) e + | LocRef f -> print_ref oc f + let print_data_location oc dl = match dl with | DataLocBlock e -> @@ -547,7 +564,7 @@ module DwarfPrinter(Target: DWARF_TARGET): List.iter (fun (b,e,loc) -> fprintf oc " .4byte %a-%a\n" label b label c_low; fprintf oc " .4byte %a-%a\n" label e label c_low; - print_loc oc loc) l.loc; + print_list_loc oc loc) l.loc; fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" -- cgit From 5492b5b55afa68e3d628da07ff583a0cac79b7e3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 13:36:53 +0200 Subject: Added location for the formal parameters and move the end of all scopes before the last statement. --- cfrontend/C2C.ml | 1 + debug/Debug.ml | 3 +++ debug/Debug.mli | 2 ++ debug/DebugInformation.ml | 29 ++++++++++++++++++++++------- debug/DebugInit.ml | 7 +++++-- debug/DwarfPrinter.ml | 6 ++++-- debug/DwarfTypes.mli | 1 + debug/Dwarfgen.ml | 38 ++++++++++++++++++++++---------------- powerpc/Asmexpand.ml | 10 ++++++++-- 9 files changed, 68 insertions(+), 29 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index dd55e60f..332665f4 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1042,6 +1042,7 @@ let convertFundef loc env fd = List.map (fun (id, ty) -> let id' = intern_string id.name in + Debug.atom_parameter fd.fd_name id id'; (id', convertTyp env ty)) fd.fd_params in let vars = diff --git a/debug/Debug.ml b/debug/Debug.ml index a496b610..d0de9e98 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -44,6 +44,7 @@ type implem = mutable stack_variable: atom -> int * int builtin_arg -> unit; mutable function_end: atom -> positive -> unit; mutable add_label: atom -> positive -> int -> unit; + mutable atom_parameter: ident -> ident -> atom -> unit; } let implem = @@ -70,6 +71,7 @@ let implem = stack_variable = (fun _ _ -> ()); function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); + atom_parameter = (fun _ _ _ -> ()); } let init_compile_unit name = implem.init name @@ -94,3 +96,4 @@ let end_live_range atom lbl = implem.end_live_range atom lbl let stack_variable atom loc = implem.stack_variable atom loc let function_end atom loc = implem.function_end atom loc let add_label atom p lbl = implem.add_label atom p lbl +let atom_parameter fid pid atom = implem.atom_parameter fid pid atom diff --git a/debug/Debug.mli b/debug/Debug.mli index 5ef1e7f5..c5fcddb3 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -42,6 +42,7 @@ type implem = mutable stack_variable: atom -> int * int builtin_arg -> unit; mutable function_end: atom -> positive -> unit; mutable add_label: atom -> positive -> int -> unit; + mutable atom_parameter: ident -> ident -> atom -> unit; } val implem: implem @@ -68,3 +69,4 @@ val stack_variable: atom -> int * int builtin_arg -> unit val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit val generate_debug_info: unit -> (dw_entry * dw_locations) option +val atom_parameter: ident -> ident -> atom -> unit diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index ec16f64e..8b6ec1ad 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -29,6 +29,10 @@ let next_id () = let reset_id () = id := 0 +(* Auximilary functions *) +let list_replace c f l = + List.map (fun a -> if c a then f a else a) l + (* The name of the current compilation unit *) let file_name: string ref = ref "" @@ -349,6 +353,7 @@ type global_variable_information = { type parameter_information = { parameter_name: string; + parameter_ident: int; parameter_atom: atom option; parameter_type: int; } @@ -512,6 +517,7 @@ let insert_global_declaration env dec= let ty = insert_type ty in { parameter_name = p.name; + parameter_ident = p.stamp; parameter_atom = None; parameter_type = ty; }) f.fd_params in @@ -572,9 +578,7 @@ let set_member_offset str field offset = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field || match f.cfd_bitfield with Some n -> n = field | _ -> false in - let members = List.map (fun a -> if name a then - {a with cfd_byte_offset = Some offset;} - else a) comp.ct_members in + let members = list_replace name (fun a -> {a with cfd_byte_offset = Some offset;}) comp.ct_members in {comp with ct_members = members;}) let set_composite_size comp sou size = @@ -585,10 +589,9 @@ let set_bitfield_offset str field offset underlying size = let id = find_type (TStruct (str,[])) in replace_composite id (fun comp -> let name f = f.cfd_name = field in - let members = List.map (fun a -> if name a then - {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size} - else - a) comp.ct_members in + let members = list_replace name (fun a -> + {a with cfd_bit_offset = Some offset; cfd_bitfield = Some underlying; cfd_byte_size = Some size}) + comp.ct_members in {comp with ct_members = members;}) let atom_global_variable id atom = @@ -606,6 +609,14 @@ let atom_function id atom = Hashtbl.iter (fun (fid,sid) tid -> if fid = id.stamp then Hashtbl.add atom_to_scope (atom,sid) tid) scope_to_local with Not_found -> () + +let atom_parameter fid id atom = + try + let fid',f = find_fun_stamp fid.stamp in + let name p = p.parameter_ident = id.stamp in + let params = list_replace name (fun p -> {p with parameter_atom = Some atom;}) f.fun_parameter in + replace_fun fid' ({f with fun_parameter = params;}) + with Not_found -> () let add_fun_addr atom (high,low) = try @@ -763,6 +774,8 @@ let function_end atom loc = List.iter (close_range loc) !open_vars; open_vars:= [] +let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 +let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 let init name = id := 0; @@ -776,3 +789,5 @@ let init name = Hashtbl.reset stamp_to_local; Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; + Hashtbl.reset compilation_section_start; + Hashtbl.reset compilation_section_end diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 40be9f42..17db4354 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -40,7 +40,8 @@ let init_debug () = implem.end_live_range <- DebugInformation.end_live_range; implem.stack_variable <- DebugInformation.stack_variable; implem.function_end <- DebugInformation.function_end; - implem.add_label <- DebugInformation.add_label + implem.add_label <- DebugInformation.add_label; + implem.atom_parameter <- DebugInformation.atom_parameter let init_none () = implem.init <- (fun _ -> ()); @@ -64,7 +65,9 @@ let init_none () = implem.end_live_range <- (fun _ _ -> ()); implem.stack_variable <- (fun _ _ -> ()); implem.function_end <- (fun _ _ -> ()); - implem.add_label <- (fun _ _ _ -> ()) + implem.add_label <- (fun _ _ _ -> ()); + implem.atom_parameter <- (fun _ _ _ -> ()) + let init () = if !Clflags.option_g then diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 63ba4cd0..32c15dfd 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -131,7 +131,8 @@ module DwarfPrinter(Target: DWARF_TARGET): add_attr_some e.formal_parameter_artificial (add_abbr_entry (0x34,artificial_type_abbr)); add_attr_some e.formal_parameter_name add_name; add_type buf; - add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)) + add_attr_some e.formal_parameter_variable_parameter (add_abbr_entry (0x4b,variable_parameter_type_abbr)); + add_location e.formal_parameter_location buf | DW_TAG_label _ -> prologue 0xa; add_low_pc buf; @@ -419,7 +420,8 @@ module DwarfPrinter(Target: DWARF_TARGET): print_opt_value oc fp.formal_parameter_artificial print_flag; print_opt_value oc fp.formal_parameter_name print_string; print_ref oc fp.formal_parameter_type; - print_opt_value oc fp.formal_parameter_variable_parameter print_flag + print_opt_value oc fp.formal_parameter_variable_parameter print_flag; + print_opt_value oc fp.formal_parameter_location print_loc let print_tag_label oc tl = print_ref oc tl.label_low_pc; diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 86a14163..8c2a7d56 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -107,6 +107,7 @@ type dw_tag_formal_parameter = formal_parameter_name: string option; formal_parameter_type: reference; formal_parameter_variable_parameter: flag option; + formal_parameter_location: location_value option; } type dw_tag_label = diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 4e531ca9..7fce22a7 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -145,6 +145,7 @@ let fun_type_to_entry id f = formal_parameter_name = if p.param_name <> "" then Some p.param_name else None; formal_parameter_type = p.param_type; formal_parameter_variable_parameter = None; + formal_parameter_location = None; } in new_entry (next_id ()) (DW_TAG_formal_parameter fp)) f.fun_params; in @@ -272,16 +273,6 @@ let global_variable_to_entry acc id v = } in new_entry id (DW_TAG_variable var),IntSet.add v.gvar_type acc -let function_parameter_to_entry acc p = - let p = { - formal_parameter_file_loc = None; - formal_parameter_artificial = None; - formal_parameter_name = Some p.parameter_name; - formal_parameter_type = p.parameter_type; - formal_parameter_variable_parameter = None; - } in - new_entry (next_id ()) (DW_TAG_formal_parameter p),IntSet.add p.formal_parameter_type acc - let gen_splitlong op_hi op_lo = let op_piece = DW_OP_piece 4 in op_piece::op_hi@(op_piece::op_lo) @@ -317,10 +308,10 @@ let range_entry_loc (sp,l) = | [a] -> LocSimple a | a::rest -> LocList (a::rest) -let rec local_variable_to_entry f_id (acc,bcc) v id = - let loc,loc_list = try +let location_entry f_id atom = + try begin - match (Hashtbl.find var_locations (get_opt_val v.lvar_atom)) with + match (Hashtbl.find var_locations atom) with | FunctionLoc (a,r) -> translate_function_loc a r | RangeLoc l -> @@ -331,9 +322,24 @@ let rec local_variable_to_entry f_id (acc,bcc) v id = and lo = Hashtbl.find label_translation (f_id,lo) in hi,lo,range_entry_loc i.var_loc) l in let id = next_id () in - Some (LocRef id),[{loc = l;loc_id = id;}] + Some (LocRef id),[{loc = l;loc_id = id;}] end - with Not_found -> None,[] in + with Not_found -> None,[] + +let function_parameter_to_entry f_id (acc,bcc) p = + let loc,loc_list = location_entry f_id (get_opt_val p.parameter_atom) in + let p = { + formal_parameter_file_loc = None; + formal_parameter_artificial = None; + formal_parameter_name = Some p.parameter_name; + formal_parameter_type = p.parameter_type; + formal_parameter_variable_parameter = None; + formal_parameter_location = loc; + } 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 loc,loc_list = location_entry f_id (get_opt_val v.lvar_atom) in let var = { variable_file_loc = v.lvar_file_loc; variable_declaration = None; @@ -392,7 +398,7 @@ let function_to_entry (acc,bcc) id f = let f_id = get_opt_val f.fun_atom in 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 = mmap function_parameter_to_entry acc f.fun_parameter 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 add_children f_entry (params@vars),(acc,bcc) diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 013d3f0a..80aa333e 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -647,7 +647,7 @@ let expand_instruction id l = emit (Plabel lbl); lbl | Some lbl -> lbl in - let rec aux lbl scopes = function + let rec aux lbl scopes = function | [] -> let lbl = get_lbl lbl in Debug.function_end id lbl | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> @@ -689,7 +689,13 @@ let expand_instruction id l = aux None scopes rest end | i::rest -> expand_instruction_simple i; aux None scopes rest in - aux None [] l + (* We need to move all closing debug annotations before the last real statement *) + let rec move_debug acc = function + | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest -> + move_debug (i::acc) rest (* Move the debug annotations forward *) + | b::rest -> List.rev (b::(List.rev acc)@rest) (* We found the first non debug location *) + | [] -> List.rev acc (* This actually can never happen *) in + aux None [] (move_debug [] (List.rev l)) let expand_function id fn = -- cgit From 68ad5472a78d12e0e4fd4eae422122185403d678 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 28 Sep 2015 18:39:43 +0200 Subject: 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. --- arm/TargetPrinter.ml | 2 +- backend/PrintAsm.ml | 21 +++++---- common/Sections.ml | 2 +- common/Sections.mli | 2 +- debug/Debug.ml | 15 ++++-- debug/Debug.mli | 10 +++- debug/DebugInformation.ml | 25 +++++++++- debug/DebugInit.ml | 14 ++++-- debug/DwarfPrinter.ml | 57 +++++++++++------------ debug/DwarfPrinter.mli | 2 +- debug/DwarfTypes.mli | 16 ++++--- debug/Dwarfgen.ml | 116 +++++++++++++++++++++++++++------------------- ia32/TargetPrinter.ml | 8 ++-- powerpc/AsmToJSON.ml | 2 +- powerpc/TargetPrinter.ml | 115 ++++++++++++++++++++------------------------- 15 files changed, 228 insertions(+), 179 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index a7188206..86f9f973 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -152,7 +152,7 @@ module Target (Opt: PRINTER_OPTIONS) : TARGET = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",%%progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info + | Section_debug_info _ | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 59570957..a152e3c2 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -24,8 +24,6 @@ open TargetPrinter module Printer(Target:TARGET) = struct - let addr_mapping: (string, (int * int)) Hashtbl.t = Hashtbl.create 7 - let get_fun_addr name = let s = Target.new_label () and e = Target.new_label () in @@ -38,7 +36,6 @@ module Printer(Target:TARGET) = else () - let print_location oc loc = if loc <> Cutil.no_loc then Target.print_file_line oc (fst loc) (snd loc) @@ -113,11 +110,8 @@ module Printer(Target:TARGET) = module DwarfTarget: DwarfTypes.DWARF_TARGET = struct let label = Target.label - let name_of_section = Target.name_of_section + let section = Target.section let print_file_loc = Target.print_file_loc - let get_start_addr = Target.get_start_addr - let get_end_addr = Target.get_end_addr - let get_stmt_list_addr = Target.get_stmt_list_addr let name_of_section = Target.name_of_section let symbol = Target.symbol end @@ -136,8 +130,15 @@ let print_program oc p db = close_filenames (); if !Clflags.option_g && Configuration.advanced_debug then begin - match Debug.generate_debug_info () with + let atom_to_s s = + let s = C2C.atom_sections s in + match s with + | [] -> Target.name_of_section Section_text + | (Section_user (n,_,_))::_ -> n + | a::_ -> + Target.name_of_section a in + match Debug.generate_debug_info atom_to_s (Target.name_of_section Section_text) with | None -> () - | Some (db,loc) -> - Printer.DebugPrinter.print_debug oc db loc + | Some db -> + Printer.DebugPrinter.print_debug oc db end diff --git a/common/Sections.ml b/common/Sections.ml index 8e569389..be0f415e 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -27,7 +27,7 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info + | Section_debug_info of string | Section_debug_abbrev | Section_debug_loc diff --git a/common/Sections.mli b/common/Sections.mli index eca9a993..cf6f13b8 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -26,7 +26,7 @@ type section_name = | Section_literal | Section_jumptable | Section_user of string * bool (*writable*) * bool (*executable*) - | Section_debug_info + | Section_debug_info of string | Section_debug_abbrev | Section_debug_loc diff --git a/debug/Debug.ml b/debug/Debug.ml index d0de9e98..1d3b260e 100644 --- a/debug/Debug.ml +++ b/debug/Debug.ml @@ -30,7 +30,7 @@ type implem = mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; mutable insert_global_declaration: Env.t -> globdecl -> unit; mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: unit -> (dw_entry * dw_locations) option; + mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; mutable all_files_iter: (string -> unit) -> unit; mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; @@ -45,6 +45,9 @@ type implem = mutable function_end: atom -> positive -> unit; mutable add_label: atom -> positive -> int -> unit; mutable atom_parameter: ident -> ident -> atom -> unit; + mutable add_compilation_section_start: string ->(int * int * int * string) -> unit; + mutable compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable exists_section: string -> bool; } let implem = @@ -57,7 +60,7 @@ let implem = set_bitfield_offset = (fun _ _ _ _ _ -> ()); insert_global_declaration = (fun _ _ -> ()); add_fun_addr = (fun _ _ -> ()); - generate_debug_info = (fun _ -> None); + generate_debug_info = (fun _ _ -> None); all_files_iter = (fun _ -> ()); insert_local_declaration = (fun _ _ _ _ -> ()); atom_local_variable = (fun _ _ -> ()); @@ -72,6 +75,9 @@ let implem = function_end = (fun _ _ -> ()); add_label = (fun _ _ _ -> ()); atom_parameter = (fun _ _ _ -> ()); + add_compilation_section_start = (fun _ _ -> ()); + compute_file_enum = (fun _ _ _ -> ()); + exists_section = (fun _ -> true); } let init_compile_unit name = implem.init name @@ -82,7 +88,7 @@ let set_member_offset id field off = implem.set_member_offset id field off let set_bitfield_offset id field off underlying size = implem.set_bitfield_offset id field off underlying size let insert_global_declaration env dec = implem.insert_global_declaration env dec let add_fun_addr atom addr = implem.add_fun_addr atom addr -let generate_debug_info () = implem.generate_debug_info () +let generate_debug_info fun_s var_s = implem.generate_debug_info fun_s var_s let all_files_iter f = implem.all_files_iter f let insert_local_declaration sto id ty loc = implem.insert_local_declaration sto id ty loc let atom_local_variable id atom = implem.atom_local_variable id atom @@ -97,3 +103,6 @@ let stack_variable atom loc = implem.stack_variable atom loc let function_end atom loc = implem.function_end atom loc let add_label atom p lbl = implem.add_label atom p lbl let atom_parameter fid pid atom = implem.atom_parameter fid pid atom +let add_compilation_section_start sec addr = implem.add_compilation_section_start sec addr +let exists_section sec = implem.exists_section sec +let compute_file_enum end_l entry_l line_e = implem.compute_file_enum end_l entry_l line_e diff --git a/debug/Debug.mli b/debug/Debug.mli index c5fcddb3..166a6759 100644 --- a/debug/Debug.mli +++ b/debug/Debug.mli @@ -28,7 +28,7 @@ type implem = mutable set_bitfield_offset: ident -> string -> int -> string -> int -> unit; mutable insert_global_declaration: Env.t -> globdecl -> unit; mutable add_fun_addr: atom -> (int * int) -> unit; - mutable generate_debug_info: unit -> (dw_entry * dw_locations) option; + mutable generate_debug_info: (atom -> string) -> string -> debug_entries option; mutable all_files_iter: (string -> unit) -> unit; mutable insert_local_declaration: storage -> ident -> typ -> location -> unit; mutable atom_local_variable: ident -> atom -> unit; @@ -43,6 +43,9 @@ type implem = mutable function_end: atom -> positive -> unit; mutable add_label: atom -> positive -> int -> unit; mutable atom_parameter: ident -> ident -> atom -> unit; + mutable add_compilation_section_start: string -> (int * int * int * string) -> unit; + mutable compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit; + mutable exists_section: string -> bool; } val implem: implem @@ -68,5 +71,8 @@ val end_live_range: atom -> positive -> unit val stack_variable: atom -> int * int builtin_arg -> unit val function_end: atom -> positive -> unit val add_label: atom -> positive -> int -> unit -val generate_debug_info: unit -> (dw_entry * dw_locations) option +val generate_debug_info: (atom -> string) -> string -> debug_entries option val atom_parameter: ident -> ident -> atom -> unit +val add_compilation_section_start: string -> (int * int * int * string) -> unit +val compute_file_enum: (string -> int) -> (string-> int) -> (unit -> unit) -> unit +val exists_section: string -> bool diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 8b6ec1ad..7866c339 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -774,9 +774,28 @@ let function_end atom loc = List.iter (close_range loc) !open_vars; open_vars:= [] -let compilation_section_start: (string,int) Hashtbl.t = Hashtbl.create 7 +let compilation_section_start: (string,int * int * int * string) Hashtbl.t = Hashtbl.create 7 let compilation_section_end: (string,int) Hashtbl.t = Hashtbl.create 7 +let add_compilation_section_start sec addr = + Hashtbl.add compilation_section_start sec addr + +let add_compilation_section_end sec addr = + Hashtbl.add compilation_section_end sec addr + +let exists_section sec = + Hashtbl.mem compilation_section_start sec + +let filenum: (string * string,int) Hashtbl.t = Hashtbl.create 7 + +let compute_file_enum end_label entry_label line_end = + Hashtbl.iter (fun sec (_,_,_,secname) -> + Hashtbl.add compilation_section_end sec (end_label secname); + StringSet.iter (fun file -> + let lbl = entry_label file in + Hashtbl.add filenum (sec,file) lbl) !all_files; + line_end ()) compilation_section_start + let init name = id := 0; file_name := name; @@ -790,4 +809,6 @@ let init name = Hashtbl.reset atom_to_local; Hashtbl.reset scope_to_local; Hashtbl.reset compilation_section_start; - Hashtbl.reset compilation_section_end + Hashtbl.reset compilation_section_end; + Hashtbl.reset filenum; + all_files := StringSet.empty diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index 17db4354..e0c435cd 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -27,7 +27,7 @@ let init_debug () = implem.set_bitfield_offset <- DebugInformation.set_bitfield_offset; implem.insert_global_declaration <- DebugInformation.insert_global_declaration; implem.add_fun_addr <- DebugInformation.add_fun_addr; - implem.generate_debug_info <- (fun () -> Some (Dwarfgen.gen_debug_info ())); + implem.generate_debug_info <- (fun a b -> Some (Dwarfgen.gen_debug_info a b)); implem.all_files_iter <- (fun f -> DebugInformation.StringSet.iter f !DebugInformation.all_files); implem.insert_local_declaration <- DebugInformation.insert_local_declaration; implem.atom_local_variable <- DebugInformation.atom_local_variable; @@ -41,7 +41,10 @@ let init_debug () = implem.stack_variable <- DebugInformation.stack_variable; implem.function_end <- DebugInformation.function_end; implem.add_label <- DebugInformation.add_label; - implem.atom_parameter <- DebugInformation.atom_parameter + implem.atom_parameter <- DebugInformation.atom_parameter; + implem.add_compilation_section_start <- DebugInformation.add_compilation_section_start; + implem.compute_file_enum <- DebugInformation.compute_file_enum; + implem.exists_section <- DebugInformation.exists_section let init_none () = implem.init <- (fun _ -> ()); @@ -52,7 +55,7 @@ let init_none () = implem.set_bitfield_offset <- (fun _ _ _ _ _ -> ()); implem.insert_global_declaration <- (fun _ _ -> ()); implem.add_fun_addr <- (fun _ _ -> ()); - implem.generate_debug_info <- (fun _ -> None); + implem.generate_debug_info <- (fun _ _ -> None); implem.all_files_iter <- (fun _ -> ()); implem.insert_local_declaration <- (fun _ _ _ _ -> ()); implem.atom_local_variable <- (fun _ _ -> ()); @@ -66,8 +69,9 @@ let init_none () = implem.stack_variable <- (fun _ _ -> ()); implem.function_end <- (fun _ _ -> ()); implem.add_label <- (fun _ _ _ -> ()); - implem.atom_parameter <- (fun _ _ _ -> ()) - + implem.atom_parameter <- (fun _ _ _ -> ()); + implem.add_compilation_section_start <- (fun _ _ -> ()); + implem.exists_section <- (fun _ -> true) let init () = if !Clflags.option_g then diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index 32c15dfd..aa1c187f 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -21,7 +21,7 @@ open Sections (* The printer is parameterized over target specific functions and a set of dwarf type constants *) module DwarfPrinter(Target: DWARF_TARGET): sig - val print_debug: out_channel -> dw_entry -> dw_locations -> unit + val print_debug: out_channel -> debug_entries -> unit end = struct @@ -245,7 +245,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_abbrev oc = let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in - fprintf oc " .section %s\n" (name_of_section Section_debug_abbrev); + section oc Section_debug_abbrev; let lbl = new_label () in abbrev_start_addr := lbl; print_label oc lbl; @@ -275,9 +275,6 @@ module DwarfPrinter(Target: DWARF_TARGET): | None -> () | Some o -> f oc o - let print_file_loc oc f = - print_opt_value oc f print_file_loc - let print_flag oc b = output_string oc (string_of_byte b) @@ -296,6 +293,15 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_2byte oc b = fprintf oc " .2byte 0x%X\n" b + let print_ref oc r = + let ref = entry_to_label r in + fprintf oc " .4byte %a\n" label ref + + let print_file_loc oc = function + | Some (file,col) -> + fprintf oc " .4byte %a\n" label file; + print_uleb128 oc col + | None -> () let size_of_loc_expr = function | DW_OP_bregx _ -> 3 @@ -322,11 +328,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_uleb128 oc i end - - let print_ref oc r = - let ref = entry_to_label r in - fprintf oc " .4byte %a\n" label ref - let print_loc oc loc = match loc with | LocSymbol s -> @@ -394,12 +395,12 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_compilation_unit oc tag = let prod_name = sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:%s" Version.version Configuration.arch in print_string oc (Sys.getcwd ()); - print_addr oc (get_start_addr ()); - print_addr oc (get_end_addr ()); + print_addr oc tag.compile_unit_low_pc; + print_addr oc tag.compile_unit_high_pc; print_uleb128 oc 1; print_string oc tag.compile_unit_name; print_string oc prod_name; - print_addr oc (get_stmt_list_addr ()) + print_addr oc tag.compile_unit_stmt_list let print_const_type oc ct = print_ref oc ct.const_type @@ -539,16 +540,15 @@ module DwarfPrinter(Target: DWARF_TARGET): print_sleb128 oc 0) entry (* Print the debug abbrev section *) - let print_debug_abbrev oc entry = - compute_abbrev entry; + let print_debug_abbrev oc entries = + List.iter (fun (_,_,e,_) -> compute_abbrev e) entries; print_abbrev oc (* Print the debug info section *) - let print_debug_info oc entry = - let debug_start = new_label () in - debug_start_addr:= debug_start; - fprintf oc" .section %s\n" (name_of_section Section_debug_info); - print_label oc debug_start; + let print_debug_info oc sec start entry = + debug_start_addr:= start; + section oc (Section_debug_info sec); + print_label oc start; let debug_length_start = new_label () (* Address used for length calculation *) and debug_end = new_label () in fprintf oc " .4byte %a-%a\n" label debug_end label debug_length_start; @@ -560,8 +560,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_sleb128 oc 0; print_label oc debug_end (* End of the debug section *) - let print_location_entry oc l = - let c_low = get_start_addr () in + let print_location_entry oc c_low l = print_label oc (entry_to_label l.loc_id); List.iter (fun (b,e,loc) -> fprintf oc " .4byte %a-%a\n" label b label c_low; @@ -570,15 +569,15 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .4byte 0\n"; fprintf oc " .4byte 0\n" - let print_location_list oc l = - fprintf oc" .section %s\n" (name_of_section Section_debug_loc); - List.iter (print_location_entry oc) l + let print_location_list oc (c_low,l) = + List.iter (print_location_entry oc c_low) l (* Print the debug info and abbrev section *) - let print_debug oc entry loc = - print_debug_abbrev oc entry; - print_debug_info oc entry; - print_location_list oc loc + let print_debug oc entries = + print_debug_abbrev oc entries; + List.iter (fun (s,d,e,_) -> print_debug_info oc s d e) entries; + section oc Section_debug_loc; + List.iter (fun (_,_,_,l) -> print_location_list oc l) entries end diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli index 8b206a00..e1e10601 100644 --- a/debug/DwarfPrinter.mli +++ b/debug/DwarfPrinter.mli @@ -14,5 +14,5 @@ open DwarfTypes module DwarfPrinter: functor (Target: DWARF_TARGET) -> sig - val print_debug: out_channel -> dw_entry -> dw_locations -> unit + val print_debug: out_channel -> debug_entries -> unit end diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli index 8c2a7d56..906b7cba 100644 --- a/debug/DwarfTypes.mli +++ b/debug/DwarfTypes.mli @@ -60,7 +60,7 @@ type bound_value = (* Types representing the attribute information per tag value *) -type file_loc = string * constant +type file_loc = int * constant type dw_tag_array_type = { @@ -77,7 +77,10 @@ type dw_tag_base_type = type dw_tag_compile_unit = { - compile_unit_name: string; + compile_unit_name: string; + compile_unit_low_pc: int; + compile_unit_high_pc: int; + compile_unit_stmt_list: int; } type dw_tag_const_type = @@ -243,16 +246,15 @@ type location_entry = loc: (int * int * location_value) list; loc_id: reference; } -type dw_locations = location_entry list +type dw_locations = int * location_entry list + +type debug_entries = (string * int * dw_entry * dw_locations) list (* The target specific functions for printing the debug information *) module type DWARF_TARGET= sig val label: out_channel -> int -> unit val print_file_loc: out_channel -> file_loc -> unit - val get_start_addr: unit -> int - val get_end_addr: unit -> int - val get_stmt_list_addr: unit -> int - val name_of_section: section_name -> string + val section: out_channel -> section_name -> unit val symbol: out_channel -> atom -> unit end 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 [] diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index c4045e63..51169d86 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -101,7 +101,7 @@ module Cygwin_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\", \"%s\"\n" s (if ex then "xr" else if wr then "d" else "dr") - | Section_debug_info + | Section_debug_info _ | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) @@ -151,7 +151,8 @@ module ELF_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",@progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info + | Section_debug_info _ + | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) @@ -203,7 +204,8 @@ module MacOS_System : SYSTEM = sprintf ".section \"%s\", %s, %s" (if wr then "__DATA" else "__TEXT") s (if ex then "regular, pure_instructions" else "regular") - | Section_debug_info + | Section_debug_info _ + | Section_debug_loc | Section_debug_abbrev -> "" (* Dummy value *) let stack_alignment = 16 (* mandatory *) diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index 136c9e41..5764aa8f 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -330,7 +330,7 @@ let p_section oc = function | Section_literal -> fprintf oc "{\"Section Name\":\"Literal\"}" | Section_jumptable -> fprintf oc "{\"Section Name\":\"Jumptable\"}" | Section_user (s,w,e) -> fprintf oc "{\"Section Name\":%s,\"Writable\":%B,\"Executable\":%B}" s w e - | Section_debug_info + | Section_debug_info _ | Section_debug_abbrev | Section_debug_loc -> () (* There should be no info in the debug sections *) diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index c05c995a..3c73f22d 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -131,7 +131,7 @@ module Linux_System : SYSTEM = | Section_user(s, wr, ex) -> sprintf ".section \"%s\",\"a%s%s\",@progbits" s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info -> ".debug_info,\"\",@progbits" + | Section_debug_info _ -> ".debug_info,\"\",@progbits" | Section_debug_abbrev -> ".debug_abbrev,\"\",@progbits" | Section_debug_loc -> ".debug_loc,\"\",@progbits" @@ -210,15 +210,20 @@ module Diab_System : SYSTEM = | true, false -> 'd' (* data *) | false, true -> 'c' (* text *) | false, false -> 'r') (* const *) - | Section_debug_info -> ".debug_info,,n" - | Section_debug_abbrev -> ".debug_abbrev,,n" - | Section_debug_loc -> ".debug_loc,,n" + | Section_debug_info s -> sprintf ".section .debug_info%s,,n" (if s <> ".text" then s else "") + | Section_debug_abbrev -> ".section .debug_abbrev,,n" + | Section_debug_loc -> ".section .debug_loc,,n" let section oc sec = let name = name_of_section sec in assert (name <> "COMM"); - fprintf oc " %s\n" name - + match sec with + | Section_debug_info s -> + fprintf oc " %s\n" name; + if s <> ".text" then + fprintf oc " .sectionlink .debug_info\n" + | _ -> + fprintf oc " %s\n" name let print_file_line oc file line = print_file_line_d2 oc comment file line @@ -233,73 +238,51 @@ module Diab_System : SYSTEM = let cfi_rel_offset oc reg ofs = () let print_prologue oc = - fprintf oc " .xopt align-fill-text=0x60000000\n"; - if !Clflags.option_g then - begin - fprintf oc " .text\n"; - fprintf oc " .section .debug_line,,n\n"; - let label_line_start = new_label () in - stmt_list_addr := label_line_start; - fprintf oc "%a:\n" label label_line_start; - fprintf oc " .text\n"; - let label_start = new_label () in - start_addr := label_start; - fprintf oc "%a:\n" label label_start; - let d_start = new_label() in - debug_start_addr := d_start; - fprintf oc " .0byte %a\n" label d_start; - fprintf oc " .d2_line_start .debug_line\n"; - end - - let filenum : (string,int) Hashtbl.t = Hashtbl.create 7 - - module StringSet = Set.Make(String) - - let additional_debug_sections: StringSet.t ref = ref StringSet.empty + fprintf oc " .xopt align-fill-text=0x60000000\n" let print_epilogue oc = - if !Clflags.option_g then - begin - fprintf oc "\n"; - let label_end = new_label () in - end_addr := label_end; - fprintf oc "%a:\n" label label_end; - fprintf oc " .text\n"; - Debug.all_files_iter (fun file -> - let label = new_label () in - Hashtbl.add filenum file label; - fprintf oc ".L%d: .d2filenum \"%s\"\n" label file); - fprintf oc " .d2_line_end\n"; - StringSet.iter (fun s -> - if s <> (name_of_section Section_text) then - begin - fprintf oc " %s\n" s; - fprintf oc " .d2_line_end\n" - end) !additional_debug_sections - end + let end_label sec = + fprintf oc "\n"; + fprintf oc " %s\n" sec; + let label_end = new_label () in + fprintf oc "%a:\n" label label_end; + label_end + and entry_label f = + let label = new_label () in + fprintf oc ".L%d: .d2filenum \"%s\"\n" label f; + label + and end_line () = fprintf oc " .d2_line_end\n" in + Debug.compute_file_enum end_label entry_label end_line let print_file_loc oc (file,col) = - fprintf oc " .4byte %a\n" label (Hashtbl.find filenum file); + fprintf oc " .4byte 1\n";(* label (Hashtbl.find filenum file);*) fprintf oc " .uleb128 %d\n" col let debug_section oc sec = - if !Clflags.option_g && Configuration.advanced_debug then - match sec with - | Section_user (name,_,_) -> - let sec_name = name_of_section sec in - if not (StringSet.mem sec_name !additional_debug_sections) && name <> ".text" then - begin - let name = ".debug_line"^name in - additional_debug_sections := StringSet.add sec_name !additional_debug_sections; - fprintf oc " .section %s,,n\n" name; - fprintf oc " .sectionlink .debug_line\n"; - section oc sec; - fprintf oc " .0byte %a\n" label !debug_start_addr; - fprintf oc " .d2_line_start %s\n" name - end - | _ -> () (* Only the case of a user section is interresting *) - else - () + match sec with + | Section_debug_abbrev + | Section_debug_info _ + | Section_debug_loc -> () + | sec -> + let name = match sec with + | Section_user (name,_,_) -> name + | _ -> name_of_section sec in + if not (Debug.exists_section name) then + let line_start = new_label () + and low_pc = new_label () + and debug_info = new_label () in + Debug.add_compilation_section_start name (line_start,low_pc,debug_info,name_of_section sec); + let line_name = ".debug_line" ^(if name <> ".text" then name else "") in + fprintf oc " .section %s,,n\n" line_name; + if name <> ".text" then + fprintf oc " .sectionlink .debug_line\n"; + fprintf oc "%a:\n" label line_start; + section oc sec; + fprintf oc "%a:\n" label low_pc; + fprintf oc " .0byte %a\n" label debug_info; + fprintf oc " .d2_line_start %s\n" line_name + else + () end -- cgit From 4e0ffb627524e3a251ee9e82ed88e1ed45e26b16 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 29 Sep 2015 16:02:56 +0200 Subject: Deactivate the debug functions for none advanced targets. --- debug/DebugInit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/debug/DebugInit.ml b/debug/DebugInit.ml index e0c435cd..6a50b020 100644 --- a/debug/DebugInit.ml +++ b/debug/DebugInit.ml @@ -74,7 +74,7 @@ let init_none () = implem.exists_section <- (fun _ -> true) let init () = - if !Clflags.option_g then + if !Clflags.option_g && Configuration.advanced_debug then init_debug () else init_none () -- cgit From 05acff8bcb4f127a6f0ff6c587ba38d1c8cbe2fc Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Tue, 29 Sep 2015 18:35:36 +0200 Subject: More fixes for the DebugInformation. Changed the sizeof function to take into account the bytes needed for the sleb128/uleb128 encoding of the DW_OP_* arguments and changed the end_live_range function to only close functions where the live range is currently open. --- debug/DebugInformation.ml | 21 ++++++++------------- debug/DwarfPrinter.ml | 9 ++------- debug/DwarfUtil.ml | 27 +++++++++++++++++++++++++++ debug/Dwarfgen.ml | 1 + 4 files changed, 38 insertions(+), 20 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 7866c339..73f9163a 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -256,10 +256,15 @@ let insert_type (ty: typ) = } in FunctionType ftype | TNamed (id,_) -> + let typ = try + let _,t = + List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in + Some (attr_aux t) + with Not_found -> None in let t = { typedef_file_loc = None; typedef_name = id.name; - typ = None; + typ = typ; } in Typedef t | TStruct (id,_) -> @@ -749,17 +754,7 @@ let end_live_range atom lbl = let old_r = Hashtbl.find var_locations atom in match old_r with | RangeLoc (n_r::old_r) -> - let n_r = {n_r with range_end = Some lbl} in - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) - | _ -> assert false - with Not_found -> () - -let close_range lbl atom = - try - let old_r = Hashtbl.find var_locations atom in - match old_r with - | RangeLoc (n_r::old_r) -> - if n_r.range_end = None then + if n_r.range_end = None then (* We can skip non open locations *) let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) | _ -> assert false @@ -771,7 +766,7 @@ let stack_variable atom (sp,loc) = let function_end atom loc = IntSet.iter (fun id -> close_scope atom id loc) !open_scopes; open_scopes := IntSet.empty; - List.iter (close_range loc) !open_vars; + List.iter (fun atom -> end_live_range atom loc) !open_vars; open_vars:= [] let compilation_section_start: (string,int * int * int * string) Hashtbl.t = Hashtbl.create 7 diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index aa1c187f..a95c71a1 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -303,12 +303,6 @@ module DwarfPrinter(Target: DWARF_TARGET): print_uleb128 oc col | None -> () - let size_of_loc_expr = function - | DW_OP_bregx _ -> 3 - | DW_OP_plus_uconst _ -> 2 - | DW_OP_piece _ -> 2 - | DW_OP_reg i -> if i < 32 then 1 else 2 - let print_loc_expr oc = function | DW_OP_bregx (a,b) -> print_byte oc dw_op_bregx; @@ -316,7 +310,7 @@ module DwarfPrinter(Target: DWARF_TARGET): fprintf oc " .sleb128 %ld\n" b | DW_OP_plus_uconst i -> print_byte oc dw_op_plus_uconst; - print_byte oc i + print_uleb128 oc i | DW_OP_piece i -> print_byte oc dw_op_piece; print_uleb128 oc i @@ -360,6 +354,7 @@ module DwarfPrinter(Target: DWARF_TARGET): let print_data_location oc dl = match dl with | DataLocBlock e -> + print_sleb128 oc (size_of_loc_expr e); print_loc_expr oc e | _ -> () diff --git a/debug/DwarfUtil.ml b/debug/DwarfUtil.ml index e1869281..16e446ee 100644 --- a/debug/DwarfUtil.ml +++ b/debug/DwarfUtil.ml @@ -113,3 +113,30 @@ let data_location_block_type_abbr = dw_form_block let data_location_ref_type_abbr = dw_form_ref4 let bound_const_type_abbr = dw_form_udata let bound_ref_type_abbr=dw_form_ref4 + +(* Sizeof functions for the encoding of uleb128 and sleb128 *) +let sizeof_uleb128 value = + let size = ref 1 in + let value = ref (value lsr 7) in + while !value <> 0 do + value := !value lsr 7; + incr size; + done; + !size + +let sizeof_sleb128 value = + let size = ref 1 in + let byte = ref (value land 0x7f) in + let value = ref (value lsr 7) in + while not ((!value = 0 && (!byte land 0x40) = 0) || (!value = -1 && ((!byte land 0x40) <> 0))) do + byte := !value land 0x7f; + value := !value lsr 7; + incr size; + done; + !size + +let size_of_loc_expr = function + | DW_OP_bregx (a,b) -> 1 + (sizeof_uleb128 a) + (sizeof_sleb128 (Int32.to_int b)) + | DW_OP_plus_uconst a + | DW_OP_piece a -> 1 + (sizeof_uleb128 a) + | DW_OP_reg i -> if i < 32 then 1 else 2 diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 3239ceb6..ac32f9f1 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -235,6 +235,7 @@ let needs_types id d = | Void | EnumType _ -> d,false | Typedef t -> + Printf.printf "Typedef %s\n" t.typedef_name; add_type (get_opt_val t.typ) d | PointerType p -> add_type p.pts d -- cgit From c0757aa180c54ff61093e8079ef58b77775ba28e Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 30 Sep 2015 11:13:34 +0200 Subject: Avoid problem with implict declarations. In order to avoid the problem that the stamp is not correct for implict declarations I insert all possible stamps of a function into my mapping and assign them one debug id. --- debug/DebugInformation.ml | 21 ++++++++++++++++++--- debug/Dwarfgen.ml | 1 - 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 73f9163a..3bf26e53 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -387,6 +387,9 @@ let definitions: (int,definition_type) Hashtbl.t = Hashtbl.create 7 (* Mapping from stamp to debug id *) let stamp_to_definition: (int,int) Hashtbl.t = Hashtbl.create 7 +(* Mapping from name to debug id *) +let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7 + (* Mapping from atom to debug id *) let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7 @@ -510,8 +513,13 @@ let insert_global_declaration env dec= let id,var = find_gvar_stamp id.stamp in replace_var id ({var with gvar_declaration = false;}) end - end - | Gfundef f -> + end else if not (Hashtbl.mem name_to_definition id.name) then begin + (* Implict declarations need special handling *) + let id' = next_id () in + Hashtbl.add stamp_to_definition id.stamp id'; + Hashtbl.add name_to_definition id.name id' + end + | Gfundef f -> let ret = (match f.fd_ret with | TVoid _ -> None | _ -> Some (insert_type f.fd_ret)) in @@ -539,7 +547,13 @@ let insert_global_declaration env dec= fun_high_pc = None; fun_scope = None; } in - insert (Function fd) f.fd_name.stamp + begin try + let id' = Hashtbl.find name_to_definition f.fd_name.name in + Hashtbl.add stamp_to_definition f.fd_name.stamp id'; + Hashtbl.add definitions id' (Function fd) + with Not_found -> + insert (Function fd) f.fd_name.stamp + end | Gcompositedecl (sou,id,at) -> ignore (insert_type (gen_comp_typ sou id at)); let id = find_type (gen_comp_typ sou id []) in @@ -798,6 +812,7 @@ let init name = Hashtbl.reset lookup_types; Hashtbl.reset definitions; Hashtbl.reset stamp_to_definition; + Hashtbl.reset name_to_definition; Hashtbl.reset atom_to_definition; Hashtbl.reset local_variables; Hashtbl.reset stamp_to_local; diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index ac32f9f1..3239ceb6 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -235,7 +235,6 @@ let needs_types id d = | Void | EnumType _ -> d,false | Typedef t -> - Printf.printf "Typedef %s\n" t.typedef_name; add_type (get_opt_val t.typ) d | PointerType p -> add_type p.pts d -- cgit From ee76d81e0e7d8a76cd31bf0d01a532d248dca45a Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 30 Sep 2015 12:43:49 +0200 Subject: Fixed minor issue with parameters that get put on the stack, made the code more robust and added indentation for convertCompositeDef --- cfrontend/C2C.ml | 10 ++++++---- debug/DebugInformation.ml | 19 ++++++++----------- powerpc/Asmexpand.ml | 6 ++++-- 3 files changed, 18 insertions(+), 17 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 332665f4..bd281374 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -524,10 +524,12 @@ let convertField env f = (intern_string f.fld_name, convertTyp env f.fld_typ) let convertCompositedef env su id attr members = - let t = match su with C.Struct -> - let layout = Cutil.struct_layout env members in - List.iter (fun (a,b) -> Debug.set_member_offset id a b) layout; - TStruct (id,attr) | C.Union -> TUnion (id,attr) in + let t = match su with + | C.Struct -> + let layout = Cutil.struct_layout env members in + List.iter (fun (a,b) -> Debug.set_member_offset id a b) layout; + TStruct (id,attr) + | C.Union -> TUnion (id,attr) in Debug.set_composite_size id su (Cutil.sizeof env t); Composite(intern_string id.name, begin match su with C.Struct -> Struct | C.Union -> Union end, diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 3bf26e53..382845a4 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -752,16 +752,13 @@ let close_scope atom s_id lbl = with Not_found -> () let start_live_range atom lbl loc = - let old_r = try - begin - match Hashtbl.find var_locations atom with - | RangeLoc old_r -> old_r - | _ -> assert false - end - with Not_found -> [] in - let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in - open_vars := atom::!open_vars; - Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + let old_r = begin try Hashtbl.find var_locations atom with Not_found -> (RangeLoc []) end in + match old_r with + | RangeLoc old_r -> + let n_r = { range_start = Some lbl; range_end = None; var_loc = loc } in + open_vars := atom::!open_vars; + Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) + | _ -> () (* Parameter that is passed as variable *) let end_live_range atom lbl = try @@ -771,7 +768,7 @@ let end_live_range atom lbl = if n_r.range_end = None then (* We can skip non open locations *) let n_r = {n_r with range_end = Some lbl} in Hashtbl.replace var_locations atom (RangeLoc (n_r::old_r)) - | _ -> assert false + | _ -> () with Not_found -> () let stack_variable atom (sp,loc) = diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 80aa333e..050380ae 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -615,7 +615,7 @@ let preg_to_dwarf_int = function | _ -> assert false -let translate_annot a = +let translate_annot annot = let rec aux = function | BA x -> Some (BA (preg_to_dwarf_int x)) | BA_int _ @@ -632,7 +632,9 @@ let translate_annot a = | Some hi ,Some lo -> Some (BA_splitlong (hi,lo)) | _,_ -> None end in - aux (List.hd a) + (match annot with + | [] -> None + | a::_ -> aux a) let expand_scope id lbl oldscopes newscopes = let opening = List.filter (fun a -> not (List.mem a oldscopes)) newscopes -- cgit