ia64/xen-unstable

view tools/debugger/pdb/debugger.ml @ 6538:84ee014ebd41

Merge xen-vtx-unstable.hg
author adsharma@los-vmm.sc.intel.com
date Wed Aug 17 12:34:38 2005 -0800 (2005-08-17)
parents 23979fb12c49 60d20acf8928
children 99914b54f7bf
line source
1 (** debugger.ml
2 *
3 * main debug functionality
4 *
5 * @author copyright (c) 2005 alex ho
6 * @see <www.cl.cam.ac.uk/netos/pdb> pervasive debugger
7 * @version 1
8 *)
10 open Intel
11 open PDB
12 open Util
13 open Str
15 let initialize_debugger () =
16 ()
18 let exit_debugger () =
19 ()
22 (**
23 Detach Command
24 Note: response is ignored by gdb. We leave the context in the
25 hash. It will be cleaned up with the socket is closed.
26 *)
27 let gdb_detach ctx =
28 PDB.detach_debugger ctx
30 (**
31 Kill Command
32 Note: response is ignored by gdb. We leave the context in the
33 hash. It will be cleaned up with the socket is closed.
34 *)
35 let gdb_kill () =
36 ""
40 (**
41 Continue Command.
42 resume the target
43 *)
44 let gdb_continue ctx =
45 PDB.continue ctx;
46 raise No_reply
48 (**
49 Step Command.
50 single step the target
51 *)
52 let gdb_step ctx =
53 PDB.step ctx;
54 raise No_reply
56 (**
57 Read Register Command.
58 return register as a 4-byte value.
59 *)
60 let gdb_read_register ctx command =
61 let read_reg register =
62 (Printf.sprintf "%08lx" (Util.flip_int32 (PDB.read_register ctx register)))
63 in
64 Scanf.sscanf command "p%x" read_reg
67 (**
68 Read Registers Command.
69 returns 16 4-byte registers in a particular format defined by gdb.
70 *)
71 let gdb_read_registers ctx =
72 let regs = PDB.read_registers ctx in
73 let str =
74 (Printf.sprintf "%08lx" (Util.flip_int32 regs.eax)) ^
75 (Printf.sprintf "%08lx" (Util.flip_int32 regs.ecx)) ^
76 (Printf.sprintf "%08lx" (Util.flip_int32 regs.edx)) ^
77 (Printf.sprintf "%08lx" (Util.flip_int32 regs.ebx)) ^
78 (Printf.sprintf "%08lx" (Util.flip_int32 regs.esp)) ^
79 (Printf.sprintf "%08lx" (Util.flip_int32 regs.ebp)) ^
80 (Printf.sprintf "%08lx" (Util.flip_int32 regs.esi)) ^
81 (Printf.sprintf "%08lx" (Util.flip_int32 regs.edi)) ^
82 (Printf.sprintf "%08lx" (Util.flip_int32 regs.eip)) ^
83 (Printf.sprintf "%08lx" (Util.flip_int32 regs.efl)) ^
84 (Printf.sprintf "%08lx" (Util.flip_int32 regs.cs)) ^
85 (Printf.sprintf "%08lx" (Util.flip_int32 regs.ss)) ^
86 (Printf.sprintf "%08lx" (Util.flip_int32 regs.ds)) ^
87 (Printf.sprintf "%08lx" (Util.flip_int32 regs.es)) ^
88 (Printf.sprintf "%08lx" (Util.flip_int32 regs.fs)) ^
89 (Printf.sprintf "%08lx" (Util.flip_int32 regs.gs)) in
90 str
92 (**
93 Set Thread Command
94 *)
95 let gdb_set_thread command =
96 "OK"
99 (**
100 Read Memory Packets
101 *)
102 let gdb_read_memory ctx command =
103 let int_list_to_string i str =
104 (Printf.sprintf "%02x" i) ^ str
105 in
106 let read_mem addr len =
107 try
108 let mem = PDB.read_memory ctx addr len in
109 List.fold_right int_list_to_string mem ""
110 with
111 Failure s -> "E02"
112 in
113 Scanf.sscanf command "m%lx,%x" read_mem
117 (**
118 Write Memory Packets
119 *)
120 let gdb_write_memory ctx command =
121 let write_mem addr len =
122 print_endline (Printf.sprintf " gdb_write_memory %lx %x\n" addr len);
123 print_endline (Printf.sprintf " [[ unimplemented ]]\n")
124 in
125 Scanf.sscanf command "M%lx,%d" write_mem;
126 "OK"
130 (**
131 Write Register Packets
132 *)
133 let gdb_write_register ctx command =
134 let write_reg reg goofy_val =
135 let new_val = Util.flip_int32 goofy_val in
136 match reg with
137 | 0 -> PDB.write_register ctx EAX new_val
138 | 1 -> PDB.write_register ctx ECX new_val
139 | 2 -> PDB.write_register ctx EDX new_val
140 | 3 -> PDB.write_register ctx EBX new_val
141 | 4 -> PDB.write_register ctx ESP new_val
142 | 5 -> PDB.write_register ctx EBP new_val
143 | 6 -> PDB.write_register ctx ESI new_val
144 | 7 -> PDB.write_register ctx EDI new_val
145 | 8 -> PDB.write_register ctx EIP new_val
146 | 9 -> PDB.write_register ctx EFL new_val
147 | 10 -> PDB.write_register ctx CS new_val
148 | 11 -> PDB.write_register ctx SS new_val
149 | 12 -> PDB.write_register ctx DS new_val
150 | 13 -> PDB.write_register ctx ES new_val
151 | 14 -> PDB.write_register ctx FS new_val
152 | 15 -> PDB.write_register ctx GS new_val
153 | _ -> print_endline (Printf.sprintf "write unknown register [%d]" reg)
154 in
155 Scanf.sscanf command "P%x=%lx" write_reg;
156 "OK"
159 (**
160 General Query Packets
161 *)
162 let gdb_query command =
163 match command with
164 | "qC" -> ""
165 | "qOffsets" -> ""
166 | "qSymbol::" -> ""
167 | _ ->
168 print_endline (Printf.sprintf "unknown gdb query packet [%s]" command);
169 "E01"
172 (**
173 Write Memory Binary Packets
174 *)
175 let gdb_write_memory_binary ctx command =
176 let write_mem addr len =
177 let pos = Str.search_forward (Str.regexp ":") command 0 in
178 let txt = Str.string_after command (pos + 1) in
179 PDB.write_memory ctx addr (int_list_of_string txt len)
180 in
181 Scanf.sscanf command "X%lx,%d" write_mem;
182 "OK"
186 (**
187 Last Signal Command
188 *)
189 let gdb_last_signal =
190 "S00"
195 (**
196 Process PDB extensions to the GDB serial protocol.
197 Changes the mutable context state.
198 *)
199 let pdb_extensions command sock =
200 let process_extension key value =
201 (* since this command can change the context,
202 we need to grab it again each time *)
203 let ctx = PDB.find_context sock in
204 match key with
205 | "status" ->
206 PDB.debug_contexts ();
207 (* print_endline ("debugger status");
208 debugger_status ()
209 *)
210 | "context" ->
211 PDB.add_context sock (List.hd value)
212 (int_list_of_string_list (List.tl value))
213 | _ -> failwith (Printf.sprintf "unknown pdb extension command [%s:%s]"
214 key (List.hd value))
215 in
216 try
217 Util.little_parser process_extension
218 (String.sub command 1 ((String.length command) - 1));
219 "OK"
220 with
221 | Unknown_context s ->
222 print_endline (Printf.sprintf "unknown context [%s]" s);
223 "E01"
224 | Unknown_domain -> "E01"
225 | Failure s -> "E01"
228 (**
229 Insert Breakpoint or Watchpoint Packet
230 *)
232 let bwc_watch_write = 102 (* from pdb_module.h *)
233 let bwc_watch_read = 103
234 let bwc_watch_access = 104
236 let gdb_insert_bwcpoint ctx command =
237 let insert cmd addr length =
238 try
239 match cmd with
240 | 0 -> PDB.insert_memory_breakpoint ctx addr length; "OK"
241 | 2 -> PDB.insert_watchpoint ctx bwc_watch_write addr length; "OK"
242 | 3 -> PDB.insert_watchpoint ctx bwc_watch_read addr length; "OK"
243 | 4 -> PDB.insert_watchpoint ctx bwc_watch_access addr length; "OK"
244 | _ -> ""
245 with
246 Failure s -> "E03"
247 in
248 Scanf.sscanf command "Z%d,%lx,%x" insert
250 (**
251 Remove Breakpoint or Watchpoint Packet
252 *)
253 let gdb_remove_bwcpoint ctx command =
254 let insert cmd addr length =
255 try
256 match cmd with
257 | 0 -> PDB.remove_memory_breakpoint ctx addr length; "OK"
258 | 2 -> PDB.remove_watchpoint ctx bwc_watch_write addr length; "OK"
259 | 3 -> PDB.remove_watchpoint ctx bwc_watch_read addr length; "OK"
260 | 4 -> PDB.remove_watchpoint ctx bwc_watch_access addr length; "OK"
261 | _ -> ""
262 with
263 Failure s -> "E04"
264 in
265 Scanf.sscanf command "z%d,%lx,%d" insert
267 (**
268 Do Work!
270 @param command char list
271 *)
273 let process_command command sock =
274 let ctx = PDB.find_context sock in
275 try
276 match command.[0] with
277 | 'c' -> gdb_continue ctx
278 | 'D' -> gdb_detach ctx
279 | 'g' -> gdb_read_registers ctx
280 | 'H' -> gdb_set_thread command
281 | 'k' -> gdb_kill ()
282 | 'm' -> gdb_read_memory ctx command
283 | 'M' -> gdb_write_memory ctx command
284 | 'p' -> gdb_read_register ctx command
285 | 'P' -> gdb_write_register ctx command
286 | 'q' -> gdb_query command
287 | 's' -> gdb_step ctx
288 | 'x' -> pdb_extensions command sock
289 | 'X' -> gdb_write_memory_binary ctx command
290 | '?' -> gdb_last_signal
291 | 'z' -> gdb_remove_bwcpoint ctx command
292 | 'Z' -> gdb_insert_bwcpoint ctx command
293 | _ ->
294 print_endline (Printf.sprintf "unknown gdb command [%s]" command);
295 ""
296 with
297 Unimplemented s ->
298 print_endline (Printf.sprintf "loser. unimplemented command [%s][%s]"
299 command s);
300 "E03"
302 (**
303 process_xen_domain
305 This is called whenever a domain debug assist responds to a
306 pdb packet.
307 *)
309 let process_xen_domain fd =
310 let channel = Evtchn.read fd in
311 let ctx = find_context fd in
313 let (dom, pid, str) =
314 begin
315 match ctx with
316 | Xen_domain d -> Xen_domain.process_response (Xen_domain.get_ring d)
317 | _ -> failwith ("process_xen_domain called without Xen_domain context")
318 end
319 in
320 let sock = PDB.find_process dom pid in
321 print_endline (Printf.sprintf "(linux) dom:%d pid:%d %s %s"
322 dom pid str (Util.get_connection_info sock));
323 Util.send_reply sock str;
324 Evtchn.unmask fd channel (* allow next virq *)
327 (**
328 process_xen_virq
330 This is called each time a virq_pdb is sent from xen to dom 0.
331 It is sent by Xen when a domain hits a breakpoint.
333 Think of this as the continuation function for a "c" or "s" command
334 issued to a domain.
335 *)
337 external query_domain_stop : unit -> (int * int) list = "query_domain_stop"
338 (* returns a list of paused domains : () -> (domain, vcpu) list *)
340 let process_xen_virq fd =
341 let channel = Evtchn.read fd in
342 let find_pair (dom, vcpu) =
343 print_endline (Printf.sprintf "checking %d.%d" dom vcpu);
344 try
345 let sock = PDB.find_domain dom vcpu in
346 true
347 with
348 Unknown_domain -> false
349 in
350 let dom_list = query_domain_stop () in
351 let (dom, vcpu) = List.find find_pair dom_list in
352 let vec = 3 in
353 let sock = PDB.find_domain dom vcpu in
354 print_endline (Printf.sprintf "handle bkpt dom:%d vcpu:%d vec:%d %s"
355 dom vcpu vec (Util.get_connection_info sock));
356 Util.send_reply sock "S05";
357 Evtchn.unmask fd channel (* allow next virq *)
360 (**
361 process_xen_xcs
363 This is called each time the software assist residing in a backend
364 domain starts up. The control message includes the address of a
365 shared ring page and our end of an event channel (which indicates
366 when data is available on the ring).
367 *)
369 let process_xen_xcs xcs_fd =
370 let (local_evtchn_fd, evtchn, dom, ring) = Xcs.read xcs_fd in
371 add_xen_domain_context local_evtchn_fd dom evtchn ring;
372 local_evtchn_fd