1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
6(*           OCaml port by John Malecki and Xavier Leroy                  *)
7(*                                                                        *)
8(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
9(*     en Automatique.                                                    *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17(******************************* Breakpoints ***************************)
18
19open Checkpoints
20open Debugcom
21open Instruct
22open Printf
23
24(*** Debugging. ***)
25let debug_breakpoints = ref false
26
27(*** Data. ***)
28
29(* Number of the last added breakpoint. *)
30let breakpoint_number = ref 0
31
32(* Breakpoint number -> event. *)
33let breakpoints = ref ([] : (int * debug_event) list)
34
35(* Program counter -> breakpoint count. *)
36let positions = ref ([] : (int * int ref) list)
37
38(* Versions of the breakpoint list. *)
39let current_version = ref 0
40let max_version = ref 0
41
42(*** Miscellaneous. ***)
43
44(* Mark breakpoints as installed in current checkpoint. *)
45let copy_breakpoints () =
46  !current_checkpoint.c_breakpoints <- !positions;
47  !current_checkpoint.c_breakpoint_version <- !current_version
48
49(* Announce a new version of the breakpoint list. *)
50let new_version () =
51  incr max_version;
52  current_version := !max_version
53
54(*** Information about breakpoints. ***)
55
56let breakpoints_count () =
57  List.length !breakpoints
58
59(* List of breakpoints at `pc'. *)
60let 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   []
68  end
69    @
70  List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc)
71                            !breakpoints)
72
73(* Is there a breakpoint at `pc' ? *)
74let breakpoint_at_pc pc =
75  breakpoints_at_pc pc <> []
76
77(*** Set and remove breakpoints ***)
78
79(* Remove all breakpoints. *)
80let remove_breakpoints pos =
81  if !debug_breakpoints then
82    (print_string "Removing breakpoints..."; print_newline ());
83  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
92
93(* Set all breakpoints. *)
94let set_breakpoints pos =
95  if !debug_breakpoints then
96    (print_string "Setting breakpoints..."; print_newline ());
97  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
105
106(* Ensure the current version in installed in current checkpoint. *)
107let update_breakpoints () =
108  if !debug_breakpoints then begin
109    prerr_string "Updating breakpoints... ";
110    prerr_int !current_checkpoint.c_breakpoint_version;
111    prerr_string " ";
112    prerr_int !current_version;
113    prerr_endline ""
114  end;
115  if !current_checkpoint.c_breakpoint_version <> !current_version then
116    Exec.protect
117      (function () ->
118         remove_breakpoints !current_checkpoint.c_breakpoints;
119         set_breakpoints !positions;
120         copy_breakpoints ())
121
122let change_version version pos =
123  Exec.protect
124    (function () ->
125       current_version := version;
126       positions := pos)
127
128(* Execute given function with no breakpoint in current checkpoint. *)
129(* --- `goto' runs faster this way (does not stop on each breakpoint). *)
130let 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
141
142(* Add a position in the position list. *)
143(* Change version if necessary. *)
144let insert_position pos =
145  try
146    incr (List.assoc pos !positions)
147  with
148    Not_found ->
149      positions := (pos, ref 1) :: !positions;
150      new_version ()
151
152(* Remove a position in the position list. *)
153(* Change version if necessary. *)
154let remove_position pos =
155  let count = List.assoc pos !positions in
156    decr count;
157    if !count = 0 then begin
158      positions := List.remove_assoc pos !positions;
159      new_version ()
160    end
161
162(* Insert a new breakpoint in lists. *)
163let 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      printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos
174             (Pos.get_desc event);
175      print_newline ()
176
177(* Remove a breakpoint from lists. *)
178let remove_breakpoint number =
179  try
180    let ev = List.assoc number !breakpoints in
181    let pos = ev.ev_pos in
182      Exec.protect
183        (function () ->
184           breakpoints := List.remove_assoc number !breakpoints;
185           remove_position pos;
186           printf "Removed breakpoint %d at %d: %s" number ev.ev_pos
187                  (Pos.get_desc ev);
188           print_newline ()
189        )
190  with
191    Not_found ->
192      prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ ".");
193      raise Not_found
194
195let remove_all_breakpoints () =
196  List.iter (function (number, _) -> remove_breakpoint number) !breakpoints
197
198(*** Temporary breakpoints. ***)
199
200(* Temporary breakpoint position. *)
201let temporary_breakpoint_position = ref (None : int option)
202
203(* Execute `funct' with a breakpoint added at `pc'. *)
204(* --- Used by `finish'. *)
205let exec_with_temporary_breakpoint pc funct =
206  let previous_version = !current_version in
207    let remove () =
208      temporary_breakpoint_position := None;
209      current_version := previous_version;
210      let count = List.assoc pc !positions in
211        decr count;
212        if !count = 0 then begin
213          positions := List.remove_assoc pc !positions;
214          reset_instr pc;
215          Symbols.set_event_at_pc pc
216        end
217
218    in
219      Exec.protect (function () -> insert_position pc);
220      temporary_breakpoint_position := Some pc;
221      try
222        funct ();
223        Exec.protect remove
224      with
225        x ->
226          Exec.protect remove;
227          raise x
228