l4/pkg/ocaml/contrib/debugger/symbols.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
   6 (*          Objective Caml port by John Malecki and Xavier Leroy       *)
   7 (*                                                                     *)
   8 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed    *)
  10 (*  under the terms of the Q Public License version 1.0.               *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: symbols.ml 9300 2009-06-18 11:17:16Z xclerc $ *)
  15
  16 (* Handling of symbol tables (globals and events) *)
  17
  18 open Instruct
  19 open Debugger_config (* Toplevel *)
  20 open Program_loading
  21
  22 let modules =
  23   ref ([] : string list)
  24
  25 let events =
  26   ref ([] : debug_event list)
  27 let events_by_pc =
  28   (Hashtbl.create 257 : (int, debug_event) Hashtbl.t)
  29 let events_by_module =
  30   (Hashtbl.create 17 : (string, debug_event array) Hashtbl.t)
  31 let all_events_by_module =
  32   (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t)
  33
  34 let relocate_event orig ev =
  35   ev.ev_pos <- orig + ev.ev_pos;
  36   match ev.ev_repr with
  37     Event_parent repr -> repr := ev.ev_pos
  38   | _                 -> ()
  39
  40 let read_symbols' bytecode_file =
  41   let ic = open_in_bin bytecode_file in
  42   begin try
  43     Bytesections.read_toc ic;
  44     ignore(Bytesections.seek_section ic "SYMB");
  45   with Bytesections.Bad_magic_number | Not_found ->
  46     prerr_string bytecode_file; prerr_endline " is not a bytecode file.";
  47     raise Toplevel
  48   end;
  49   Symtable.restore_state (input_value ic);
  50   begin try
  51     ignore (Bytesections.seek_section ic "DBUG")
  52   with Not_found ->
  53     prerr_string bytecode_file; prerr_endline " has no debugging info.";
  54     raise Toplevel
  55   end;
  56   let num_eventlists = input_binary_int ic in
  57   let eventlists = ref [] in
  58   for i = 1 to num_eventlists do
  59     let orig = input_binary_int ic in
  60     let evl = (input_value ic : debug_event list) in
  61     (* Relocate events in event list *)
  62     List.iter (relocate_event orig) evl;
  63     eventlists := evl :: !eventlists
  64   done;
  65   begin try
  66     ignore (Bytesections.seek_section ic "CODE")
  67   with Not_found ->
  68     (* The file contains only debugging info, loading mode is forced to "manual" *)
  69     set_launching_function (List.assoc "manual" loading_modes)
  70   end;
  71   close_in_noerr ic;
  72   !eventlists
  73
  74 let read_symbols bytecode_file =
  75   let all_events = read_symbols' bytecode_file in
  76
  77   modules := []; events := [];
  78   Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module;
  79   Hashtbl.clear all_events_by_module;
  80
  81   List.iter
  82     (fun evl ->
  83       List.iter
  84         (fun ev ->
  85           events := ev :: !events;
  86           Hashtbl.add events_by_pc ev.ev_pos ev)
  87         evl)
  88     all_events;
  89
  90   List.iter
  91     (function
  92         [] -> ()
  93       | ev :: _ as evl ->
  94           let md = ev.ev_module in
  95           let cmp ev1 ev2 = compare (Events.get_pos ev1).Lexing.pos_cnum
  96                                     (Events.get_pos ev2).Lexing.pos_cnum
  97           in
  98           let sorted_evl = List.sort cmp evl in
  99           modules := md :: !modules;
 100           Hashtbl.add all_events_by_module md sorted_evl;
 101           let real_evl =
 102             List.filter
 103               (function
 104                  {ev_kind = Event_pseudo} -> false
 105                | _                        -> true)
 106               sorted_evl
 107           in
 108           Hashtbl.add events_by_module md (Array.of_list real_evl))
 109     all_events
 110
 111 let any_event_at_pc pc =
 112   Hashtbl.find events_by_pc pc
 113
 114 let event_at_pc pc =
 115   let ev = any_event_at_pc pc in
 116   match ev.ev_kind with
 117     Event_pseudo -> raise Not_found
 118   | _            -> ev
 119
 120 let set_event_at_pc pc =
 121  try ignore(event_at_pc pc); Debugcom.set_event pc
 122  with Not_found -> ()
 123
 124 (* List all events in module *)
 125 let events_in_module mdle =
 126   try
 127     Hashtbl.find all_events_by_module mdle
 128   with Not_found ->
 129     []
 130
 131 (* Binary search of event at or just after char *)
 132 let find_event ev char =
 133   let rec bsearch lo hi =
 134     if lo >= hi then begin
 135       if (Events.get_pos ev.(hi)).Lexing.pos_cnum < char
 136       then raise Not_found
 137       else hi
 138     end else begin
 139       let pivot = (lo + hi) / 2 in
 140       let e = ev.(pivot) in
 141       if char <= (Events.get_pos e).Lexing.pos_cnum
 142       then bsearch lo pivot
 143       else bsearch (pivot + 1) hi
 144     end
 145   in
 146   bsearch 0 (Array.length ev - 1)
 147
 148 (* Return first event after the given position. *)
 149 (* Raise [Not_found] if module is unknown or no event is found. *)
 150 let event_at_pos md char =
 151   let ev = Hashtbl.find events_by_module md in
 152   ev.(find_event ev char)
 153
 154 (* Return event closest to given position *)
 155 (* Raise [Not_found] if module is unknown or no event is found. *)
 156 let event_near_pos md char =
 157   let ev = Hashtbl.find events_by_module md in
 158   try
 159     let pos = find_event ev char in
 160     (* Desired event is either ev.(pos) or ev.(pos - 1),
 161        whichever is closest *)
 162     if pos > 0 && char - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum
 163                   <= (Events.get_pos ev.(pos)).Lexing.pos_cnum - char
 164     then ev.(pos - 1)
 165     else ev.(pos)
 166   with Not_found ->
 167     let pos = Array.length ev - 1 in
 168     if pos < 0 then raise Not_found;
 169     ev.(pos)
 170
 171 (* Flip "event" bit on all instructions *)
 172 let set_all_events () =
 173   Hashtbl.iter
 174     (fun pc ev ->
 175        match ev.ev_kind with
 176          Event_pseudo -> ()
 177        | _            -> Debugcom.set_event ev.ev_pos)
 178     events_by_pc
 179
 180
 181 (* Previous `pc'. *)
 182 (* Save time if `update_current_event' is called *)
 183 (* several times at the same point. *)
 184 let old_pc = ref (None : int option)
 185
 186 (* Recompute the current event *)
 187 let update_current_event () =
 188   match Checkpoints.current_pc () with
 189     None ->
 190       Events.current_event := None;
 191       old_pc := None
 192   | (Some pc) as opt_pc when opt_pc <> !old_pc ->
 193       Events.current_event :=
 194         begin try
 195           Some (event_at_pc pc)
 196         with Not_found ->
 197           None
 198         end;
 199       old_pc := opt_pc
 200   | _ ->
 201       ()