summaryrefslogtreecommitdiff
path: root/src/gdbmi.ml
diff options
context:
space:
mode:
Diffstat (limited to 'src/gdbmi.ml')
-rw-r--r--src/gdbmi.ml257
1 files changed, 257 insertions, 0 deletions
diff --git a/src/gdbmi.ml b/src/gdbmi.ml
new file mode 100644
index 00000000..faf3ac11
--- /dev/null
+++ b/src/gdbmi.ml
@@ -0,0 +1,257 @@
+(**************************************************************************)
+(* Sail *)
+(* *)
+(* Copyright (c) 2013-2017 *)
+(* Kathyrn Gray *)
+(* Shaked Flur *)
+(* Stephen Kell *)
+(* Gabriel Kerneis *)
+(* Robert Norton-Wright *)
+(* Christopher Pulte *)
+(* Peter Sewell *)
+(* Alasdair Armstrong *)
+(* Brian Campbell *)
+(* Thomas Bauereiss *)
+(* Anthony Fox *)
+(* Jon French *)
+(* Dominic Mulligan *)
+(* Stephen Kell *)
+(* Mark Wassell *)
+(* *)
+(* All rights reserved. *)
+(* *)
+(* This software was developed by the University of Cambridge Computer *)
+(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *)
+(* (REMS) project, funded by EPSRC grant EP/K008528/1. *)
+(* *)
+(* Redistribution and use in source and binary forms, with or without *)
+(* modification, are permitted provided that the following conditions *)
+(* are met: *)
+(* 1. Redistributions of source code must retain the above copyright *)
+(* notice, this list of conditions and the following disclaimer. *)
+(* 2. Redistributions in binary form must reproduce the above copyright *)
+(* notice, this list of conditions and the following disclaimer in *)
+(* the documentation and/or other materials provided with the *)
+(* distribution. *)
+(* *)
+(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *)
+(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *)
+(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *)
+(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *)
+(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *)
+(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *)
+(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *)
+(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *)
+(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *)
+(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *)
+(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *)
+(* SUCH DAMAGE. *)
+(**************************************************************************)
+
+open Ast
+open Ast_util
+open Printf
+open Gdbmi_types
+
+let parse_gdb_response str =
+ let lexbuf = Lexing.from_string str in
+ Gdbmi_parser.response_eof Gdbmi_lexer.token lexbuf
+
+type gdb_session = (in_channel * out_channel * in_channel) option
+
+let gdb_command = ref "gdb-multiarch"
+
+let gdb_token_counter = ref 0
+
+let gdb_token () =
+ incr gdb_token_counter;
+ !gdb_token_counter
+
+let not_connected = Reporting.err_general Parse_ast.Unknown "Not connected to gdb"
+
+let rec wait_for' regexp stdout =
+ let line = input_line stdout in
+ if Str.string_match regexp line 0 then (
+ line
+ ) else (
+ print_endline Util.(line |> dim |> clear);
+ wait_for' regexp stdout
+ )
+
+let wait_for token stdout =
+ let regexp = Str.regexp (sprintf "^%i\\^" token) in
+ wait_for' regexp stdout
+
+let wait_for_gdb stdout =
+ let regexp = Str.regexp_string "(gdb)" in
+ wait_for' regexp stdout
+
+let send_sync session cmd =
+ match session with
+ | None -> raise not_connected
+ | Some (stdout, stdin, _) ->
+ let token = gdb_token () in
+ let cmd = sprintf "%i-%s\n" token cmd in
+ print_string Util.(cmd |> yellow |> clear);
+ flush stdin;
+ output_string stdin cmd;
+ flush stdin;
+ wait_for token stdout
+
+let send_regular session cmd =
+ match session with
+ | None -> raise not_connected
+ | Some (stdout, stdin, _) ->
+ let token = gdb_token () in
+ print_endline Util.(cmd |> yellow |> clear);
+ flush stdin;
+ output_string stdin (cmd ^ "\n");
+ flush stdin;
+ ignore (wait_for_gdb stdout)
+
+let synced_registers = ref []
+
+let gdb_sync session =
+ let gdb_register_names = parse_gdb_response (send_sync session "data-list-register-names") in
+ let gdb_register_values = parse_gdb_response (send_sync session "data-list-register-values x") in
+ let names = match gdb_register_names with
+ | Result (_, "done", output) ->
+ List.assoc "register-names" output |> gdb_seq |> List.map gdb_string
+ | _ -> failwith "GDB could not get register names"
+ in
+ let values = match gdb_register_values with
+ | Result (_, "done", output) ->
+ List.assoc "register-values" output
+ |> gdb_seq
+ |> List.map gdb_assoc
+ |> List.map (List.assoc "value")
+ |> List.map gdb_string
+ | _ -> failwith "GDB could not get register names"
+ in
+ synced_registers := List.combine names values
+
+let gdb_list_registers session =
+ gdb_sync session;
+ List.iter (fun (name, value) ->
+ print_endline (sprintf "%s: %s" name value)
+ ) !synced_registers
+
+let gdb_read_mem session addr data_size =
+ let open Value in
+ let cmd = sprintf "data-read-memory %s x 1 1 %i" (Sail_lib.string_of_bits addr) (Big_int.to_int data_size) in
+ (* An example response looks something like:
+
+ 7^done,addr="0x0000000040009e64",nr-bytes="4",total-bytes="4",next-row="0x0000000040009e68",
+ prev-row="0x0000000040009e60",next-page="0x0000000040009e68",prev-page="0x0000000040009e60",
+ memory=[{addr="0x0000000040009e64",data=["0x03","0xfc","0x5a","0xd3"]}]
+ *)
+ match parse_gdb_response (send_sync session cmd) with
+ | Result (_, "done", output) ->
+ List.assoc "memory" output |> gdb_seq
+ |> List.hd |> gdb_assoc
+ |> List.assoc "data" |> gdb_seq
+ |> List.rev_map (fun byte -> Sail_lib.byte_of_int (int_of_string (gdb_string byte)))
+ |> List.concat
+
+ | _ -> failwith "Unexpected response from GDB"
+
+let value_gdb_read_ram session =
+ let open Value in
+ function
+ | [addr_size; data_size; _; addr] ->
+ mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int data_size))
+
+ | _ -> failwith "gdb_read_ram"
+
+let gdb_effect_interp session state eff =
+ let open Value in
+ let open Interpreter in
+ let lstate, gstate = state in
+ match eff with
+ | Read_mem (rk, addr, len, cont) ->
+ let result = mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int len)) in
+ cont result state
+ | Read_reg (name, cont) ->
+ begin match List.assoc_opt name !synced_registers with
+ | Some value ->
+ let value = mk_vector (Sail_lib.to_bits' (64, Big_int.of_string value)) in
+ cont value state
+ | None ->
+ cont (Bindings.find (mk_id name) gstate.registers) state
+ end
+ | Write_reg (name, v, cont) ->
+ let id = mk_id name in
+ if Bindings.mem id gstate.registers then
+ let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in
+ cont () state'
+ else
+ failwith ("Write of nonexistent register: " ^ name)
+ | _ ->
+ failwith "Unsupported in GDB state"
+
+let gdb_hooks session =
+ Value.add_primop "read_ram" (value_gdb_read_ram session);
+ Interpreter.set_effect_interp (gdb_effect_interp session)
+
+let () =
+ let open Interactive in
+ let session = ref None in
+
+ let gdb_start arg =
+ let stdout, stdin, stderr = Unix.open_process_full (sprintf "%s --interpreter=mi" !gdb_command) [||] in
+ session := Some (stdout, stdin, stderr);
+ wait_for_gdb stdout |> ignore;
+ if arg = "" then () else print_endline (send_sync !session arg)
+ in
+
+ let gdb_send arg =
+ if arg = "" then () else print_endline (send_sync !session arg)
+ in
+
+ register_command
+ ~name:"gdb_command"
+ ~help:"Use specified gdb. Default is gdb-multiarch. This is the \
+ correct version on Ubuntu, but other Linux distros and \
+ operating systems may differ in how they package gdb with \
+ support for multiple architectures."
+ (ArgString ("gdb", fun arg -> Action (fun () -> gdb_command := arg)));
+
+ register_command
+ ~name:"gdb_start"
+ ~help:"Start a child GDB process sending :0 as the first command, waiting for it to complete"
+ (ArgString ("command", fun cmd -> Action (fun () -> gdb_start cmd)));
+
+ (ArgString ("port", fun port -> Action (fun () ->
+ if port = "" then
+ gdb_start "target-select remote localhost:1234"
+ else
+ gdb_start ("target-select remote localhost:" ^ port)
+ ))) |> register_command
+ ~name:"gdb_qemu"
+ ~help:"Connect GDB to a remote QEMU target on localhost port :0 (default is 1234, as per -s option for QEMU)";
+
+ register_command
+ ~name:"gdb_send"
+ ~help:"Send a GDB/MI command to a child GDB process and wait for it to complete"
+ (ArgString ("command", fun cmd -> Action (fun () -> gdb_send cmd)));
+
+ register_command
+ ~name:"gdb_sync"
+ ~help:"Sync sail registers with GDB"
+ (Action (fun () -> gdb_sync !session));
+
+ register_command
+ ~name:"gdb_list_registers"
+ ~help:"Sync sail registers with GDB and list them"
+ (Action (fun () -> gdb_list_registers !session));
+
+ register_command
+ ~name:"gdb_hooks"
+ ~help:"Make reading and writing memory go via GDB"
+ (Action (fun () -> gdb_hooks !session));
+
+ (ArgString ("symbol_file", fun file -> Action (fun () ->
+ send_regular !session ("symbol-file " ^ file)
+ ))) |> register_command
+ ~name:"gdb_symbol_file"
+ ~help:"Load debugging symbols into GDB";
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-10 07:34:27 +0000