diff options
Diffstat (limited to 'tools/debugger/pdb/PDB.ml')
-rw-r--r-- | tools/debugger/pdb/PDB.ml | 264 |
1 files changed, 168 insertions, 96 deletions
diff --git a/tools/debugger/pdb/PDB.ml b/tools/debugger/pdb/PDB.ml index 0ed121b7aa..12ee1f00d8 100644 --- a/tools/debugger/pdb/PDB.ml +++ b/tools/debugger/pdb/PDB.ml @@ -13,92 +13,105 @@ exception Unknown_domain type context_t = | Void - | Event_channel + | Xen_virq + | Xen_xcs + | Xen_domain of Xen_domain.context_t | Domain of Domain.context_t | Process of Process.context_t let string_of_context ctx = match ctx with | Void -> "{void}" - | Event_channel -> "{event channel}" + | Xen_virq -> "{Xen virq evtchn}" + | Xen_xcs -> "{Xen xcs socket}" + | Xen_domain d -> Xen_domain.string_of_context d | Domain d -> Domain.string_of_context d | Process p -> Process.string_of_context p +let hash = Hashtbl.create 10 -let read_registers ctx = - match ctx with - | Domain d -> Domain.read_registers d - | _ -> Intel.null_registers - -let write_register ctx register value = - match ctx with - | Domain d -> Domain.write_register d register value - | _ -> raise (Unimplemented "write register") - - -let read_memory ctx addr len = - match ctx with - | Domain d -> Domain.read_memory d addr len - | _ -> raise (Unimplemented "read memory") - -let write_memory ctx addr values = - match ctx with - | Domain d -> Domain.write_memory d addr values - | _ -> raise (Unimplemented "write memory") +(***************************************************************************) -let continue ctx = - match ctx with - | Domain d -> Domain.continue d - | _ -> raise (Unimplemented "continue") - -let step ctx = - match ctx with - | Domain d -> Domain.step d - | _ -> raise (Unimplemented "step") - +let find_context key = + try + Hashtbl.find hash key + with + Not_found -> + print_endline "error: (find_context) PDB context not found"; + raise Not_found -let insert_memory_breakpoint ctx addr len = - match ctx with - | Domain d -> Domain.insert_memory_breakpoint d addr len - | _ -> raise (Unimplemented "insert memory breakpoint") +let delete_context key = + Hashtbl.remove hash key -let remove_memory_breakpoint ctx addr len = - match ctx with - | Domain d -> Domain.remove_memory_breakpoint d addr len - | _ -> raise (Unimplemented "remove memory breakpoint") +(** + find_domain : Locate the socket associated with the context(s) + matching a particular (domain, vcpu) pair. if there are multiple + contexts (there shouldn't be), then return the first one. + *) +let find_domain dom vcpu = + let find key ctx list = + match ctx with + | Domain d -> + if (((Domain.get_domain d) = dom) && + ((Domain.get_execution_domain d) = vcpu)) + then + key :: list + else + list + | _ -> list + in + let sock_list = Hashtbl.fold find hash [] in + match sock_list with + | hd::tl -> hd + | [] -> raise Unknown_domain -let pause ctx = - match ctx with - | Domain d -> Domain.pause d - | _ -> raise (Unimplemented "pause target") +(** + find_xen_domain_context : fetch the socket associated with the + xen_domain context for a domain. if there are multiple contexts + (there shouldn't be), then return the first one. + *) +let find_xen_domain_context domain = + let find key ctx list = + match ctx with + | Xen_domain d -> + if ((Xen_domain.get_domain d) = domain) + then + key :: list + else + list + | _ -> list + in + let sock_list = Hashtbl.fold find hash [] in + match sock_list with + | hd::tl -> hd + | [] -> raise Unknown_domain let attach_debugger ctx = match ctx with | Domain d -> Domain.attach_debugger (Domain.get_domain d) (Domain.get_execution_domain d) + | Process p -> + begin + let xdom_sock = find_xen_domain_context (Process.get_domain p) in + let xdom_ctx = find_context xdom_sock in + match xdom_ctx with + | Xen_domain d -> + Process.attach_debugger p d + | _ -> failwith ("context has wrong xen domain type") + end | _ -> raise (Unimplemented "attach debugger") let detach_debugger ctx = match ctx with | Domain d -> Domain.detach_debugger (Domain.get_domain d) (Domain.get_execution_domain d) + | Process p -> Process.detach_debugger p | _ -> raise (Unimplemented "detach debugger") -external open_debugger : unit -> unit = "open_context" -external close_debugger : unit -> unit = "close_context" - -(* this is just the domains right now... expand to other contexts later *) -external debugger_status : unit -> unit = "debugger_status" - - -(***********************************************************) - - -let hash = Hashtbl.create 10 let debug_contexts () = print_endline "context list:"; @@ -106,14 +119,19 @@ let debug_contexts () = match ctx with | Void -> print_endline (Printf.sprintf " [%s] {void}" (Util.get_connection_info key)) - | Event_channel -> print_endline (Printf.sprintf " [%s] {event_channel}" - (Util.get_connection_info key)) + | Xen_virq -> print_endline (Printf.sprintf " [%s] {xen virq evtchn}" + (Util.get_connection_info key)) + | Xen_xcs -> print_endline (Printf.sprintf " [%s] {xen xcs socket}" + (Util.get_connection_info key)) + | Xen_domain d -> print_endline (Printf.sprintf " [%s] %s" + (Util.get_connection_info key) + (Xen_domain.string_of_context d)) + | Domain d -> print_endline (Printf.sprintf " [%s] %s" + (Util.get_connection_info key) + (Domain.string_of_context d)) | Process p -> print_endline (Printf.sprintf " [%s] %s" - (Util.get_connection_info key) - (Process.string_of_context p)) - | Domain d -> print_endline (Printf.sprintf " [%s] %s" - (Util.get_connection_info key) - (Domain.string_of_context d)) + (Util.get_connection_info key) + (Process.string_of_context p)) in Hashtbl.iter print_context hash @@ -123,13 +141,14 @@ let debug_contexts () = *) let add_context (key:Unix.file_descr) context params = match context with - | "void" -> Hashtbl.replace hash key Void - | "event channel" -> Hashtbl.replace hash key Event_channel + | "void" -> Hashtbl.replace hash key Void + | "xen virq" -> Hashtbl.replace hash key Xen_virq + | "xen xcs" -> Hashtbl.replace hash key Xen_xcs | "domain" -> begin match params with - | dom::exec_dom::_ -> - let d = Domain(Domain.new_context dom exec_dom) in + | dom::vcpu::_ -> + let d = Domain(Domain.new_context dom vcpu) in attach_debugger d; Hashtbl.replace hash key d | _ -> failwith "bogus parameters to domain context" @@ -138,43 +157,96 @@ let add_context (key:Unix.file_descr) context params = begin match params with | dom::pid::_ -> - let p = Process.new_context dom pid in - Hashtbl.replace hash key (Process(p)) + let p = Process(Process.new_context dom pid) in + attach_debugger p; + Hashtbl.replace hash key p | _ -> failwith "bogus parameters to process context" end + | "xen domain" | _ -> raise (Unknown_context context) +(* + * this is really bogus. add_xen_domain_context should really + * be a case within add_context. however, we need to pass in + * a pointer that can only be represented as an int32. + * this would require a different type for params... :( + * 31 bit integers suck. + *) +let add_xen_domain_context (key:Unix.file_descr) dom evtchn sring = + let d = Xen_domain.new_context dom evtchn sring in + Hashtbl.replace hash key (Xen_domain(d)) + + let add_default_context sock = add_context sock "void" [] -let find_context key = - try - Hashtbl.find hash key - with - Not_found -> - print_endline "error: (find_context) PDB context not found"; - raise Not_found +(***************************************************************************) -let delete_context key = - Hashtbl.remove hash key +(***************************************************************************) -(** find_domain : Locate the context(s) matching a particular domain - * and execution_domain pair. - *) +let read_registers ctx = + match ctx with + | Void -> Intel.null_registers (* default for startup *) + | Domain d -> Domain.read_registers d + | Process p -> Process.read_registers p + | _ -> raise (Unimplemented "read registers") + +let write_register ctx register value = + match ctx with + | Domain d -> Domain.write_register d register value + | Process p -> Process.write_register p register value + | _ -> raise (Unimplemented "write register") + + +let read_memory ctx addr len = + match ctx with + | Domain d -> Domain.read_memory d addr len + | Process p -> Process.read_memory p addr len + | _ -> raise (Unimplemented "read memory") + +let write_memory ctx addr values = + match ctx with + | Domain d -> Domain.write_memory d addr values + | Process p -> Process.write_memory p addr values + | _ -> raise (Unimplemented "write memory") + + +let continue ctx = + match ctx with + | Domain d -> Domain.continue d + | Process p -> Process.continue p + | _ -> raise (Unimplemented "continue") + +let step ctx = + match ctx with + | Domain d -> Domain.step d + | Process p -> Process.step p + | _ -> raise (Unimplemented "step") + + +let insert_memory_breakpoint ctx addr len = + match ctx with + | Domain d -> Domain.insert_memory_breakpoint d addr len + | Process p -> Process.insert_memory_breakpoint p addr len + | _ -> raise (Unimplemented "insert memory breakpoint") + +let remove_memory_breakpoint ctx addr len = + match ctx with + | Domain d -> Domain.remove_memory_breakpoint d addr len + | Process p -> Process.remove_memory_breakpoint p addr len + | _ -> raise (Unimplemented "remove memory breakpoint") + + +let pause ctx = + match ctx with + | Domain d -> Domain.pause d + | Process p -> Process.pause p + | _ -> raise (Unimplemented "pause target") + + +external open_debugger : unit -> unit = "open_context" +external close_debugger : unit -> unit = "close_context" + +(* this is just the domains right now... expand to other contexts later *) +external debugger_status : unit -> unit = "debugger_status" -let find_domain dom exec_dom = - let find key ctx list = - match ctx with - | Domain d -> - if (((Domain.get_domain d) = dom) && - ((Domain.get_execution_domain d) = exec_dom)) - then - key :: list - else - list - | _ -> list - in - let sock_list = Hashtbl.fold find hash [] in - match sock_list with - | hd::tl -> hd - | [] -> raise Unknown_domain |