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. --- debug/Debug.ml | 19 +++++--- debug/Debug.mli | 5 +- debug/DebugInformation.ml | 39 ++++++++-------- debug/DwarfPrinter.ml | 12 ++--- debug/DwarfTypes.mli | 4 +- debug/Dwarfgen.ml | 117 +++++++++++++++++++++++++++++++++++++++------- 6 files changed, 142 insertions(+), 54 deletions(-) (limited to 'debug') 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) -- cgit