diff options
Diffstat (limited to 'tools/debugger/pdb/debugger.ml')
| -rw-r--r-- | tools/debugger/pdb/debugger.ml | 372 |
1 files changed, 0 insertions, 372 deletions
diff --git a/tools/debugger/pdb/debugger.ml b/tools/debugger/pdb/debugger.ml deleted file mode 100644 index aa741a4566..0000000000 --- a/tools/debugger/pdb/debugger.ml +++ /dev/null @@ -1,372 +0,0 @@ -(** debugger.ml - * - * main debug functionality - * - * @author copyright (c) 2005 alex ho - * @see <www.cl.cam.ac.uk/netos/pdb> pervasive debugger - * @version 1 - *) - -open Intel -open PDB -open Util -open Str - -let initialize_debugger () = - () - -let exit_debugger () = - () - - -(** - Detach Command - Note: response is ignored by gdb. We leave the context in the - hash. It will be cleaned up with the socket is closed. - *) -let gdb_detach ctx = - PDB.detach_debugger ctx - -(** - Kill Command - Note: response is ignored by gdb. We leave the context in the - hash. It will be cleaned up with the socket is closed. - *) -let gdb_kill () = - "" - - - -(** - Continue Command. - resume the target - *) -let gdb_continue ctx = - PDB.continue ctx; - raise No_reply - -(** - Step Command. - single step the target - *) -let gdb_step ctx = - PDB.step ctx; - raise No_reply - -(** - Read Register Command. - return register as a 4-byte value. - *) -let gdb_read_register ctx command = - let read_reg register = - (Printf.sprintf "%08lx" (Util.flip_int32 (PDB.read_register ctx register))) - in - Scanf.sscanf command "p%x" read_reg - - -(** - Read Registers Command. - returns 16 4-byte registers in a particular format defined by gdb. - *) -let gdb_read_registers ctx = - let regs = PDB.read_registers ctx in - let str = - (Printf.sprintf "%08lx" (Util.flip_int32 regs.eax)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.ecx)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.edx)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.ebx)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.esp)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.ebp)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.esi)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.edi)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.eip)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.efl)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.cs)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.ss)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.ds)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.es)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.fs)) ^ - (Printf.sprintf "%08lx" (Util.flip_int32 regs.gs)) in - str - -(** - Set Thread Command - *) -let gdb_set_thread command = - "OK" - - -(** - Read Memory Packets - *) -let gdb_read_memory ctx command = - let int_list_to_string i str = - (Printf.sprintf "%02x" i) ^ str - in - let read_mem addr len = - try - let mem = PDB.read_memory ctx addr len in - List.fold_right int_list_to_string mem "" - with - Failure s -> "E02" - in - Scanf.sscanf command "m%lx,%x" read_mem - - - -(** - Write Memory Packets - *) -let gdb_write_memory ctx command = - let write_mem addr len = - print_endline (Printf.sprintf " gdb_write_memory %lx %x\n" addr len); - print_endline (Printf.sprintf " [[ unimplemented ]]\n") - in - Scanf.sscanf command "M%lx,%d" write_mem; - "OK" - - - -(** - Write Register Packets - *) -let gdb_write_register ctx command = - let write_reg reg goofy_val = - let new_val = Util.flip_int32 goofy_val in - match reg with - | 0 -> PDB.write_register ctx EAX new_val - | 1 -> PDB.write_register ctx ECX new_val - | 2 -> PDB.write_register ctx EDX new_val - | 3 -> PDB.write_register ctx EBX new_val - | 4 -> PDB.write_register ctx ESP new_val - | 5 -> PDB.write_register ctx EBP new_val - | 6 -> PDB.write_register ctx ESI new_val - | 7 -> PDB.write_register ctx EDI new_val - | 8 -> PDB.write_register ctx EIP new_val - | 9 -> PDB.write_register ctx EFL new_val - | 10 -> PDB.write_register ctx CS new_val - | 11 -> PDB.write_register ctx SS new_val - | 12 -> PDB.write_register ctx DS new_val - | 13 -> PDB.write_register ctx ES new_val - | 14 -> PDB.write_register ctx FS new_val - | 15 -> PDB.write_register ctx GS new_val - | _ -> print_endline (Printf.sprintf "write unknown register [%d]" reg) - in - Scanf.sscanf command "P%x=%lx" write_reg; - "OK" - - -(** - General Query Packets - *) -let gdb_query command = - match command with - | "qC" -> "" - | "qOffsets" -> "" - | "qSymbol::" -> "" - | _ -> - print_endline (Printf.sprintf "unknown gdb query packet [%s]" command); - "E01" - - -(** - Write Memory Binary Packets - *) -let gdb_write_memory_binary ctx command = - let write_mem addr len = - let pos = Str.search_forward (Str.regexp ":") command 0 in - let txt = Str.string_after command (pos + 1) in - PDB.write_memory ctx addr (int_list_of_string txt len) - in - Scanf.sscanf command "X%lx,%d" write_mem; - "OK" - - - -(** - Last Signal Command - *) -let gdb_last_signal = - "S00" - - - - -(** - Process PDB extensions to the GDB serial protocol. - Changes the mutable context state. - *) -let pdb_extensions command sock = - let process_extension key value = - (* since this command can change the context, - we need to grab it again each time *) - let ctx = PDB.find_context sock in - match key with - | "status" -> - PDB.debug_contexts (); - (* print_endline ("debugger status"); - debugger_status () - *) - | "context" -> - PDB.add_context sock (List.hd value) - (int_list_of_string_list (List.tl value)) - | _ -> failwith (Printf.sprintf "unknown pdb extension command [%s:%s]" - key (List.hd value)) - in - try - Util.little_parser process_extension - (String.sub command 1 ((String.length command) - 1)); - "OK" - with - | Unknown_context s -> - print_endline (Printf.sprintf "unknown context [%s]" s); - "E01" - | Unknown_domain -> "E01" - | Failure s -> "E01" - - -(** - Insert Breakpoint or Watchpoint Packet - *) - -let bwc_watch_write = 102 (* from pdb_module.h *) -let bwc_watch_read = 103 -let bwc_watch_access = 104 - -let gdb_insert_bwcpoint ctx command = - let insert cmd addr length = - try - match cmd with - | 0 -> PDB.insert_memory_breakpoint ctx addr length; "OK" - | 2 -> PDB.insert_watchpoint ctx bwc_watch_write addr length; "OK" - | 3 -> PDB.insert_watchpoint ctx bwc_watch_read addr length; "OK" - | 4 -> PDB.insert_watchpoint ctx bwc_watch_access addr length; "OK" - | _ -> "" - with - Failure s -> "E03" - in - Scanf.sscanf command "Z%d,%lx,%x" insert - -(** - Remove Breakpoint or Watchpoint Packet - *) -let gdb_remove_bwcpoint ctx command = - let insert cmd addr length = - try - match cmd with - | 0 -> PDB.remove_memory_breakpoint ctx addr length; "OK" - | 2 -> PDB.remove_watchpoint ctx bwc_watch_write addr length; "OK" - | 3 -> PDB.remove_watchpoint ctx bwc_watch_read addr length; "OK" - | 4 -> PDB.remove_watchpoint ctx bwc_watch_access addr length; "OK" - | _ -> "" - with - Failure s -> "E04" - in - Scanf.sscanf command "z%d,%lx,%d" insert - -(** - Do Work! - - @param command char list - *) - -let process_command command sock = - let ctx = PDB.find_context sock in - try - match command.[0] with - | 'c' -> gdb_continue ctx - | 'D' -> gdb_detach ctx - | 'g' -> gdb_read_registers ctx - | 'H' -> gdb_set_thread command - | 'k' -> gdb_kill () - | 'm' -> gdb_read_memory ctx command - | 'M' -> gdb_write_memory ctx command - | 'p' -> gdb_read_register ctx command - | 'P' -> gdb_write_register ctx command - | 'q' -> gdb_query command - | 's' -> gdb_step ctx - | 'x' -> pdb_extensions command sock - | 'X' -> gdb_write_memory_binary ctx command - | '?' -> gdb_last_signal - | 'z' -> gdb_remove_bwcpoint ctx command - | 'Z' -> gdb_insert_bwcpoint ctx command - | _ -> - print_endline (Printf.sprintf "unknown gdb command [%s]" command); - "" - with - Unimplemented s -> - print_endline (Printf.sprintf "loser. unimplemented command [%s][%s]" - command s); - "E03" - -(** - process_xen_domain - - This is called whenever a domain debug assist responds to a - pdb packet. -*) - -let process_xen_domain fd = - let channel = Evtchn.read fd in - let ctx = find_context fd in - - let (dom, pid, str) = - begin - match ctx with - | Xen_domain d -> Xen_domain.process_response (Xen_domain.get_ring d) - | _ -> failwith ("process_xen_domain called without Xen_domain context") - end - in - let sock = PDB.find_process dom pid in - print_endline (Printf.sprintf "(linux) dom:%d pid:%d %s %s" - dom pid str (Util.get_connection_info sock)); - Util.send_reply sock str; - Evtchn.unmask fd channel (* allow next virq *) - - -(** - process_xen_virq - - This is called each time a virq_pdb is sent from xen to dom 0. - It is sent by Xen when a domain hits a breakpoint. - - Think of this as the continuation function for a "c" or "s" command - issued to a domain. -*) - -external query_domain_stop : unit -> (int * int) list = "query_domain_stop" -(* returns a list of paused domains : () -> (domain, vcpu) list *) - -let process_xen_virq fd = - let channel = Evtchn.read fd in - let find_pair (dom, vcpu) = - print_endline (Printf.sprintf "checking %d.%d" dom vcpu); - try - let sock = PDB.find_domain dom vcpu in - true - with - Unknown_domain -> false - in - let dom_list = query_domain_stop () in - let (dom, vcpu) = List.find find_pair dom_list in - let vec = 3 in - let sock = PDB.find_domain dom vcpu in - print_endline (Printf.sprintf "handle bkpt dom:%d vcpu:%d vec:%d %s" - dom vcpu vec (Util.get_connection_info sock)); - Util.send_reply sock "S05"; - Evtchn.unmask fd channel (* allow next virq *) - - -(** - process_xen_xcs - - This is called each time the software assist residing in a backend - domain starts up. The control message includes the address of a - shared ring page and our end of an event channel (which indicates - when data is available on the ring). -*) - -let process_xen_xcs xcs_fd = - let (local_evtchn_fd, evtchn, dom, ring) = Xcs.read xcs_fd in - add_xen_domain_context local_evtchn_fd dom evtchn ring; - local_evtchn_fd |