Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Dynlink support for ocamldebug 

This commit adds dynlink support for ocamldebug. As a side effect, it also:
  - factorizes the various functions searching for a code fragment into one,
    called [caml_find_code_fragment];
  - removes the [caml_register_code_fragment], which does not seem to
    be used anywhere, and which clearly should not be used by external code.
master
Jacques-Henri Jourdan 2019-05-02 17:05:15 +02:00
parent 430c20bb78
commit 593f94055a
52 changed files with 791 additions and 413 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Changes
View File

@ -52,6 +52,13 @@ Working version
OCaml callback when called from C.
(Jacques-Henri Jourdan, review by Stephen Dolan and Gabriel Scherer)
### Tools:
* #6792, #8654 ocamldebug now supports program using Dynlink. This
breaks compatibility with emacs modes.
(Whitequark and Jacques-Henri Jourdan, review by Gabriel Scherer
and Xavier Clerc)
### Standard library:
- #8657: Optimization in [Array.make] when initializing with unboxed

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

35
debugger/.depend
View File

@ -2,8 +2,11 @@ breakpoints.cmo : \
symbols.cmi \
pos.cmi \
parameters.cmi \
../utils/misc.cmi \
../bytecomp/instruct.cmi \
exec.cmi \
events.cmi \
debugger_config.cmi \
debugcom.cmi \
checkpoints.cmi \
breakpoints.cmi
@ -11,13 +14,17 @@ breakpoints.cmx : \
symbols.cmx \
pos.cmx \
parameters.cmx \
../utils/misc.cmx \
../bytecomp/instruct.cmx \
exec.cmx \
events.cmx \
debugger_config.cmx \
debugcom.cmx \
checkpoints.cmx \
breakpoints.cmi
breakpoints.cmi : \
../bytecomp/instruct.cmi
events.cmi \
debugcom.cmi
checkpoints.cmo : \
primitives.cmi \
int64ops.cmi \
@ -112,16 +119,19 @@ debugcom.cmo : \
primitives.cmi \
../utils/misc.cmi \
int64ops.cmi \
../bytecomp/instruct.cmi \
input_handling.cmi \
debugcom.cmi
debugcom.cmx : \
primitives.cmx \
../utils/misc.cmx \
int64ops.cmx \
../bytecomp/instruct.cmx \
input_handling.cmx \
debugcom.cmi
debugcom.cmi : \
primitives.cmi
primitives.cmi \
../bytecomp/instruct.cmi
debugger_config.cmo : \
int64ops.cmi \
debugger_config.cmi
@ -143,6 +153,7 @@ eval.cmo : \
../bytecomp/instruct.cmi \
../typing/ident.cmi \
frames.cmi \
events.cmi \
../typing/env.cmi \
debugcom.cmi \
../typing/ctype.cmi \
@ -162,6 +173,7 @@ eval.cmx : \
../bytecomp/instruct.cmx \
../typing/ident.cmx \
frames.cmx \
events.cmx \
../typing/env.cmx \
debugcom.cmx \
../typing/ctype.cmx \
@ -172,8 +184,8 @@ eval.cmi : \
../typing/path.cmi \
parser_aux.cmi \
../parsing/longident.cmi \
../bytecomp/instruct.cmi \
../typing/ident.cmi \
events.cmi \
../typing/env.cmi \
debugcom.cmi
events.cmo : \
@ -206,7 +218,7 @@ frames.cmx : \
debugcom.cmx \
frames.cmi
frames.cmi : \
../bytecomp/instruct.cmi
events.cmi
history.cmo : \
primitives.cmi \
int64ops.cmi \
@ -340,18 +352,21 @@ parser.cmo : \
../parsing/longident.cmi \
int64ops.cmi \
input_handling.cmi \
debugcom.cmi \
parser.cmi
parser.cmx : \
parser_aux.cmi \
../parsing/longident.cmx \
int64ops.cmx \
input_handling.cmx \
debugcom.cmx \
parser.cmi
parser.cmi : \
parser_aux.cmi \
../parsing/longident.cmi
parser_aux.cmi : \
../parsing/longident.cmi
../parsing/longident.cmi \
debugcom.cmi
pattern_matching.cmo : \
../typing/typedtree.cmi \
parser_aux.cmi \
@ -375,13 +390,15 @@ pattern_matching.cmi : \
pos.cmo : \
../parsing/location.cmi \
../bytecomp/instruct.cmi \
events.cmi \
pos.cmi
pos.cmx : \
../parsing/location.cmx \
../bytecomp/instruct.cmx \
events.cmx \
pos.cmi
pos.cmi : \
../bytecomp/instruct.cmi
events.cmi
primitives.cmo : \
$(UNIXDIR)/unix.cmi \
primitives.cmi
@ -511,7 +528,7 @@ show_information.cmx : \
breakpoints.cmx \
show_information.cmi
show_information.cmi : \
../bytecomp/instruct.cmi
events.cmi
show_source.cmo : \
source.cmi \
primitives.cmi \
@ -568,7 +585,9 @@ symbols.cmx : \
../bytecomp/bytesections.cmx \
symbols.cmi
symbols.cmi : \
../bytecomp/instruct.cmi
../bytecomp/instruct.cmi \
events.cmi \
debugcom.cmi
time_travel.cmo : \
trap_barrier.cmi \
symbols.cmi \

128
debugger/breakpoints.ml
View File

