(** 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