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