1919open Checkpoints
2020open Debugcom
2121open Instruct
22+ open Events
2223open Printf
2324
2425(* ** Debugging. ***)
@@ -30,10 +31,11 @@ let debug_breakpoints = ref false
3031let breakpoint_number = ref 0
3132
3233(* Breakpoint number -> event. *)
33- let breakpoints = ref ([] : (int * debug_event ) list )
34+ type breakpoint_id = int
35+ let breakpoints = ref ([] : (breakpoint_id * code_event ) list )
3436
3537(* Program counter -> breakpoint count. *)
36- let positions = ref ([] : (int * int ref ) list )
38+ let positions = ref ([] : (pc * int ref ) list )
3739
3840(* Versions of the breakpoint list. *)
3941let current_version = ref 0
@@ -58,50 +60,46 @@ let breakpoints_count () =
5860
5961(* List of breakpoints at `pc'. *)
6062let rec breakpoints_at_pc pc =
61- begin try
62- let ev = Symbols. event_at_pc pc in
63- match ev.ev_repr with
64- Event_child {contents = pc' } -> breakpoints_at_pc pc'
65- | _ -> []
66- with Not_found ->
67- []
63+ begin match Symbols. event_at_pc pc with
64+ | {ev_frag = frag ; ev_ev = {ev_repr = Event_child {contents = pos } } } ->
65+ breakpoints_at_pc {frag; pos}
66+ | _ -> []
67+ | exception Not_found -> []
6868 end
6969 @
70- List. map fst (List. filter (function (_ , {ev_pos = pos } ) -> pos = pc)
71- ! breakpoints)
70+ List. map fst (List. filter
71+ (function (_ , {ev_frag = frag ; ev_ev = {ev_pos = pos } } ) ->
72+ {frag; pos} = pc)
73+ ! breakpoints)
7274
7375(* Is there a breakpoint at `pc' ? *)
7476let breakpoint_at_pc pc =
7577 breakpoints_at_pc pc <> []
7678
7779(* ** Set and remove breakpoints ***)
7880
81+ let print_pc out {frag;pos} = fprintf out " %d:%d"
82+
7983(* Remove all breakpoints. *)
80- let remove_breakpoints pos =
84+ let remove_breakpoints pcs =
8185 if ! debug_breakpoints then
82- (print_string " Removing breakpoints..." ; print_newline () ) ;
86+ printf " Removing breakpoints...\n %! "
8387 List. iter
84- (function (pos , _ ) ->
85- if ! debug_breakpoints then begin
86- print_int pos;
87- print_newline()
88- end ;
89- reset_instr pos;
90- Symbols. set_event_at_pc pos)
91- pos
88+ (function (pc , _ ) ->
89+ if ! debug_breakpoints then printf " %a\n %!"
90+ reset_instr pc;
91+ Symbols. set_event_at_pc pc)
92+ pcs
9293
9394(* Set all breakpoints. *)
94- let set_breakpoints pos =
95+ let set_breakpoints pcs =
9596 if ! debug_breakpoints then
96- (print_string " Setting breakpoints..." ; print_newline () ) ;
97+ printf " Setting breakpoints...\n %! "
9798 List. iter
98- (function (pos , _ ) ->
99- if ! debug_breakpoints then begin
100- print_int pos;
101- print_newline()
102- end ;
103- set_breakpoint pos)
104- pos
99+ (function (pc , _ ) ->
100+ if ! debug_breakpoints then printf " %a\n %!"
101+ set_breakpoint pc)
102+ pcs
105103
106104(* Ensure the current version is installed in current checkpoint. *)
107105let update_breakpoints () =
@@ -119,25 +117,13 @@ let update_breakpoints () =
119117 set_breakpoints ! positions;
120118 copy_breakpoints () )
121119
122- let change_version version pos =
123- Exec. protect
124- (function () ->
125- current_version := version;
126- positions := pos)
127-
128120(* Execute given function with no breakpoint in current checkpoint. *)
129121(* --- `goto' runs faster this way (does not stop on each breakpoint). *)
130122let execute_without_breakpoints f =
131- let version = ! current_version
132- and pos = ! positions
133- in
134- change_version 0 [] ;
135- try
136- f () ;
137- change_version version pos
138- with
139- _ ->
140- change_version version pos
123+ Misc. protect_refs [Misc. R (Debugger_config. break_on_load, false );
124+ Misc. R (current_version, 0 );
125+ Misc. R (positions, [] )]
126+ f
141127
142128(* Add a position in the position list. *)
143129(* Change version if necessary. *)
@@ -160,37 +146,33 @@ let remove_position pos =
160146 end
161147
162148(* Insert a new breakpoint in lists. *)
163- let rec new_breakpoint =
164- function
165- {ev_repr = Event_child pc } ->
166- new_breakpoint (Symbols. any_event_at_pc ! pc)
167- | event ->
168- Exec. protect
169- (function () ->
170- incr breakpoint_number;
171- insert_position event.ev_pos;
172- breakpoints := (! breakpoint_number, event) :: ! breakpoints);
173- if ! Parameters. breakpoint then begin
174- printf " Breakpoint %d at %d: %s" ! breakpoint_number event.ev_pos
175- (Pos. get_desc event);
176- print_newline ()
177- end
149+ let rec new_breakpoint event =
150+ match event with
151+ {ev_frag =frag ; ev_ev ={ev_repr =Event_child pos } } ->
152+ new_breakpoint (Symbols. any_event_at_pc {frag; pos= (! pos)})
153+ | {ev_frag =frag ; ev_ev ={ev_pos =pos } } ->
154+ let pc = {frag; pos} in
155+ Exec. protect
156+ (function () ->
157+ incr breakpoint_number;
158+ insert_position pc;
159+ breakpoints := (! breakpoint_number, event) :: ! breakpoints);
160+ if ! Parameters. breakpoint then
161+ printf " Breakpoint %d at %a: %s\n %!" ! breakpoint_number print_pc pc
162+ (Pos. get_desc event)
178163
179164(* Remove a breakpoint from lists. *)
180165let remove_breakpoint number =
181166 try
182167 let ev = List. assoc number ! breakpoints in
183- let pos = ev.ev_pos in
184- Exec. protect
185- (function () ->
186- breakpoints := List. remove_assoc number ! breakpoints;
187- remove_position pos;
188- if ! Parameters. breakpoint then begin
189- printf " Removed breakpoint %d at %d: %s"
190- (Pos. get_desc ev);
191- print_newline ()
192- end
193- )
168+ let pc = {frag = ev.ev_frag; pos= ev.ev_ev.ev_pos} in
169+ Exec. protect
170+ (function () ->
171+ breakpoints := List. remove_assoc number ! breakpoints;
172+ remove_position pc;
173+ if ! Parameters. breakpoint then
174+ printf " Removed breakpoint %d at %a: %s\n %!"
175+ (Pos. get_desc ev))
194176 with
195177 Not_found ->
196178 prerr_endline (" No breakpoint number " ^ (Int. to_string number) ^ " ."
@@ -202,7 +184,7 @@ let remove_all_breakpoints () =
202184(* ** Temporary breakpoints. ***)
203185
204186(* Temporary breakpoint position. *)
205- let temporary_breakpoint_position = ref (None : int option )
187+ let temporary_breakpoint_position = ref (None : pc option )
206188
207189(* Execute `funct' with a breakpoint added at `pc'. *)
208190(* --- Used by `finish'. *)
0 commit comments