Added translation of the range lists to location entries.

5 files changed, 98 insertions, 36 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