aboutsummaryrefslogtreecommitdiffstats
path: root/tools/debugger/pdb/PDB.ml
diff options
context:
space:
mode:
Diffstat (limited to 'tools/debugger/pdb/PDB.ml')
-rw-r--r--tools/debugger/pdb/PDB.ml264
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-12 14:25:48 +0000