@ -19,6 +19,7 @@
open Checkpoints
open Debugcom
open Instruct
open Events
open Printf
(*** Debugging. ***)
@ -30,10 +31,11 @@ let debug_breakpoints = ref false
let breakpoint_number = ref 0
(* Breakpoint number -> event. *)
let breakpoints = ref ([] : (int * debug_event) list)
type breakpoint_id = int
let breakpoints = ref ([] : (breakpoint_id * code_event) list)
(* Program counter -> breakpoint count. *)
let positions = ref ([] : (int * int ref) list)
let positions = ref ([] : (pc * int ref) list)
(* Versions of the breakpoint list. *)
let current_version = ref 0
@ -58,17 +60,17 @@ let breakpoints_count () =
(* List of breakpoints at `pc'. *)
let rec breakpoints_at_pc pc =
begin try
let ev = Symbols.event_at_pc pc in
match ev.ev_repr with
Event_child {contents = pc'} -> breakpoints_at_pc pc'
| _ -> []
with Not_found ->
[]
begin match Symbols.event_at_pc pc with
| {ev_frag = frag; ev_ev = {ev_repr = Event_child {contents = pos}}} ->
breakpoints_at_pc {frag; pos}
| _ -> []
| exception Not_found -> []
end
@
List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc)
!breakpoints)
List.map fst (List.filter
(function (_, {ev_frag = frag; ev_ev = {ev_pos = pos}}) ->
{frag; pos} = pc)
!breakpoints)
(* Is there a breakpoint at `pc' ? *)
let breakpoint_at_pc pc =
@ -76,32 +78,28 @@ let breakpoint_at_pc pc =
(*** Set and remove breakpoints ***)
let print_pc out {frag;pos} = fprintf out "%d:%d" frag pos
(* Remove all breakpoints. *)
let remove_breakpoints pos =
let remove_breakpoints pcs =
if !debug_breakpoints then
(print_string "Removing breakpoints..."; print_newline ());
printf "Removing breakpoints...\n%!";
List.iter
(function (pos, _) ->
if !debug_breakpoints then begin
print_int pos;
print_newline()
end;
reset_instr pos;
Symbols.set_event_at_pc pos)
pos
(function (pc, _) ->
if !debug_breakpoints then printf "%a\n%!" print_pc pc;
reset_instr pc;
Symbols.set_event_at_pc pc)
pcs
(* Set all breakpoints. *)
let set_breakpoints pos =
let set_breakpoints pcs =
if !debug_breakpoints then
(print_string "Setting breakpoints..."; print_newline ());
printf "Setting breakpoints...\n%!";
List.iter
(function (pos, _) ->
if !debug_breakpoints then begin
print_int pos;
print_newline()
end;
set_breakpoint pos)
pos
(function (pc, _) ->
if !debug_breakpoints then printf "%a\n%!" print_pc pc;
set_breakpoint pc)
pcs
(* Ensure the current version is installed in current checkpoint. *)
let update_breakpoints () =
@ -119,25 +117,13 @@ let update_breakpoints () =
set_breakpoints !positions;
copy_breakpoints ())
let change_version version pos =
Exec.protect
(function () ->
current_version := version;
positions := pos)
(* Execute given function with no breakpoint in current checkpoint. *)
(* --- `goto' runs faster this way (does not stop on each breakpoint). *)
let execute_without_breakpoints f =
let version = !current_version
and pos = !positions
in
change_version 0 [];
try
f ();
change_version version pos
with
_ ->
change_version version pos
Misc.protect_refs [Misc.R (Debugger_config.break_on_load, false);
Misc.R (current_version, 0);
Misc.R (positions, [])]
f
(* Add a position in the position list. *)
(* Change version if necessary. *)
@ -160,37 +146,33 @@ let remove_position pos =
end
(* Insert a new breakpoint in lists. *)
let rec new_breakpoint =
function
{ev_repr = Event_child pc} ->
new_breakpoint (Symbols.any_event_at_pc !pc)
| event ->
Exec.protect
(function () ->
incr breakpoint_number;
insert_position event.ev_pos;
breakpoints := (!breakpoint_number, event) :: !breakpoints);
if !Parameters.breakpoint then begin
printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos
(Pos.get_desc event);
print_newline ()
end
let rec new_breakpoint event =
match event with
{ev_frag=frag; ev_ev={ev_repr=Event_child pos}} ->
new_breakpoint (Symbols.any_event_at_pc {frag; pos=(!pos)})
| {ev_frag=frag; ev_ev={ev_pos=pos}} ->
let pc = {frag; pos} in
Exec.protect
(function () ->
incr breakpoint_number;
insert_position pc;
breakpoints := (!breakpoint_number, event) :: !breakpoints);
if !Parameters.breakpoint then
printf "Breakpoint %d at %a: %s\n%!" !breakpoint_number print_pc pc
(Pos.get_desc event)
(* Remove a breakpoint from lists. *)
let remove_breakpoint number =
try
let ev = List.assoc number !breakpoints in
let pos = ev.ev_pos in
Exec.protect
(function () ->
breakpoints := List.remove_assoc number !breakpoints;
remove_position pos;
if !Parameters.breakpoint then begin
printf "Removed breakpoint %d at %d: %s" number ev.ev_pos
(Pos.get_desc ev);
print_newline ()
end
)
let pc = {frag = ev.ev_frag; pos=ev.ev_ev.ev_pos} in
Exec.protect
(function () ->
breakpoints := List.remove_assoc number !breakpoints;
remove_position pc;
if !Parameters.breakpoint then
printf "Removed breakpoint %d at %a: %s\n%!" number print_pc pc
(Pos.get_desc ev))
with
Not_found ->
prerr_endline ("No breakpoint number " ^ (Int.to_string number) ^ ".");
@ -202,7 +184,7 @@ let remove_all_breakpoints () =
(*** Temporary breakpoints. ***)
(* Temporary breakpoint position. *)
let temporary_breakpoint_position = ref (None : int option)
let temporary_breakpoint_position = ref (None : pc option)
(* Execute `funct' with a breakpoint added at `pc'. *)
(* --- Used by `finish'. *)

17
debugger/breakpoints.mli
View File

@ -16,8 +16,6 @@
(******************************* Breakpoints ***************************)
open Instruct
(*** Debugging. ***)
val debug_breakpoints : bool ref
@ -25,14 +23,15 @@ val debug_breakpoints : bool ref
val breakpoints_count : unit -> int
(* Breakpoint number -> debug_event_kind. *)
val breakpoints : (int * debug_event) list ref
(* Breakpoint number -> code_event. *)
type breakpoint_id = int
val breakpoints : (breakpoint_id * Events.code_event) list ref
(* Is there a breakpoint at `pc' ? *)
val breakpoint_at_pc : int -> bool
val breakpoint_at_pc : Debugcom.pc -> bool
(* List of breakpoints at `pc'. *)
val breakpoints_at_pc : int -> int list
val breakpoints_at_pc : Debugcom.pc -> int list
(*** Set and remove breakpoints ***)
@ -44,7 +43,7 @@ val update_breakpoints : unit -> unit
val execute_without_breakpoints : (unit -> unit) -> unit
(* Insert a new breakpoint in lists. *)
val new_breakpoint : debug_event -> unit
val new_breakpoint : Events.code_event -> unit
(* Remove a breakpoint from lists. *)
val remove_breakpoint : int -> unit
@ -54,8 +53,8 @@ val remove_all_breakpoints : unit -> unit
(*** Temporary breakpoints. ***)
(* Temporary breakpoint position. *)
val temporary_breakpoint_position : int option ref
val temporary_breakpoint_position : Debugcom.pc option ref
(* Execute `funct' with a breakpoint added at `pc'. *)
(* --- Used by `finish'. *)
val exec_with_temporary_breakpoint : int -> (unit -> unit) -> unit
val exec_with_temporary_breakpoint : Debugcom.pc -> (unit -> unit) -> unit

24
debugger/checkpoints.ml
View File

@ -43,8 +43,9 @@ type checkpoint = {
mutable c_state : checkpoint_state;
mutable c_parent : checkpoint;
mutable c_breakpoint_version : int;
mutable c_breakpoints : (int * int ref) list;
mutable c_trap_barrier : int
mutable c_breakpoints : (pc * int ref) list;
mutable c_trap_barrier : int;
mutable c_code_fragments : int list
}
(*** Pseudo-checkpoint `root'. ***)
@ -59,7 +60,8 @@ let rec root = {
c_parent = root;
c_breakpoint_version = 0;
c_breakpoints = [];
c_trap_barrier = 0
c_trap_barrier = 0;
c_code_fragments = [0]
}
(*** Current state ***)
@ -75,12 +77,14 @@ let current_time () =
let current_report () =
!current_checkpoint.c_report
let current_pc () =
match current_report () with
None | Some {rep_type = Exited | Uncaught_exc} -> None
| Some {rep_program_pointer = pc } -> Some pc
let current_pc_sp () =
(* This pattern matching mimics the test used in debugger.c for
deciding whether or not PC/SP should be sent with the report.
See debugger.c, the [if] statement above the [command_loop]
label. *)
match current_report () with
None | Some {rep_type = Exited | Uncaught_exc} -> None
| Some {rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp)
| Some {rep_type = Event | Breakpoint;
rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp)
| _ -> None
let current_pc () = Option.map fst (current_pc_sp ())

9
debugger/checkpoints.mli
View File

@ -42,8 +42,9 @@ type checkpoint =
mutable c_state : checkpoint_state;
mutable c_parent : checkpoint;
mutable c_breakpoint_version : int;
mutable c_breakpoints : (int * int ref) list;
mutable c_trap_barrier : int}
mutable c_breakpoints : (pc * int ref) list;
mutable c_trap_barrier : int;
mutable c_code_fragments : int list}
(*** Pseudo-checkpoint `root'. ***)
(* --- Parents of all checkpoints which have no parent. *)
@ -55,5 +56,5 @@ val current_checkpoint : checkpoint ref
val current_time : unit -> int64
val current_report : unit -> report option
val current_pc : unit -> int option
val current_pc_sp : unit -> (int * int) option
val current_pc : unit -> pc option
val current_pc_sp : unit -> (pc * int) option

52
debugger/command_line.ml
View File

@ -126,14 +126,15 @@ let add_breakpoint_at_pc pc =
new_breakpoint (any_event_at_pc pc)
with
| Not_found ->
eprintf "Can\'t add breakpoint at pc %i: no event there.@." pc;
eprintf "Can\'t add breakpoint at pc %i:%i: no event there.@."
pc.frag pc.pos;
raise Toplevel
let add_breakpoint_after_pc pc =
let rec try_add n =
if n < 3 then begin
try
new_breakpoint (any_event_at_pc (pc + n * 4))
new_breakpoint (any_event_at_pc {pc with pos = pc.pos + n * 4})
with
| Not_found ->
try_add (n+1)
@ -156,11 +157,8 @@ let convert_module mdle =
then Filename.chop_suffix m ".ml"
else m)
| None ->
try
(get_current_event ()).ev_module
with
| Not_found ->
error "Not in a module."
try (get_current_event ()).ev_ev.ev_module
with Not_found -> error "Not in a module."
(** Toplevel. **)
let current_line = ref ""
@ -303,7 +301,7 @@ let instr_run ppf lexbuf =
ensure_loaded ();
reset_named_values ();
run ();
show_current_event ppf;;
show_current_event ppf
let instr_reverse ppf lexbuf =
eol lexbuf;
@ -502,7 +500,7 @@ let env_of_event =
function
None -> Env.empty
| Some ev ->
Envaux.env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst
Envaux.env_from_summary ev.ev_ev.ev_typenv ev.ev_ev.ev_typsubst
let print_command depth ppf lexbuf =
let exprs = expression_list_eol Lexer.lexeme lexbuf in
@ -613,8 +611,8 @@ let instr_break ppf lexbuf =
new_breakpoint ev
| None ->
error "Can\'t add breakpoint at this point.")
| BA_pc pc -> (* break PC *)
add_breakpoint_at_pc pc
| BA_pc {frag; pos} -> (* break PC *)
add_breakpoint_at_pc {frag; pos}
| BA_function expr -> (* break FUNCTION *)
let env =
try
@ -644,7 +642,7 @@ let instr_break ppf lexbuf =
let ev = event_at_pos module_name 0 in
let ev_pos =
{Lexing.dummy_pos with
pos_fname = (Events.get_pos ev).pos_fname} in
pos_fname = (Events.get_pos ev.ev_ev).pos_fname} in
let buffer =
try get_buffer ev_pos module_name with
| Not_found ->
@ -703,7 +701,7 @@ let instr_backtrace ppf lexbuf =
| Some x -> x in
ensure_loaded ();
match current_report() with
| None | Some {rep_type = Exited | Uncaught_exc} -> ()
| None | Some {rep_type = Exited | Uncaught_exc | Code_loaded _} -> ()
| Some _ ->
let frame_counter = ref 0 in
let print_frame first_frame last_frame = function
@ -936,8 +934,8 @@ let info_checkpoints ppf lexbuf =
!checkpoints))
let info_one_breakpoint ppf (num, ev) =
fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev);
;;
fprintf ppf "%3d %d:%10d %s@." num ev.ev_frag ev.ev_ev.ev_pos
(Pos.get_desc ev)
let info_breakpoints ppf lexbuf =
eol lexbuf;
@ -946,7 +944,7 @@ let info_breakpoints ppf lexbuf =
fprintf ppf "Num Address Where@.";
List.iter (info_one_breakpoint ppf) (List.rev !breakpoints);
end
;;
let info_events _ppf lexbuf =
ensure_loaded ();
@ -955,6 +953,7 @@ let info_events _ppf lexbuf =
in
print_endline ("Module: " ^ mdle);
print_endline " Address Characters Kind Repr.";
let frag, events = events_in_module mdle in
List.iter
(function ev ->
let start_char, end_char =
@ -966,7 +965,8 @@ let info_events _ppf lexbuf =
ev.ev_loc.Location.loc_start.Lexing.pos_cnum,
ev.ev_loc.Location.loc_end.Lexing.pos_cnum in
Printf.printf
"%10d %6d-%-6d %10s %10s\n"
"%d:%10d %6d-%-6d %10s %10s\n"
frag
ev.ev_pos
start_char
end_char
@ -983,7 +983,7 @@ let info_events _ppf lexbuf =
Event_none -> ""
| Event_parent _ -> "(repr)"
| Event_child repr -> Int.to_string !repr))
(events_in_module mdle)
events
(** User-defined printers **)
@ -1093,10 +1093,14 @@ Argument N means do this N times (or till program stops for another reason)." };
(* Breakpoints *)
{ instr_name = "break"; instr_prio = false;
instr_action = instr_break; instr_repeat = false; instr_help =
"Set breakpoint at specified line or function.\
\nSyntax: break function-name\
"Set breakpoint.\
\nSyntax: break\
\n break function-name\
\n break @ [module] linenum\
\n break @ [module] # characternum" };
\n break @ [module] linenum columnnum\
\n break @ [module] # characternum\
\n break frag:pc\
\n break pc" };
{ instr_name = "delete"; instr_prio = false;
instr_action = instr_delete; instr_repeat = false; instr_help =
"delete some breakpoints.\n\
@ -1214,7 +1218,11 @@ It can be either:\n\
"process to follow after forking.\n\
It can be either :\n\
child: the newly created process.\n\
parent: the process that called fork.\n" }];
parent: the process that called fork.\n" };
{ var_name = "break_on_load";
var_action = boolean_variable false break_on_load;
var_help =
"whether to stop after loading new code (e.g. with Dynlink)." }];
info_list :=
(* info name, function, help *)

73
debugger/debugcom.ml
View File

@ -45,16 +45,23 @@ let set_current_connection io_chan =
(* Modify the program code *)
let set_event pos =
type pc =
{ frag : int;
pos : int; }
let set_event {frag; pos} =
output_char !conn.io_out 'e';
output_binary_int !conn.io_out frag;
output_binary_int !conn.io_out pos
let set_breakpoint pos =
let set_breakpoint {frag; pos} =
output_char !conn.io_out 'B';
output_binary_int !conn.io_out frag;
output_binary_int !conn.io_out pos
let reset_instr pos =
let reset_instr {frag; pos} =
output_char !conn.io_out 'i';
output_binary_int !conn.io_out frag;
output_binary_int !conn.io_out pos
(* Basic commands for flow control *)
@ -65,12 +72,15 @@ type execution_summary =
| Exited
| Trap_barrier
| Uncaught_exc
| Debug_info of Instruct.debug_event list array
| Code_loaded of int
| Code_unloaded of int
type report = {
rep_type : execution_summary;
rep_event_count : int;
rep_event_count : int64;
rep_stack_pointer : int;
rep_program_pointer : int
rep_program_pointer : pc
}
type checkpoint_report =
@ -95,24 +105,33 @@ let do_go_smallint n =
| 'x' -> Exited
| 's' -> Trap_barrier
| 'u' -> Uncaught_exc
| _ -> Misc.fatal_error "Debugcom.do_go" in
| 'D' -> Debug_info (input_value !conn.io_in :
Instruct.debug_event list array)
| 'L' -> Code_loaded (input_binary_int !conn.io_in)
| 'U' -> Code_unloaded (input_binary_int !conn.io_in)
| c -> Misc.fatal_error (Printf.sprintf "Debugcom.do_go %c" c)
in
let event_counter = input_binary_int !conn.io_in in
let stack_pos = input_binary_int !conn.io_in in
let pc = input_binary_int !conn.io_in in
let frag = input_binary_int !conn.io_in in
let pos = input_binary_int !conn.io_in in
{ rep_type = summary;
rep_event_count = event_counter;
rep_event_count = Int64.of_int event_counter;
rep_stack_pointer = stack_pos;
rep_program_pointer = pc })
rep_program_pointer = {frag; pos} })
let rec do_go n =
assert (n >= _0);
if n > max_small_int then(
ignore (do_go_smallint max_int);
do_go (n -- max_small_int)
)else(
if n > max_small_int then
begin match do_go_smallint max_int with
| { rep_type = Event } ->
do_go (n -- max_small_int)
| report ->
{ report with
rep_event_count = report.rep_event_count ++ (n -- max_small_int) }
end
else
do_go_smallint (Int64.to_int n)
)
;;
(* Perform a checkpoint *)
@ -148,8 +167,9 @@ let initial_frame () =
output_char !conn.io_out '0';
flush !conn.io_out;
let stack_pos = input_binary_int !conn.io_in in
let pc = input_binary_int !conn.io_in in
(stack_pos, pc)
let frag = input_binary_int !conn.io_in in
let pos = input_binary_int !conn.io_in in
(stack_pos, {frag; pos})
let set_initial_frame () =
ignore(initial_frame ())
@ -163,8 +183,14 @@ let up_frame stacksize =
output_binary_int !conn.io_out stacksize;
flush !conn.io_out;
let stack_pos = input_binary_int !conn.io_in in
let pc = if stack_pos = -1 then 0 else input_binary_int !conn.io_in in
(stack_pos, pc)
let frag, pos =
if stack_pos = -1
then 0, 0
else let frag = input_binary_int !conn.io_in in
let pos = input_binary_int !conn.io_in in
frag, pos
in
(stack_pos, { frag; pos })
(* Get and set the current frame position *)
@ -172,8 +198,9 @@ let get_frame () =
output_char !conn.io_out 'f';
flush !conn.io_out;
let stack_pos = input_binary_int !conn.io_in in
let pc = input_binary_int !conn.io_in in
(stack_pos, pc)
let frag = input_binary_int !conn.io_in in
let pos = input_binary_int !conn.io_in in
(stack_pos, {frag; pos})
let set_frame stack_pos =
output_char !conn.io_out 'S';
@ -308,7 +335,9 @@ module Remote_value =
output_char !conn.io_out 'C';
output_remote_value !conn.io_out v;
flush !conn.io_out;
input_binary_int !conn.io_in
let frag = input_binary_int !conn.io_in in
let pos = input_binary_int !conn.io_in in
{frag;pos}
let same rv1 rv2 =
match (rv1, rv2) with

25
debugger/debugcom.mli
View File

@ -16,18 +16,25 @@
(* Low-level communication with the debuggee *)
type pc =
{ frag : int;
pos : int; }
type execution_summary =
Event
| Breakpoint
| Exited
| Trap_barrier
| Uncaught_exc
| Debug_info of Instruct.debug_event list array
| Code_loaded of int
| Code_unloaded of int
type report =
{ rep_type : execution_summary;
rep_event_count : int;
rep_event_count : int64;
rep_stack_pointer : int;
rep_program_pointer : int }
rep_program_pointer : pc }
type checkpoint_report =
Checkpoint_done of int
@ -41,13 +48,13 @@ type follow_fork_mode =
val set_current_connection : Primitives.io_channel -> unit
(* Put an event at given pc *)
val set_event : int -> unit
val set_event : pc -> unit
(* Put a breakpoint at given pc *)
val set_breakpoint : int -> unit
val set_breakpoint : pc -> unit
(* Remove breakpoint or event at given pc *)
val reset_instr : int -> unit
val reset_instr : pc -> unit
(* Create a new checkpoint (the current process forks). *)
val do_checkpoint : unit -> checkpoint_report
@ -63,12 +70,12 @@ val wait_child : Primitives.io_channel -> unit
(* Move to initial frame (that of current function). *)
(* Return stack position and current pc *)
val initial_frame : unit -> int * int
val initial_frame : unit -> int * pc
val set_initial_frame : unit -> unit
(* Get the current frame position *)
(* Return stack position and current pc *)
val get_frame : unit -> int * int
val get_frame : unit -> int * pc
(* Set the current frame *)
val set_frame : int -> unit
@ -76,7 +83,7 @@ val set_frame : int -> unit
(* Move up one frame *)
(* Return stack position and current pc.
If there's no frame above, return (-1, 0). *)
val up_frame : int -> int * int
val up_frame : int -> int * pc
(* Set the trap barrier to given stack position. *)
val set_trap_barrier : int -> unit
@ -109,7 +116,7 @@ module Remote_value :
val from_environment : int -> t
val global : int -> t
val accu : unit -> t
val closure_code : t -> int
val closure_code : t -> pc
(* Returns a hexadecimal representation of the remote address,
or [""] if the value is local. *)

3
debugger/debugger_config.ml
View File

@ -82,6 +82,9 @@ let make_checkpoints = ref
"Win32" -> false
| _ -> true)
(* Whether to break when new code is loaded. *)
let break_on_load = ref true
(*** Environment variables for debuggee. ***)
let environment = ref []

1
debugger/debugger_config.mli
View File

@ -34,6 +34,7 @@ val checkpoint_big_step : int64 ref
val checkpoint_small_step : int64 ref
val checkpoint_max_count : int ref
val make_checkpoints : bool ref
val break_on_load : bool ref
(*** Environment variables for debuggee. ***)

5
debugger/eval.ml
View File

@ -19,6 +19,7 @@ open Path
open Instruct
open Types
open Parser_aux
open Events
type error =
Unbound_identifier of Ident.t
@ -47,7 +48,7 @@ let rec address path event = function
with Symtable.Error _ -> raise(Error(Unbound_identifier id))
else
begin match event with
Some ev ->
Some {ev_ev = ev} ->
begin try
let pos = Ident.find_same id ev.ev_compenv.ce_stack in
Debugcom.Remote_value.local (ev.ev_stacksize - pos)
@ -94,7 +95,7 @@ let rec expression event env = function
end
| E_result ->
begin match event with
Some {ev_kind = Event_after ty; ev_typsubst = subst}
Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}}
when !Frames.current_frame = 0 ->
(Debugcom.Remote_value.accu(), Subst.type_expr subst ty)
| _ ->

2
debugger/eval.mli
View File

@ -19,7 +19,7 @@ open Parser_aux
open Format
val expression :
Instruct.debug_event option -> Env.t -> expression ->
Events.code_event option -> Env.t -> expression ->
Debugcom.Remote_value.t * type_expr
type error =

8
debugger/events.ml
View File

@ -18,6 +18,10 @@
open Instruct
type code_event =
{ ev_frag : int;
ev_ev : Instruct.debug_event }
let get_pos ev =
match ev.ev_kind with
| Event_before -> ev.ev_loc.Location.loc_start
@ -30,7 +34,7 @@ let get_pos ev =
(* Event at current position *)
let current_event =
ref (None : debug_event option)
ref (None : code_event option)
(* Current position in source. *)
(* Raise `Not_found' if not on an event (beginning or end of program). *)
@ -43,7 +47,7 @@ let current_event_is_before () =
match !current_event with
None ->
raise Not_found
| Some {ev_kind = Event_before} ->
| Some {ev_ev = {ev_kind = Event_before}} ->
true
| _ ->
false

9
debugger/events.mli
View File

@ -16,15 +16,20 @@
open Instruct
(* A debug event associated with a code fragment. *)
type code_event =
{ ev_frag : int;
ev_ev : Instruct.debug_event }
val get_pos : debug_event -> Lexing.position;;
(** Current events. **)
(* The event at current position. *)
val current_event : debug_event option ref
val current_event : code_event option ref
(* Current position in source. *)
(* Raise `Not_found' if not on an event (beginning or end of program). *)
val get_current_event : unit -> debug_event
val get_current_event : unit -> code_event
val current_event_is_before : unit -> bool

14
debugger/frames.ml
View File

@ -25,7 +25,7 @@ open Symbols
let current_frame = ref 0
(* Event at selected position *)
let selected_event = ref (None : debug_event option)
let selected_event = ref (None : code_event option)
(* Selected position in source. *)
(* Raise `Not_found' if not on an event. *)
@ -33,7 +33,7 @@ let selected_point () =
match !selected_event with
None ->
raise Not_found
| Some ev ->
| Some {ev_ev=ev} ->
(ev.ev_module,
(Events.get_pos ev).Lexing.pos_lnum,
(Events.get_pos ev).Lexing.pos_cnum - (Events.get_pos ev).Lexing.pos_bol)
@ -42,7 +42,7 @@ let selected_event_is_before () =
match !selected_event with
None ->
raise Not_found
| Some {ev_kind = Event_before} ->
| Some {ev_ev={ev_kind = Event_before}} ->
true
| _ ->
false
@ -52,7 +52,7 @@ let selected_event_is_before () =
let rec move_up frame_count event =
if frame_count <= 0 then event else begin
let (sp, pc) = up_frame event.ev_stacksize in
let (sp, pc) = up_frame event.ev_ev.ev_stacksize in
if sp < 0 then raise Not_found;
move_up (frame_count - 1) (any_event_at_pc pc)
end
@ -106,13 +106,13 @@ let reset_frame () =
let do_backtrace action =
match !current_event with
None -> Misc.fatal_error "Frames.do_backtrace"
| Some curr_ev ->
| Some ev ->
let (initial_sp, _) = get_frame() in
set_initial_frame();
let event = ref curr_ev in
let event = ref ev in
begin try
while action (Some !event) do
let (sp, pc) = up_frame !event.ev_stacksize in
let (sp, pc) = up_frame !event.ev_ev.ev_stacksize in
if sp < 0 then raise Exit;
event := any_event_at_pc pc
done

8
debugger/frames.mli
View File

@ -16,13 +16,13 @@
(****************************** Frames *********************************)
open Instruct
open Events
(* Current frame number *)
val current_frame : int ref
(* Event at selected position. *)
val selected_event : debug_event option ref
(* Fragment and event at selected position. *)
val selected_event : code_event option ref
(* Selected position in source (module, line, column). *)
(* Raise `Not_found' if not on an event. *)
@ -48,7 +48,7 @@ val reset_frame : unit -> unit
or None if we've encountered a stack frame with no debugging info
attached. Stop when the function returns false, or frame with no
debugging info reached, or top of stack reached. *)
val do_backtrace : (debug_event option -> bool) -> unit
val do_backtrace : (code_event option -> bool) -> unit
(* Return the number of frames in the stack, or (-1) if it can't be
determined because some frames have no debugging info. *)

2
debugger/lexer.mll
View File

@ -83,6 +83,8 @@ and lexeme = (* Read a lexeme *)
{ AT }
| "$"
{ DOLLAR }
| ":"
{ COLON }
| "!"
{ BANG }
| "("

6
debugger/parser.mly
View File

@ -20,6 +20,7 @@ open Int64ops
open Input_handling
open Longident
open Parser_aux
open Debugcom
%}
@ -31,6 +32,7 @@ open Parser_aux
%token STAR /* * */
%token MINUS /* - */
%token DOT /* . */
%token COLON /* : */
%token HASH /* # */
%token AT /* @ */
%token DOLLAR /* $ */
@ -235,7 +237,9 @@ expression_list_eol :
break_argument_eol :
end_of_line { BA_none }
| integer_eol { BA_pc $1 }
| integer_eol { BA_pc {frag = 0; pos = $1} }
| INTEGER COLON integer_eol { BA_pc {frag = to_int $1;
pos = $3} }
| expression end_of_line { BA_function $1 }
| AT opt_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)}
| AT opt_longident HASH integer_eol { BA_pos2 ($2, $4) }

2
debugger/parser_aux.mli
View File

@ -23,7 +23,7 @@ type expression =
type break_arg =
BA_none (* break *)
| BA_pc of int (* break PC *)
| BA_pc of Debugcom.pc (* break FRAG PC *)
| BA_function of expression (* break FUNCTION *)
| BA_pos1 of Longident.t option * int * int option
(* break @ [MODULE] LINE [POS] *)

10
debugger/pos.ml
View File

@ -13,14 +13,14 @@
(* *)
(**************************************************************************)
open Instruct;;
open Lexing;;
open Location;;
open Instruct
open Lexing
open Location
open Events
let get_desc ev =
let loc = ev.ev_loc in
let loc = ev.ev_ev.ev_loc in
Printf.sprintf "file %s, line %d, characters %d-%d"
loc.loc_start.pos_fname loc.loc_start.pos_lnum
(loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1)
(loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1)
;;

2
debugger/pos.mli
View File

@ -13,4 +13,4 @@
(* *)
(**************************************************************************)
val get_desc : Instruct.debug_event -> string;;
val get_desc : Events.code_event -> string;;

5
debugger/program_management.ml
View File

@ -126,7 +126,8 @@ let initialize_loading () =
prerr_endline "Program not found.";
raise Toplevel;
end;
Symbols.read_symbols !program_name;
Symbols.clear_symbols ();
Symbols.read_symbols 0 !program_name;
Load_path.init (Load_path.get_paths () @ !Symbols.program_source_dirs);
Envaux.reset_cache ();
if !debug_loading then
@ -134,7 +135,7 @@ let initialize_loading () =
open_connection !socket_name
(function () ->
go_to _0;
Symbols.set_all_events();
Symbols.set_all_events 0;
exit_main_loop ())
(* Ensure the program is already loaded. *)

33
debugger/show_information.ml
View File

@ -32,7 +32,7 @@ let show_current_event ppf =
fprintf ppf "Time: %Li" (current_time ());
(match current_pc () with
| Some pc ->
fprintf ppf " - pc: %i" pc
fprintf ppf " - pc: %i:%i" pc.frag pc.pos
| _ -> ());
end;
update_current_event ();
@ -43,7 +43,7 @@ let show_current_event ppf =
fprintf ppf "Beginning of program.@.";
show_no_point ()
| Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} ->
let ev = get_current_event () in
let ev = (get_current_event ()).ev_ev in
if !Parameters.time then fprintf ppf " - module %s@." ev.ev_module;
(match breakpoints_at_pc pc with
| [] ->
@ -68,28 +68,34 @@ let show_current_event ppf =
@[Uncaught exception:@ %a@]@."
Printval.print_exception (Debugcom.Remote_value.accu ());
show_no_point ()
| Some {rep_type = Trap_barrier} ->
(* Trap_barrier not visible outside *)
(* of module `time_travel'. *)
| Some {rep_type = Code_loaded frag} ->
let mds = String.concat ", " (Symbols.modules_in_code_fragment frag) in
fprintf ppf "@.Module(s) %s loaded.@." mds;
show_no_point ()
| Some {rep_type = Trap_barrier}
| Some {rep_type = Debug_info _}
| Some {rep_type = Code_unloaded _} ->
(* Not visible outside *)
(* of module `time_travel'. *)
if !Parameters.time then fprintf ppf "@.";
Misc.fatal_error "Show_information.show_current_event"
(* Display short information about one frame. *)
let show_one_frame framenum ppf event =
let pos = Events.get_pos event in
let show_one_frame framenum ppf ev =
let pos = Events.get_pos ev.ev_ev in
let cnum =
try
let buffer = get_buffer pos event.ev_module in
let buffer = get_buffer pos ev.ev_ev.ev_module in
snd (start_and_cnum buffer pos)
with _ -> pos.Lexing.pos_cnum in
if !machine_readable then
fprintf ppf "#%i Pc: %i %s char %i@."
framenum event.ev_pos event.ev_module
fprintf ppf "#%i Pc: %i:%i %s char %i@."
framenum ev.ev_frag ev.ev_ev.ev_pos ev.ev_ev.ev_module
cnum
else
fprintf ppf "#%i %s %s:%i:%i@."
framenum event.ev_module
framenum ev.ev_ev.ev_module
pos.Lexing.pos_fname pos.Lexing.pos_lnum
(pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1)
@ -101,7 +107,8 @@ let show_current_frame ppf selected =
fprintf ppf "@.No frame selected.@."
| Some sel_ev ->
show_one_frame !current_frame ppf sel_ev;
begin match breakpoints_at_pc sel_ev.ev_pos with
begin match breakpoints_at_pc
{frag=sel_ev.ev_frag; pos = sel_ev.ev_ev.ev_pos} with
| [] -> ()
| [breakpoint] ->
fprintf ppf "Breakpoint: %i@." breakpoint
@ -111,4 +118,4 @@ let show_current_frame ppf selected =
List.iter (function x -> fprintf ppf "%i " x) l)
(List.sort compare breakpoints);
end;
show_point sel_ev selected
show_point sel_ev.ev_ev selected

8
debugger/show_information.mli
View File

@ -14,14 +14,14 @@
(* *)
(**************************************************************************)
open Format;;
open Format
(* Display information about the current event. *)
val show_current_event : formatter -> unit;;
val show_current_event : formatter -> unit
(* Display information about the current frame. *)
(* --- `select frame' must have succeeded before calling this function. *)
val show_current_frame : formatter -> bool -> unit;;
val show_current_frame : formatter -> bool -> unit
(* Display short information about one frame. *)
val show_one_frame : int -> formatter -> Instruct.debug_event -> unit
val show_one_frame : int -> formatter -> Events.code_event -> unit

91
debugger/symbols.ml
View File

@ -19,6 +19,8 @@
open Instruct
open Debugger_config (* Toplevel *)
open Program_loading
open Debugcom
open Events
module String = Misc.Stdlib.String
let modules =
@ -30,11 +32,11 @@ let program_source_dirs =
let events =
ref ([] : debug_event list)
let events_by_pc =
(Hashtbl.create 257 : (int, debug_event) Hashtbl.t)
(Hashtbl.create 257 : (pc, debug_event) Hashtbl.t)
let events_by_module =
(Hashtbl.create 17 : (string, debug_event array) Hashtbl.t)
(Hashtbl.create 17 : (string, int * debug_event array) Hashtbl.t)
let all_events_by_module =
(Hashtbl.create 17 : (string, debug_event list) Hashtbl.t)
(Hashtbl.create 17 : (string, int * debug_event list) Hashtbl.t)
let partition_modules evl =
let rec partition_modules' ev evl =
@ -93,20 +95,19 @@ let read_symbols' bytecode_file =
close_in_noerr ic;
!eventlists, !dirs
let read_symbols bytecode_file =
let all_events, all_dirs = read_symbols' bytecode_file in
let clear_symbols () =
modules := []; events := [];
program_source_dirs := String.Set.elements all_dirs;
program_source_dirs := [];
Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module;
Hashtbl.clear all_events_by_module;
Hashtbl.clear all_events_by_module
let add_symbols frag all_events =
List.iter
(fun evl ->
List.iter
(fun ev ->
events := ev :: !events;
Hashtbl.add events_by_pc ev.ev_pos ev)
Hashtbl.add events_by_pc {frag; pos = ev.ev_pos} ev)
evl)
all_events;
@ -120,7 +121,7 @@ let read_symbols bytecode_file =
in
let sorted_evl = List.sort cmp evl in
modules := md :: !modules;
Hashtbl.add all_events_by_module md sorted_evl;
Hashtbl.add all_events_by_module md (frag, sorted_evl);
let real_evl =
List.filter
(function
@ -128,20 +129,52 @@ let read_symbols bytecode_file =
| _ -> true)
sorted_evl
in
Hashtbl.add events_by_module md (Array.of_list real_evl))
Hashtbl.add events_by_module md (frag, Array.of_list real_evl))
all_events
let read_symbols frag bytecode_file =
let all_events, all_dirs = read_symbols' bytecode_file in
program_source_dirs := !program_source_dirs @ (String.Set.elements all_dirs);
add_symbols frag all_events
let erase_symbols frag =
let pcs = Hashtbl.fold (fun pc _ pcs ->
if pc.frag = frag then pc :: pcs else pcs)
events_by_pc []
in
List.iter (Hashtbl.remove events_by_pc) pcs;
let mds = Hashtbl.fold (fun md (frag', _) mds ->
if frag' = frag then md :: mds else mds)
events_by_module []
in
List.iter (Hashtbl.remove events_by_module) mds;
List.iter (Hashtbl.remove all_events_by_module) mds;
modules := List.filter (fun md -> not (List.mem md mds)) !modules
let code_fragments () =
let frags =
Hashtbl.fold
(fun _ (frag, _) l -> frag :: l)
all_events_by_module []
in
List.sort_uniq compare frags
let modules_in_code_fragment frag' =
Hashtbl.fold (fun md (frag, _) l ->
if frag' = frag then md :: l else l)
all_events_by_module []
let any_event_at_pc pc =
Hashtbl.find events_by_pc pc
{ ev_frag = pc.frag; ev_ev = Hashtbl.find events_by_pc pc }
let event_at_pc pc =
let ev = any_event_at_pc pc in
match ev.ev_kind with
Event_pseudo -> raise Not_found
| _ -> ev
match any_event_at_pc pc with
{ ev_ev = { ev_kind = Event_pseudo } } -> raise Not_found
| ev -> ev
let set_event_at_pc pc =
try ignore(event_at_pc pc); Debugcom.set_event pc
try ignore(event_at_pc pc); set_event pc
with Not_found -> ()
(* List all events in module *)
@ -149,7 +182,7 @@ let events_in_module mdle =
try
Hashtbl.find all_events_by_module mdle
with Not_found ->
[]
0, []
(* Binary search of event at or just after char *)
let find_event ev char =
@ -174,40 +207,40 @@ let find_event ev char =
(* Return first event after the given position. *)
(* Raise [Not_found] if module is unknown or no event is found. *)
let event_at_pos md char =
let ev = Hashtbl.find events_by_module md in
ev.(find_event ev char)
let ev_frag, ev = Hashtbl.find events_by_module md in
{ ev_frag; ev_ev = ev.(find_event ev char) }
(* Return event closest to given position *)
(* Raise [Not_found] if module is unknown or no event is found. *)
let event_near_pos md char =
let ev = Hashtbl.find events_by_module md in
let ev_frag, ev = Hashtbl.find events_by_module md in
try
let pos = find_event ev char in
(* Desired event is either ev.(pos) or ev.(pos - 1),
whichever is closest *)
if pos > 0 && char - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum
<= (Events.get_pos ev.(pos)).Lexing.pos_cnum - char
then ev.(pos - 1)
else ev.(pos)
then { ev_frag; ev_ev = ev.(pos - 1) }
else { ev_frag; ev_ev = ev.(pos) }
with Not_found ->
let pos = Array.length ev - 1 in
if pos < 0 then raise Not_found;
ev.(pos)
{ ev_frag; ev_ev = ev.(pos) }
(* Flip "event" bit on all instructions *)
let set_all_events () =
let set_all_events frag =
Hashtbl.iter
(fun _pc ev ->
(fun pc ev ->
match ev.ev_kind with
Event_pseudo -> ()
| _ -> Debugcom.set_event ev.ev_pos)
| _ when pc.frag = frag -> set_event pc
| _ -> ())
events_by_pc
(* Previous `pc'. *)
(* Save time if `update_current_event' is called *)
(* several times at the same point. *)
let old_pc = ref (None : int option)
let old_pc = ref (None : pc option)
(* Recompute the current event *)
let update_current_event () =

40
debugger/symbols.mli
View File

@ -14,6 +14,8 @@
(* *)
(**************************************************************************)
open Events
(* Modules used by the program. *)
val modules : string list ref
@ -21,31 +23,49 @@ val modules : string list ref
* compiled *)
val program_source_dirs : string list ref
(* Read debugging info from executable file *)
val read_symbols : string -> unit
(* Clear loaded symbols *)
val clear_symbols : unit -> unit
(* Flip "event" bit on all instructions *)
val set_all_events : unit -> unit
(* Read debugging info from executable or dynlinkable file
and associate with given code fragment *)
val read_symbols : int -> string -> unit
(* Add debugging info from memory and associate with given
code fragment *)
val add_symbols : int -> Instruct.debug_event list list -> unit
(* Erase debugging info associated with given code fragment *)
val erase_symbols : int -> unit
(* Return the list of all code fragments that have debug info associated *)
val code_fragments : unit -> int list
(* Flip "event" bit on all instructions in given fragment *)
val set_all_events : int -> unit
(* Return event at given PC, or raise Not_found *)
(* Can also return pseudo-event at beginning of functions *)
val any_event_at_pc : int -> Instruct.debug_event
val any_event_at_pc : Debugcom.pc -> code_event
(* Return event at given PC, or raise Not_found *)
val event_at_pc : int -> Instruct.debug_event
val event_at_pc : Debugcom.pc -> code_event
(* Set event at given PC *)
val set_event_at_pc : int -> unit
val set_event_at_pc : Debugcom.pc -> unit
(* List the events in `module'. *)
val events_in_module : string -> Instruct.debug_event list
val events_in_module : string -> int * Instruct.debug_event list
(* List the modules in given code fragment. *)
val modules_in_code_fragment : int -> string list
(* First event after the given position. *)
(* --- Raise `Not_found' if no such event. *)
val event_at_pos : string -> int -> Instruct.debug_event
val event_at_pos : string -> int -> code_event
(* Closest event from given position. *)
(* --- Raise `Not_found' if no such event. *)
val event_near_pos : string -> int -> Instruct.debug_event
val event_near_pos : string -> int -> code_event
(* Recompute the current event *)
val update_current_event : unit -> unit

68
debugger/time_travel.ml
View File

@ -99,6 +99,11 @@ let set_current_checkpoint checkpoint =
if not checkpoint.c_valid then
wait_for_connection checkpoint;
current_checkpoint := checkpoint;
let dead_frags = List.filter (fun frag ->
not (List.mem frag checkpoint.c_code_fragments))
(Symbols.code_fragments ())
in
List.iter Symbols.erase_symbols dead_frags;
set_current_connection checkpoint.c_fd
(* Kill `checkpoint'. *)
@ -231,7 +236,8 @@ let duplicate_current_checkpoint () =
c_parent = checkpoint;
c_breakpoint_version = checkpoint.c_breakpoint_version;
c_breakpoints = checkpoint.c_breakpoints;
c_trap_barrier = checkpoint.c_trap_barrier}
c_trap_barrier = checkpoint.c_trap_barrier;
c_code_fragments = checkpoint.c_code_fragments}
in
checkpoints := list_replace checkpoint new_checkpoint !checkpoints;
set_current_checkpoint checkpoint;
@ -260,6 +266,29 @@ let interrupted = ref false
(* Information about last breakpoint encountered *)
let last_breakpoint = ref None
(* Last debug info loaded *)
let last_debug_info = ref None
let rec do_go_dynlink steps =
match do_go steps with
| { rep_type = Code_loaded frag; rep_event_count = steps } as report ->
begin match !last_debug_info with
| Some di ->
Symbols.add_symbols frag di;
Symbols.set_all_events frag;
last_debug_info := None
| None -> assert false
end;
if !break_on_load then report
else do_go_dynlink steps
| { rep_type = Code_unloaded frag; rep_event_count = steps } ->
Symbols.erase_symbols frag;
do_go_dynlink steps
| { rep_type = Debug_info di; rep_event_count = steps } ->
last_debug_info := Some (Array.to_list di);
do_go_dynlink steps
| report -> report
(* Ensure we stop on an event. *)
let rec stop_on_event report =
match report with
@ -282,7 +311,7 @@ and find_event () =
print_string "Searching next event...";
print_newline ()
end;
let report = do_go _1 in
let report = do_go_dynlink _1 in
!current_checkpoint.c_report <- Some report;
stop_on_event report
@ -302,9 +331,10 @@ let internal_step duration =
update_breakpoints ();
update_trap_barrier ();
!current_checkpoint.c_state <- C_running duration;
let report = do_go duration in
let report = do_go_dynlink duration in
!current_checkpoint.c_report <- Some report;
!current_checkpoint.c_state <- C_stopped;
!current_checkpoint.c_code_fragments <- Symbols.code_fragments ();
if report.rep_type = Event then begin
!current_checkpoint.c_time <-
!current_checkpoint.c_time ++ duration;
@ -314,7 +344,7 @@ let internal_step duration =
else begin
!current_checkpoint.c_time <-
!current_checkpoint.c_time ++ duration
-- (Int64.of_int report.rep_event_count) ++ _1;
-- report.rep_event_count ++ _1;
interrupted := true;
last_breakpoint := None;
stop_on_event report
@ -350,7 +380,8 @@ let new_checkpoint pid fd =
c_parent = root;
c_breakpoint_version = 0;
c_breakpoints = [];
c_trap_barrier = 0}
c_trap_barrier = 0;
c_code_fragments = [0]}
in
insert_checkpoint new_checkpoint
@ -469,7 +500,6 @@ let find_last_breakpoint max_time =
(Some (pc, _)) as state when breakpoint_at_pc pc -> state
| _ -> None)
(* Run from `time_max' back to `time'. *)
(* --- Assume 0 <= time < time_max *)
let rec back_to time time_max =
@ -522,9 +552,9 @@ let finish () =
None ->
prerr_endline "`finish' not meaningful in outermost frame.";
raise Toplevel
| Some curr_event ->
| Some {ev_ev={ev_stacksize}} ->
set_initial_frame();
let (frame, pc) = up_frame curr_event.ev_stacksize in
let (frame, pc) = up_frame ev_stacksize in
if frame < 0 then begin
prerr_endline "`finish' not meaningful in outermost frame.";
raise Toplevel
@ -558,18 +588,18 @@ let next_1 () =
match !current_event with
None -> (* Beginning of the program. *)
step _1
| Some event1 ->
| Some {ev_ev={ev_stacksize=ev_stacksize1}} ->
let (frame1, _pc1) = initial_frame() in
step _1;
if not !interrupted then begin
Symbols.update_current_event ();
match !current_event with
None -> ()
| Some event2 ->
| Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
let (frame2, _pc2) = initial_frame() in
(* Call `finish' if we've entered a function. *)
if frame1 >= 0 && frame2 >= 0 &&
frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize
frame2 - ev_stacksize2 > frame1 - ev_stacksize1
then finish()
end
@ -589,9 +619,9 @@ let start () =
None ->
prerr_endline "`start not meaningful in outermost frame.";
raise Toplevel
| Some curr_event ->
| Some {ev_ev={ev_stacksize}} ->
let (frame, _) = initial_frame() in
let (frame', pc) = up_frame curr_event.ev_stacksize in
let (frame', pc) = up_frame ev_stacksize in
if frame' < 0 then begin
prerr_endline "`start not meaningful in outermost frame.";
raise Toplevel
@ -602,11 +632,11 @@ let start () =
prerr_endline "Calling function has no debugging information.";
raise Toplevel
with
{ev_info = Event_return nargs} -> nargs
{ev_ev = {ev_info = Event_return nargs}} -> nargs
| _ -> Misc.fatal_error "Time_travel.start"
in
let offset = if nargs < 4 then 1 else 2 in
let pc = pc - 4 * offset in
let pc = { pc with pos = pc.pos - 4 * offset } in
while
exec_with_temporary_breakpoint pc back_run;
match !last_breakpoint with
@ -614,7 +644,7 @@ let start () =
step _minus1;
(not !interrupted)
&&
(frame' - nargs > frame - curr_event.ev_stacksize)
(frame' - nargs > frame - ev_stacksize)
| _ ->
false
do
@ -626,18 +656,18 @@ let previous_1 () =
match !current_event with
None -> (* End of the program. *)
step _minus1
| Some event1 ->
| Some {ev_ev={ev_stacksize=ev_stacksize1}} ->
let (frame1, _pc1) = initial_frame() in
step _minus1;
if not !interrupted then begin
Symbols.update_current_event ();
match !current_event with
None -> ()
| Some event2 ->
| Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
let (frame2, _pc2) = initial_frame() in
(* Call `start' if we've entered a function. *)
if frame1 >= 0 && frame2 >= 0 &&
frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize
frame2 - ev_stacksize2 > frame1 - ev_stacksize1
then start()
end

38
manual/manual/cmds/debugger.etex
View File

@ -86,7 +86,7 @@ by typing an end-of-file character (usually "ctrl-D").
Typing an interrupt character (usually "ctrl-C") will not exit the
debugger, but will terminate the action of any debugger command that is in
progress and return to the debugger command level.
progress and return to the debugger command level.
\section{Commands} \label{s:debugger-commands}
@ -310,8 +310,13 @@ column \var{column}.
Set a breakpoint in module \var{module} at the event closest to
character number \var{character}.
\item["break "\var{address}]
Set a breakpoint at the code address \var{address}.
\item["break " \var{frag}":"\var{pc}, "break " \var{pc}]
Set a breakpoint at code address \var{frag}":"\var{pc}. The integer
\var{frag} is the identifier of a code fragment, a set of modules that
have been loaded at once, either initially or with the "Dynlink"
module. The integer \var{pc} is the instruction counter within this
code fragment. If \var{frag} is ommited, it defaults to 0, which is
the code fragment of the program loaded initially.
\item["delete "\optvar{breakpoint-numbers}]
Delete the specified breakpoints. Without argument, all breakpoints
@ -513,6 +518,33 @@ checkpoints.
Select whether the debugger makes checkpoints or not.
\end{options}
\subsection{Behavior of the debugger with respect to "fork"}
When the program issues a call to "fork", the debugger can either
follow the child or the parent. By default, the debugger follows the
parent process. The variable \var{follow_fork_mode} controls this
behavior:
\begin{options}
\item["set follow_fork_mode" \var{child/parent}]
Select whether to follow the child or the parent in case of a call to
"fork".
\end{options}
\subsection{Stopping execution when new code is loaded}
The debugger is compatible with the "Dynlink" module. However, when an
external module is not yet loaded, it is impossible to set a
breakpoint in its code. In order to facilitate setting breakpoints in
dynamically loaded code, the debugger stops the program each time new
modules are loaded. This behavior can be disabled using the
"break_on_load" variable:
\begin{options}
\item["set break_on_load" \var{on/off}]
Select whether to stop after loading new code.
\end{options}
\subsection{Communication between the debugger and the program}
\label{s:communication}

72
runtime/.depend
View File

@ -18,12 +18,13 @@ backtrace_byt_b.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_b.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_b.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -183,8 +184,8 @@ meta_b.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_b.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -327,12 +328,13 @@ backtrace_byt_bd.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_bd.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_bd.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -496,8 +498,8 @@ meta_bd.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_bd.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -640,12 +642,13 @@ backtrace_byt_bi.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_bi.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_bi.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -805,8 +808,8 @@ meta_bi.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_bi.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -949,12 +952,13 @@ backtrace_byt_bpic.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_bpic.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_bpic.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -1114,8 +1118,8 @@ meta_bpic.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_bpic.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -1258,12 +1262,13 @@ backtrace_byt_n.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_n.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_n.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -1420,8 +1425,8 @@ meta_n.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_n.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -1564,12 +1569,13 @@ backtrace_byt_nd.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_nd.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_nd.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -1730,8 +1736,8 @@ meta_nd.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_nd.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -1874,12 +1880,13 @@ backtrace_byt_ni.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_ni.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_ni.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -2036,8 +2043,8 @@ meta_ni.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_ni.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@ -2180,12 +2187,13 @@ backtrace_byt_npic.$(O): backtrace_byt.c caml/config.h caml/m.h caml/s.h \
caml/exec.h caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/startup.h caml/exec.h caml/stacks.h caml/memory.h caml/sys.h \
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h
caml/backtrace.h caml/fail.h caml/backtrace_prim.h caml/backtrace.h \
caml/debugger.h
backtrace_npic.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
caml/freelist.h caml/minor_gc.h caml/address_class.h caml/memprof.h \
caml/backtrace.h caml/exec.h caml/backtrace_prim.h caml/backtrace.h \
caml/fail.h
caml/fail.h caml/debugger.h
backtrace_nat_npic.$(O): backtrace_nat.c caml/alloc.h caml/misc.h caml/config.h \
caml/m.h caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
caml/backtrace_prim.h caml/backtrace.h caml/memory.h caml/gc.h \
@ -2342,8 +2350,8 @@ meta_npic.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h
caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \
caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
caml/memprof.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h \
caml/stacks.h caml/memory.h caml/backtrace_prim.h caml/backtrace.h \
caml/exec.h
caml/stacks.h caml/memory.h caml/debugger.h caml/backtrace_prim.h \
caml/backtrace.h caml/exec.h
minor_gc_npic.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/config.h caml/fail.h caml/finalise.h \
caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \

1
runtime/backtrace.c
View File

@ -26,6 +26,7 @@
#include "caml/backtrace.h"
#include "caml/backtrace_prim.h"
#include "caml/fail.h"
#include "caml/debugger.h"
/* The table of debug information fragments */
struct ext_table caml_debug_info;

4
runtime/backtrace_byt.c
View File

@ -42,6 +42,7 @@
#include "caml/backtrace.h"
#include "caml/fail.h"
#include "caml/backtrace_prim.h"
#include "caml/debugger.h"
/* The table of debug information fragments */
struct ext_table caml_debug_info;
@ -178,6 +179,9 @@ CAMLprim value caml_add_debug_info(code_t code_start, value code_size,
CAMLparam1(events_heap);
struct debug_info *debug_info;
if (events_heap != Val_unit)
caml_debugger(DEBUG_INFO_ADDED, events_heap);
/* build the OCaml-side debug_info value */
debug_info = caml_stat_alloc(sizeof(struct debug_info));

21
runtime/caml/debugger.h
View File

@ -29,13 +29,16 @@ extern uintnat caml_event_count;
enum event_kind {
EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT,
TRAP_BARRIER, UNCAUGHT_EXC
TRAP_BARRIER, UNCAUGHT_EXC, DEBUG_INFO_ADDED,
CODE_LOADED, CODE_UNLOADED
};
void caml_debugger_init (void);
void caml_debugger (enum event_kind event);
void caml_debugger (enum event_kind event, value param);
void caml_debugger_cleanup_fork (void);
opcode_t caml_debugger_saved_instruction(code_t pc);
/* Communication protocol */
/* Requests from the debugger to the runtime system */
@ -97,7 +100,11 @@ enum debugger_request {
/* Replies to a REQ_GO request. All replies are followed by three uint32_t:
- the value of the event counter
- the position of the stack
- the current pc. */
- the current pc.
The REP_CODE_DEBUG_INFO reply is also followed by:
- the newly added debug information.
The REP_CODE_{UN,}LOADED reply is also followed by:
- the code fragment index. */
enum debugger_reply {
REP_EVENT = 'e',
@ -108,8 +115,14 @@ enum debugger_reply {
/* Program exited by calling exit or reaching the end of the source. */
REP_TRAP = 's',
/* Trap barrier crossed. */
REP_UNCAUGHT_EXC = 'u'
REP_UNCAUGHT_EXC = 'u',
/* Program exited due to a stray exception. */
REP_CODE_DEBUG_INFO = 'D',
/* Additional debug info loaded. */
REP_CODE_LOADED = 'L',
/* Additional code loaded. */
REP_CODE_UNLOADED = 'U',
/* Additional code unloaded. */
};
#endif /* CAML_INTERNALS */

1
runtime/caml/fix_code.h
View File

@ -26,7 +26,6 @@
extern code_t caml_start_code;
extern asize_t caml_code_size;
extern unsigned char * caml_saved_code;
void caml_init_code_fragments(void);
void caml_load_code (int fd, asize_t len);

18
runtime/caml/intext.h
View File

@ -188,24 +188,6 @@ CAMLnoreturn_start
CAMLextern void caml_deserialize_error(char * msg)
CAMLnoreturn_end;
#ifdef CAML_INTERNALS
/* Auxiliary stuff for sending code pointers */
struct code_fragment {
char * code_start;
char * code_end;
unsigned char digest[16];
char digest_computed;
};
CAMLextern struct code_fragment * caml_extern_find_code(char *addr);
extern struct ext_table caml_code_fragments_table;
#endif /* CAML_INTERNALS */
#ifdef __cplusplus
}
#endif

13
runtime/caml/misc.h
View File

@ -443,6 +443,19 @@ extern void caml_instr_atexit (void);
# endif
#endif
/* A table of all code fragments (main program and dynlinked modules) */
struct code_fragment {
char *code_start;
char *code_end;
unsigned char digest[16];
char digest_computed;
};
extern struct ext_table caml_code_fragments_table;
int caml_find_code_fragment(char* pc, int *index, struct code_fragment **cf);
#endif /* CAML_INTERNALS */
#ifdef __cplusplus

166
runtime/debugger.c
View File

@ -39,7 +39,7 @@ void caml_debugger_init(void)
{
}
void caml_debugger(enum event_kind event)
void caml_debugger(enum event_kind event, value param)
{
}
@ -95,6 +95,8 @@ static struct channel * dbg_out;/* Output channel on the socket */
static char *dbg_addr = NULL;
static struct ext_table breakpoints_table;
static void open_connection(void)
{
#ifdef _WIN32
@ -186,6 +188,8 @@ void caml_debugger_init(void)
if (dbg_addr != NULL) caml_stat_free(dbg_addr);
dbg_addr = address;
caml_ext_table_init(&breakpoints_table, 16);
#ifdef _WIN32
winsock_startup();
(void)atexit(winsock_cleanup);
@ -266,16 +270,113 @@ static void safe_output_value(struct channel *chan, value val)
caml_external_raise = saved_external_raise;
}
struct breakpoint {
code_t pc;
opcode_t saved;
};
static struct breakpoint *find_breakpoint(code_t pc)
{
struct breakpoint *bpti;
int i;
for (i = 0; i < breakpoints_table.size; i++) {
bpti = (struct breakpoint *) breakpoints_table.contents[i];
if (bpti->pc == pc)
return bpti;
}
return NULL;
}
static void save_instruction(code_t pc)
{
struct breakpoint *bpt;
if (find_breakpoint(pc) != NULL) {
/* Already saved. Nothing to do. */
return;
}
bpt = caml_stat_alloc(sizeof(struct breakpoint));
bpt->pc = pc;
bpt->saved = *pc;
caml_ext_table_add(&breakpoints_table, bpt);
}
static void set_instruction(code_t pc, opcode_t opcode)
{
save_instruction(pc);
caml_set_instruction(pc, opcode);
}
static void restore_instruction(code_t pc)
{
struct breakpoint *bpt = find_breakpoint(pc);
CAMLassert (bpt != NULL);
*pc = bpt->saved;
caml_ext_table_remove(&breakpoints_table, bpt);
}
static code_t pc_from_pos(int frag, intnat pos)
{
struct code_fragment *cf;
CAMLassert (frag >= 0);
CAMLassert (frag < caml_code_fragments_table.size);
CAMLassert (pos >= 0);
CAMLassert (pos < caml_code_size);
cf = (struct code_fragment *) caml_code_fragments_table.contents[frag];
return (code_t) (cf->code_start + pos);
}
opcode_t caml_debugger_saved_instruction(code_t pc)
{
struct breakpoint *bpt = find_breakpoint(pc);
CAMLassert (bpt != NULL);
return bpt->saved;
}
void caml_debugger_code_unloaded(int index)
{
struct code_fragment *cf;
struct breakpoint *bpti;
int i;
if (!caml_debugger_in_use) return;
caml_putch(dbg_out, REP_CODE_UNLOADED);
caml_putword(dbg_out, index);
cf = (struct code_fragment *) caml_code_fragments_table.contents[index];
for (i = 0; i < breakpoints_table.size; i++) {
bpti = (struct breakpoint *) breakpoints_table.contents[i];
if ((char*) bpti->pc >= cf->code_start && (char*) bpti->pc < cf->code_end) {
caml_ext_table_remove(&breakpoints_table, bpti);
/* caml_ext_table_remove has shifted the next element in place
of the one we just removed. Decrement i for the next
iteration. */
i--;
}
}
}
#define Pc(sp) ((code_t)((sp)[0]))
#define Env(sp) ((sp)[1])
#define Extra_args(sp) (Long_val(((sp)[2])))
#define Locals(sp) ((sp) + 3)
void caml_debugger(enum event_kind event)
void caml_debugger(enum event_kind event, value param)
{
value * frame;
value *frame, *newframe;
intnat i, pos;
value val;
int frag, found = 0;
struct code_fragment *cf;
(void) found; /* Silence unused variable warning. */
if (dbg_socket == -1) return; /* Not connected to a debugger. */
@ -301,14 +402,30 @@ void caml_debugger(enum event_kind event)
case UNCAUGHT_EXC:
caml_putch(dbg_out, REP_UNCAUGHT_EXC);
break;
case DEBUG_INFO_ADDED:
caml_putch(dbg_out, REP_CODE_DEBUG_INFO);
caml_output_val(dbg_out, /* debug_info */ param, Val_emptylist);
break;
case CODE_LOADED:
caml_putch(dbg_out, REP_CODE_LOADED);
caml_putword(dbg_out, /* index */ Long_val(param));
break;
case CODE_UNLOADED:
caml_putch(dbg_out, REP_CODE_UNLOADED);
caml_putword(dbg_out, /* index */ Long_val(param));
break;
}
caml_putword(dbg_out, caml_event_count);
if (event == EVENT_COUNT || event == BREAKPOINT) {
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
found = caml_find_code_fragment((char*) Pc(frame), &frag, &cf);
CAMLassert(found);
caml_putword(dbg_out, frag);
caml_putword(dbg_out, (char*) Pc(frame) - cf->code_start);
} else {
/* No PC and no stack frame associated with other events */
caml_putword(dbg_out, 0);
caml_putword(dbg_out, -1);
caml_putword(dbg_out, 0);
}
caml_flush(dbg_out);
@ -319,23 +436,19 @@ void caml_debugger(enum event_kind event)
while(1) {
switch(caml_getch(dbg_in)) {
case REQ_SET_EVENT:
frag = caml_getword(dbg_in);
pos = caml_getword(dbg_in);
CAMLassert (pos >= 0);
CAMLassert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT);
set_instruction(pc_from_pos(frag, pos), EVENT);
break;
case REQ_SET_BREAKPOINT:
frag = caml_getword(dbg_in);
pos = caml_getword(dbg_in);
CAMLassert (pos >= 0);
CAMLassert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK);
set_instruction(pc_from_pos(frag, pos), BREAK);
break;
case REQ_RESET_INSTR:
frag = caml_getword(dbg_in);
pos = caml_getword(dbg_in);
CAMLassert (pos >= 0);
CAMLassert (pos < caml_code_size);
pos = pos / sizeof(opcode_t);
caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]);
restore_instruction(pc_from_pos(frag, pos));
break;
case REQ_CHECKPOINT:
#ifndef _WIN32
@ -371,10 +484,13 @@ void caml_debugger(enum event_kind event)
/* Fall through */
case REQ_GET_FRAME:
caml_putword(dbg_out, caml_stack_high - frame);
if (frame < caml_stack_high){
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
}else{
caml_putword (dbg_out, 0);
if (frame < caml_stack_high &&
caml_find_code_fragment((char*) Pc(frame), &frag, &cf)) {
caml_putword(dbg_out, frag);
caml_putword(dbg_out, (char*) Pc(frame) - cf->code_start);
} else {
caml_putword(dbg_out, 0);
caml_putword(dbg_out, 0);
}
caml_flush(dbg_out);
break;
@ -384,12 +500,15 @@ void caml_debugger(enum event_kind event)
break;
case REQ_UP_FRAME:
i = caml_getword(dbg_in);
if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) {
newframe = frame + Extra_args(frame) + i + 3;
if (newframe >= caml_stack_high ||
!caml_find_code_fragment((char*) Pc(newframe), &frag, &cf)) {
caml_putword(dbg_out, -1);
} else {
frame += Extra_args(frame) + i + 3;
frame = newframe;
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
caml_putword(dbg_out, frag);
caml_putword(dbg_out, (char*) Pc(frame) - cf->code_start);
}
caml_flush(dbg_out);
break;
@ -441,7 +560,10 @@ void caml_debugger(enum event_kind event)
break;
case REQ_GET_CLOSURE_CODE:
val = getval(dbg_in);
caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t));
found = caml_find_code_fragment((char*) Code_val(val), &frag, &cf);
CAMLassert(found);
caml_putword(dbg_out, frag);
caml_putword(dbg_out, (char*) Code_val(val) - cf->code_start);
caml_flush(dbg_out);
break;
case REQ_SET_FORK_MODE:

22
runtime/extern.c
View File

@ -610,9 +610,13 @@ static void extern_rec(value v)
}
}
}
else if ((cf = caml_extern_find_code((char *) v)) != NULL) {
else if (caml_find_code_fragment((char*) v, NULL, &cf)) {
if ((extern_flags & CLOSURES) == 0)
extern_invalid_argument("output_value: functional value");
if (! cf->digest_computed) {
caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
cf->digest_computed = 1;
}
writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock((const char *)cf->digest, 16);
} else {
@ -929,19 +933,3 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len)
}
#endif
}
/* Find where a code pointer comes from */
CAMLexport struct code_fragment * caml_extern_find_code(char *addr)
{
int i;
for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {
struct code_fragment * cf = caml_code_fragments_table.contents[i];
if (! cf->digest_computed) {
caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
cf->digest_computed = 1;
}
if (cf->code_start <= addr && addr < cf->code_end) return cf;
}
return NULL;
}

11
runtime/fix_code.c
View File

@ -37,7 +37,6 @@
code_t caml_start_code;
asize_t caml_code_size;
unsigned char * caml_saved_code;
struct ext_table caml_code_fragments_table;
/* Read the main bytecode block from a file */
@ -56,8 +55,6 @@ void caml_init_code_fragments(void) {
void caml_load_code(int fd, asize_t len)
{
int i;
caml_code_size = len;
caml_start_code = (code_t) caml_stat_alloc(caml_code_size);
if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size)
@ -67,15 +64,7 @@ void caml_load_code(int fd, asize_t len)
#ifdef ARCH_BIG_ENDIAN
caml_fixup_endianness(caml_start_code, caml_code_size);
#endif
if (caml_debugger_in_use) {
len /= sizeof(opcode_t);
caml_saved_code = (unsigned char *) caml_stat_alloc(len);
for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i];
}
#ifdef THREADED_CODE
/* Better to thread now than at the beginning of [caml_interprete],
since the debugger interface needs to perform SET_EVENT requests
on the code. */
caml_thread_code(caml_start_code, caml_code_size);
#endif
}

17
runtime/interp.c
View File

@ -104,10 +104,10 @@ sp is a local copy of the global variable caml_extern_sp. */
#ifdef THREADED_CODE
#define Restart_curr_instr \
goto *(jumptable[caml_saved_code[pc - 1 - caml_start_code]])
goto *((void*)(jumptbl_base + caml_debugger_saved_instruction(pc - 1)))
#else
#define Restart_curr_instr \
curr_instr = caml_saved_code[pc - 1 - caml_start_code]; \
curr_instr = caml_debugger_saved_instruction(pc - 1); \
goto dispatch_instr
#endif
@ -845,17 +845,20 @@ value caml_interprete(code_t prog, asize_t prog_size)
Next;
Instruct(RAISE_NOTRACE):
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
if (caml_trapsp >= caml_trap_barrier)
caml_debugger(TRAP_BARRIER, Val_unit);
goto raise_notrace;
Instruct(RERAISE):
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
if (caml_trapsp >= caml_trap_barrier)
caml_debugger(TRAP_BARRIER, Val_unit);
if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1);
goto raise_notrace;
Instruct(RAISE):
raise_exception:
if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER);
if (caml_trapsp >= caml_trap_barrier)
caml_debugger(TRAP_BARRIER, Val_unit);
if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0);
raise_notrace:
if ((char *) caml_trapsp
@ -1130,14 +1133,14 @@ value caml_interprete(code_t prog, asize_t prog_size)
Instruct(EVENT):
if (--caml_event_count == 0) {
Setup_for_debugger;
caml_debugger(EVENT_COUNT);
caml_debugger(EVENT_COUNT, Val_unit);
Restore_after_debugger;
}
Restart_curr_instr;
Instruct(BREAK):
Setup_for_debugger;
caml_debugger(BREAKPOINT);
caml_debugger(BREAKPOINT, Val_unit);
Restore_after_debugger;
Restart_curr_instr;

43
runtime/meta.c
View File

@ -31,6 +31,7 @@
#include "caml/mlvalues.h"
#include "caml/prims.h"
#include "caml/stacks.h"
#include "caml/debugger.h"
#include "caml/backtrace_prim.h"
#ifndef NATIVE_CODE
@ -117,6 +118,10 @@ CAMLprim value caml_reify_bytecode(value ls_prog,
caml_thread_code((code_t) prog, len);
#endif
caml_prepare_bytecode((code_t) prog, len);
/* Notify debugger after fragment gets added and reified. */
caml_debugger(CODE_LOADED, Val_long(caml_code_fragments_table.size - 1));
clos = caml_alloc_small (1, Closure_tag);
Code_val(clos) = (code_t) prog;
bytecode = caml_alloc_small (2, Abstract_tag);
@ -136,26 +141,21 @@ CAMLprim value caml_static_release_bytecode(value bc)
{
code_t prog;
asize_t len;
struct code_fragment * cf = NULL, * cfi;
int i;
int found, index;
struct code_fragment *cf;
prog = Bytecode_val(bc)->prog;
len = Bytecode_val(bc)->len;
caml_remove_debug_info(prog);
for (i = 0; i < caml_code_fragments_table.size; i++) {
cfi = (struct code_fragment *) caml_code_fragments_table.contents[i];
if (cfi->code_start == (char *) prog &&
cfi->code_end == (char *) prog + len) {
cf = cfi;
break;
}
}
if (!cf) {
/* [cf] Not matched with a caml_reify_bytecode call; impossible. */
CAMLassert (0);
} else {
caml_ext_table_remove(&caml_code_fragments_table, cf);
}
found = caml_find_code_fragment((char*) prog, &index, &cf);
/* Not matched with a caml_reify_bytecode call; impossible. */
CAMLassert(found); (void) found; /* Silence unused variable warning. */
/* Notify debugger before the fragment gets destroyed. */
caml_debugger(CODE_UNLOADED, Val_long(index));
caml_ext_table_remove(&caml_code_fragments_table, cf);
#ifndef NATIVE_CODE
caml_release_bytecode(prog, len);
@ -166,17 +166,6 @@ CAMLprim value caml_static_release_bytecode(value bc)
return Val_unit;
}
CAMLprim value caml_register_code_fragment(value prog, value len, value digest)
{
struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment));
cf->code_start = (char *) prog;
cf->code_end = (char *) prog + Long_val(len);
memcpy(cf->digest, String_val(digest), 16);
cf->digest_computed = 1;
caml_ext_table_add(&caml_code_fragments_table, cf);
return Val_unit;
}
CAMLprim value caml_realloc_global(value size)
{
mlsize_t requested_size, actual_size, i;

16
runtime/misc.c
View File

@ -281,3 +281,19 @@ void caml_instr_atexit (void)
}
}
#endif /* CAML_INSTR */
int caml_find_code_fragment(char* pc, int *index, struct code_fragment **cf)
{
struct code_fragment *cfi;
int i;
for (i = 0; i < caml_code_fragments_table.size; i++) {
cfi = (struct code_fragment *) caml_code_fragments_table.contents[i];
if ((char*) pc >= cfi->code_start && (char*) pc < cfi->code_end) {
if (index != NULL) *index = i;
if (cf != NULL) *cf = cfi;
return 1;
}
}
return 0;
}

14
runtime/startup_byt.c
View File

@ -444,14 +444,14 @@ CAMLexport void caml_main(char_os **argv)
_beginthread(caml_signal_thread, 4096, NULL);
#endif
/* Execute the program */
caml_debugger(PROGRAM_START);
caml_debugger(PROGRAM_START, Val_unit);
res = caml_interprete(caml_start_code, caml_code_size);
if (Is_exception_result(res)) {
caml_exn_bucket = Extract_exception(res);
if (caml_debugger_in_use) {
caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
exception value.*/
caml_debugger(UNCAUGHT_EXC);
caml_debugger(UNCAUGHT_EXC, Val_unit);
}
caml_fatal_uncaught_exception(caml_exn_bucket);
}
@ -513,12 +513,6 @@ CAMLexport value caml_startup_code_exn(
caml_code_size = code_size;
caml_init_code_fragments();
caml_init_debug_info();
if (caml_debugger_in_use) {
uintnat len, i;
len = code_size / sizeof(opcode_t);
caml_saved_code = (unsigned char *) caml_stat_alloc(len);
for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i];
}
#ifdef THREADED_CODE
caml_thread_code(caml_start_code, code_size);
#endif
@ -535,7 +529,7 @@ CAMLexport value caml_startup_code_exn(
/* Initialize system libraries */
caml_sys_init(exe_name, argv);
/* Execute the program */
caml_debugger(PROGRAM_START);
caml_debugger(PROGRAM_START, Val_unit);
return caml_interprete(caml_start_code, caml_code_size);
}
@ -556,7 +550,7 @@ CAMLexport void caml_startup_code(
if (caml_debugger_in_use) {
caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
exception value.*/
caml_debugger(UNCAUGHT_EXC);
caml_debugger(UNCAUGHT_EXC, Val_unit);
}
caml_fatal_uncaught_exception(caml_exn_bucket);
}

2
runtime/sys.c
View File

@ -148,7 +148,7 @@ CAMLprim value caml_sys_exit(value retcode_v)
}
#ifndef NATIVE_CODE
caml_debugger(PROGRAM_EXIT);
caml_debugger(PROGRAM_EXIT, Val_unit);
#endif
caml_instr_atexit ();
if (caml_cleanup_on_exit)

11
testsuite/tests/tool-debugger/dynlink/host.debug.reference Normal file
View File

@ -0,0 +1,11 @@
Loading program... done.
hello host
Module(s) Plugin loaded.
Breakpoint: 1
2 <|b|>print_endline "hello plugin"
Backtrace:
#0 Plugin plugin.ml:2:3
#1 Plugin plugin.ml:4:10
hello plugin
Program exit.

35
testsuite/tests/tool-debugger/dynlink/host.ml Normal file
View File

@ -0,0 +1,35 @@
(* TEST
include dynlink
files = "host.ml plugin.ml"
libraries = ""
flags += " -g "
ocamldebug_script = "${test_source_directory}/input_script"
* debugger
** shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
module = "host.ml"
**** ocamlc.byte
module = "plugin.ml"
***** ocamlc.byte
module = ""
all_modules = "host.cmo"
program = "${test_build_directory}/host.byte"
libraries = "dynlink"
****** run
output = "host.output"
******* check-program-output
reference = "${test_source_directory}/host.reference"
******* ocamldebug
output = "host.debug.output"
******** check-program-output
reference = "${test_source_directory}/host.debug.reference"
*)
let () = print_endline "hello host"; Dynlink.loadfile "plugin.cmo"

2
testsuite/tests/tool-debugger/dynlink/host.reference Normal file
View File

@ -0,0 +1,2 @@
hello host
hello plugin

5
testsuite/tests/tool-debugger/dynlink/input_script Normal file
View File

@ -0,0 +1,5 @@
r
br @ Plugin 2
r
bt
r

1
testsuite/tests/tool-debugger/dynlink/ocamltests Normal file
View File

@ -0,0 +1 @@
host.ml

4
testsuite/tests/tool-debugger/dynlink/plugin.ml Normal file
View File

@ -0,0 +1,4 @@
let do_plugin () =
print_endline "hello plugin"
let () = do_plugin ()