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.

6 files changed, 142 insertions, 54 deletions

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)