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 (**************************** Time travel ******************************)
18
19 open Int64ops
20 open Instruct
21 open Events
22 open Debugcom
23 open Primitives
24 open Checkpoints
25 open Breakpoints
26 open Trap_barrier
27 open Input_handling
28 open Debugger_config
29 open Program_loading
30 open Question
31
32 exception Current_checkpoint_lost
33 exception Current_checkpoint_lost_start_at of int64 * int64
34
35 let remove_1st key list =
36 let rec remove =
37 function
38 [] -> []
39 | a::l -> if a == key then l else a::(remove l)
40 in
41 remove list
42
43 (*** Debugging. ***)
44
45 let debug_time_travel = ref false
46
47 (*** Internal utilities. ***)
48
49 (* Insert a checkpoint in the checkpoint list.
50 * Raise `Exit' if there is already a checkpoint at the same time.
51 *)
52 let insert_checkpoint ({c_time = time} as checkpoint) =
53 let rec traverse =
54 function
55 [] -> [checkpoint]
56 | (({c_time = t} as a)::l) as l' ->
57 if t > time then
58 a::(traverse l)
59 else if t = time then
60 raise Exit
61 else
62 checkpoint::l'
63 in
64 checkpoints := traverse !checkpoints
65
66 (* Remove a checkpoint from the checkpoint list.
67 * --- No error if not found.
68 *)
69 let remove_checkpoint checkpoint =
70 checkpoints := remove_1st checkpoint !checkpoints
71
72 (* Wait for the process used by `checkpoint' to connect.
73 * --- Usually not called (the process is already connected).
74 *)
75 let wait_for_connection checkpoint =
76 try
77 Exec.unprotect
78 (function () ->
79 let old_controller = Input_handling.current_controller !connection in
80 execute_with_other_controller
81 (function
82 fd ->
83 old_controller fd;
84 if checkpoint.c_valid = true then
85 exit_main_loop ())
86 !connection
87 main_loop)
88 with
89 Sys.Break ->
90 checkpoint.c_parent <- root;
91 remove_checkpoint checkpoint;
92 checkpoint.c_pid <- -1;
93 raise Sys.Break
94
95 (* Select a checkpoint as current. *)
96 let set_current_checkpoint checkpoint =
97 if !debug_time_travel then
98 prerr_endline ("Select: " ^ (Int.to_string checkpoint.c_pid));
99 if not checkpoint.c_valid then
100 wait_for_connection checkpoint;
101 current_checkpoint := checkpoint;
102 let dead_frags = List.filter (fun frag ->
103 not (List.mem frag checkpoint.c_code_fragments))
104 (Symbols.code_fragments ())
105 in
106 List.iter Symbols.erase_symbols dead_frags;
107 set_current_connection checkpoint.c_fd
108
109 (* Kill `checkpoint'. *)
110 let kill_checkpoint checkpoint =
111 if !debug_time_travel then
112 prerr_endline ("Kill: " ^ (Int.to_string checkpoint.c_pid));
113 if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *)
114 (if not checkpoint.c_valid then
115 wait_for_connection checkpoint;
116 stop checkpoint.c_fd;
117 if checkpoint.c_parent.c_pid > 0 then
118 wait_child checkpoint.c_parent.c_fd;
119 checkpoint.c_parent <- root;
120 close_io checkpoint.c_fd;
121 remove_file checkpoint.c_fd;
122 remove_checkpoint checkpoint);
123 checkpoint.c_pid <- -1 (* Don't exist anymore *)
124
125 (*** Cleaning the checkpoint list. ***)
126
127 (* Separate checkpoints before (<=) and after (>) `t'. *)
128 (* ### t checkpoints -> (after, before) *)
129 let cut t =
130 let rec cut_t =
131 function
132 [] -> ([], [])
133 | ({c_time = t'} as a::l) as l' ->
134 if t' <= t then
135 ([], l')
136 else
137 let (b, e) = cut_t l in
138 (a::b, e)
139 in
140 cut_t
141
142 (* Partition the checkpoints list. *)
143 let cut2 t0 t l =
144 let rec cut2_t0 t =
145 function
146 [] -> []
147 | l ->
148 let (after, before) = cut (t0 -- t -- _1) l in
149 let l = cut2_t0 (t ++ t) before in
150 after::l
151 in
152 let (after, before) = cut (t0 -- _1) l in
153 after::(cut2_t0 t before)
154
155 (* Separate first elements and last element of a list of checkpoints. *)
156 let chk_merge2 cont =
157 let rec chk_merge2_cont =
158 function
159 [] -> cont
160 | [a] ->
161 let (accepted, rejected) = cont in
162 (a::accepted, rejected)
163 | a::l ->
164 let (accepted, rejected) = chk_merge2_cont l in
165 (accepted, a::rejected)
166 in chk_merge2_cont
167
168 (* Separate the checkpoint list. *)
169 (* ### list -> accepted * rejected *)
170 let rec chk_merge =
171 function
172 [] -> ([], [])
173 | l::tail ->
174 chk_merge2 (chk_merge tail) l
175
176 let new_checkpoint_list checkpoint_count accepted rejected =
177 if List.length accepted >= checkpoint_count then
178 let (k, l) = list_truncate2 checkpoint_count accepted in
179 (k, l @ rejected)
180 else
181 let (k, l) =
182 list_truncate2 (checkpoint_count - List.length accepted) rejected
183 in
184 (List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k,
185 l)
186
187 (* Clean the checkpoint list. *)
188 (* Reference time is `time'. *)
189 let clean_checkpoints time checkpoint_count =
190 let (after, before) = cut time !checkpoints in
191 let (accepted, rejected) =
192 chk_merge (cut2 time !checkpoint_small_step before)
193 in
194 let (kept, lost) =
195 new_checkpoint_list checkpoint_count accepted after
196 in
197 List.iter kill_checkpoint (lost @ rejected);
198 checkpoints := kept
199
200 (*** Internal functions for moving. ***)
201
202 (* Find the first checkpoint before (or at) `time'.
203 * Ask for reloading the program if necessary.
204 *)
205 let find_checkpoint_before time =
206 let rec find =
207 function
208 [] ->
209 print_string "Can't go that far in the past !"; print_newline ();
210 if yes_or_no "Reload program" then begin
211 load_program ();
212 find !checkpoints
213 end
214 else
215 raise Toplevel
216 | { c_time = t } as a::l ->
217 if t > time then
218 find l
219 else
220 a
221 in find !checkpoints
222
223 (* Make a copy of the current checkpoint and clean the checkpoint list. *)
224 (* --- The new checkpoint is not put in the list. *)
225 let duplicate_current_checkpoint () =
226 let checkpoint = !current_checkpoint in
227 if not checkpoint.c_valid then
228 wait_for_connection checkpoint;
229 let new_checkpoint = (* Ghost *)
230 {c_time = checkpoint.c_time;
231 c_pid = 0;
232 c_fd = checkpoint.c_fd;
233 c_valid = false;
234 c_report = checkpoint.c_report;
235 c_state = C_stopped;
236 c_parent = checkpoint;
237 c_breakpoint_version = checkpoint.c_breakpoint_version;
238 c_breakpoints = checkpoint.c_breakpoints;
239 c_trap_barrier = checkpoint.c_trap_barrier;
240 c_code_fragments = checkpoint.c_code_fragments}
241 in
242 checkpoints := list_replace checkpoint new_checkpoint !checkpoints;
243 set_current_checkpoint checkpoint;
244 clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1);
245 if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *)
246 (match do_checkpoint () with (* Duplicate checkpoint *)
247 Checkpoint_done pid ->
248 (new_checkpoint.c_pid <- pid;
249 if !debug_time_travel then
250 prerr_endline ("Waiting for connection: " ^ Int.to_string pid))
251 | Checkpoint_failed ->
252 prerr_endline
253 "A fork failed. Reducing maximum number of checkpoints.";
254 checkpoint_max_count := List.length !checkpoints - 1;
255 remove_checkpoint new_checkpoint)
256
257 (* Was the movement interrupted ? *)
258 (* --- An exception could have been used instead, *)
259 (* --- but it is not clear where it should be caught. *)
260 (* --- For instance, it should not be caught in `step' *)
261 (* --- (as `step' is used in `next_1'). *)
262 (* --- On the other side, other modules does not need to know *)
263 (* --- about this exception. *)
264 let interrupted = ref false
265
266 (* Information about last breakpoint encountered *)
267 let last_breakpoint = ref None
268
269 (* Last debug info loaded *)
270 let last_debug_info = ref None
271
272 let rec do_go_dynlink steps =
273 match do_go steps with
274 | { rep_type = Code_loaded frag; rep_event_count = steps } as report ->
275 begin match !last_debug_info with
276 | Some di ->
277 Symbols.add_symbols frag di;
278 Symbols.set_all_events frag;
279 last_debug_info := None
280 | None -> assert false
281 end;
282 if !break_on_load then report
283 else do_go_dynlink steps
284 | { rep_type = Code_unloaded frag; rep_event_count = steps } ->
285 Symbols.erase_symbols frag;
286 do_go_dynlink steps
287 | { rep_type = Debug_info di; rep_event_count = steps } ->
288 last_debug_info := Some (Array.to_list di);
289 do_go_dynlink steps
290 | report -> report
291
292 (* Ensure we stop on an event. *)
293 let rec stop_on_event report =
294 match report with
295 {rep_type = Breakpoint; rep_program_pointer = pc;
296 rep_stack_pointer = sp} ->
297 last_breakpoint := Some (pc, sp);
298 Symbols.update_current_event ();
299 begin match !current_event with
300 None -> find_event ()
301 | Some _ -> ()
302 end
303 | {rep_type = Trap_barrier} ->
304 (* No event at current position. *)
305 find_event ()
306 | _ ->
307 ()
308
309 and find_event () =
310 if !debug_time_travel then begin
311 print_string "Searching next event...";
312 print_newline ()
313 end;
314 let report = do_go_dynlink _1 in
315 !current_checkpoint.c_report <- Some report;
316 stop_on_event report
317
318 (* Internal function for running debugged program.
319 * Requires `duration > 0'.
320 *)
321 let internal_step duration =
322 match current_report () with
323 Some {rep_type = Exited | Uncaught_exc} -> ()
324 | _ ->
325 Exec.protect
326 (function () ->
327 if !make_checkpoints then
328 duplicate_current_checkpoint ()
329 else
330 remove_checkpoint !current_checkpoint;
331 update_breakpoints ();
332 update_trap_barrier ();
333 !current_checkpoint.c_state <- C_running duration;
334 let report = do_go_dynlink duration in
335 !current_checkpoint.c_report <- Some report;
336 !current_checkpoint.c_state <- C_stopped;
337 !current_checkpoint.c_code_fragments <- Symbols.code_fragments ();
338 if report.rep_type = Event then begin
339 !current_checkpoint.c_time <-
340 !current_checkpoint.c_time ++ duration;
341 interrupted := false;
342 last_breakpoint := None
343 end
344 else begin
345 !current_checkpoint.c_time <-
346 !current_checkpoint.c_time ++ duration
347 -- report.rep_event_count ++ _1;
348 interrupted := true;
349 last_breakpoint := None;
350 stop_on_event report
351 end;
352 (try
353 insert_checkpoint !current_checkpoint
354 with
355 Exit ->
356 kill_checkpoint !current_checkpoint;
357 set_current_checkpoint
358 (find_checkpoint_before (current_time ()))));
359 if !debug_time_travel then begin
360 print_string "Checkpoints: pid(time)"; print_newline ();
361 List.iter
362 (function {c_time = time; c_pid = pid; c_valid = valid} ->
363 Printf.printf "%d(%Ld)%s " pid time
364 (if valid then "" else "(invalid)"))
365 !checkpoints;
366 print_newline ()
367 end
368
369 (*** Miscellaneous functions (exported). ***)
370
371 (* Create a checkpoint at time 0 (new program). *)
372 let new_checkpoint pid fd =
373 let new_checkpoint =
374 {c_time = _0;
375 c_pid = pid;
376 c_fd = fd;
377 c_valid = true;
378 c_report = None;
379 c_state = C_stopped;
380 c_parent = root;
381 c_breakpoint_version = 0;
382 c_breakpoints = [];
383 c_trap_barrier = 0;
384 c_code_fragments = [0]}
385 in
386 insert_checkpoint new_checkpoint
387
388 (* Set the file descriptor of a checkpoint *)
389 (* (a new process has connected with the debugger). *)
390 (* --- Return `true' on success (close the connection otherwise). *)
391 let set_file_descriptor pid fd =
392 let rec find =
393 function
394 [] ->
395 prerr_endline "Unexpected connection";
396 close_io fd;
397 false
398 | ({c_pid = pid'} as checkpoint)::l ->
399 if pid <> pid' then
400 find l
401 else
402 (checkpoint.c_fd <- fd;
403 checkpoint.c_valid <- true;
404 true)
405 in
406 if !debug_time_travel then
407 prerr_endline ("New connection: " ^(Int.to_string pid));
408 find (!current_checkpoint::!checkpoints)
409
410 (* Kill all the checkpoints. *)
411 let kill_all_checkpoints () =
412 List.iter kill_checkpoint (!current_checkpoint::!checkpoints)
413
414 (* Kill a checkpoint without killing the process. *)
415 (* (used when connection with the process is lost). *)
416 (* --- Assume that the checkpoint is valid. *)
417 let forget_process fd pid =
418 let checkpoint =
419 List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints)
420 in
421 if pid > 0 then begin
422 Printf.eprintf "Lost connection with process %d" pid;
423 let kont =
424 if checkpoint == !current_checkpoint then begin
425 Printf.eprintf " (active process)\n";
426 match !current_checkpoint.c_state with
427 C_stopped ->
428 Printf.eprintf "at time %Ld" !current_checkpoint.c_time;
429 fun () -> raise Current_checkpoint_lost
430 | C_running duration ->
431 Printf.eprintf "between time %Ld and time %Ld"
432 !current_checkpoint.c_time
433 (!current_checkpoint.c_time ++ duration);
434 fun () -> raise (Current_checkpoint_lost_start_at
435 (!current_checkpoint.c_time, duration))
436 end
437 else ignore in
438 Printf.eprintf "\n"; flush stderr;
439 Input_handling.remove_file fd;
440 close_io checkpoint.c_fd;
441 remove_file checkpoint.c_fd;
442 remove_checkpoint checkpoint;
443 checkpoint.c_pid <- -1; (* Don't exist anymore *)
444 if checkpoint.c_parent.c_pid > 0 then
445 wait_child checkpoint.c_parent.c_fd;
446 kont ()
447 end
448
449 (* Try to recover when the current checkpoint is lost. *)
450 let recover () =
451 set_current_checkpoint
452 (find_checkpoint_before (current_time ()))
453
454 (*** Simple movements. ***)
455
456 (* Forward stepping. Requires `duration >= 0'. *)
457 let rec step_forward duration =
458 if duration > !checkpoint_small_step then begin
459 let first_step =
460 if duration > !checkpoint_big_step then
461 !checkpoint_big_step
462 else
463 !checkpoint_small_step
464 in
465 internal_step first_step;
466 if not !interrupted then
467 step_forward (duration -- first_step)
468 end
469 else if duration != _0 then
470 internal_step duration
471
472 (* Go to time `time' from current checkpoint (internal). *)
473 let internal_go_to time =
474 let duration = time -- (current_time ()) in
475 if duration > _0 then
476 execute_without_breakpoints (function () -> step_forward duration)
477
478 (* Move to a given time. *)
479 let go_to time =
480 let checkpoint = find_checkpoint_before time in
481 set_current_checkpoint checkpoint;
482 internal_go_to time
483
484 (* Return the time of the last breakpoint *)
485 (* between current time and `max_time'. *)
486 let find_last_breakpoint max_time =
487 let rec find break =
488 let time = current_time () in
489 step_forward (max_time -- time);
490 match !last_breakpoint, !temporary_breakpoint_position with
491 (Some _, _) when current_time () < max_time ->
492 find !last_breakpoint
493 | (Some (pc, _), Some pc') when pc = pc' ->
494 (max_time, !last_breakpoint)
495 | _ ->
496 (time, break)
497 in
498 find
499 (match current_pc_sp () with
500 (Some (pc, _)) as state when breakpoint_at_pc pc -> state
501 | _ -> None)
502
503 (* Run from `time_max' back to `time'. *)
504 (* --- Assume 0 <= time < time_max *)
505 let rec back_to time time_max =
506 let
507 {c_time = t} = find_checkpoint_before (pre64 time_max)
508 in
509 go_to (max time t);
510 let (new_time, break) = find_last_breakpoint time_max in
511 if break <> None || (new_time <= time) then begin
512 go_to new_time;
513 interrupted := break <> None;
514 last_breakpoint := break
515 end else
516 back_to time new_time
517
518 (* Backward stepping. *)
519 (* --- Assume duration > 1 *)
520 let step_backward duration =
521 let time = current_time () in
522 if time > _0 then
523 back_to (max _0 (time -- duration)) time
524
525 (* Run the program from current time. *)
526 (* Stop at the first breakpoint, or at the end of the program. *)
527 let rec run () =
528 internal_step !checkpoint_big_step;
529 if not !interrupted then
530 run ()
531
532 (* Run the program backward from current time. *)
533 (* Stop at the first breakpoint, or at the beginning of the program. *)
534 let back_run () =
535 if current_time () > _0 then
536 back_to _0 (current_time ())
537
538 (* Step in any direction. *)
539 (* Stop at the first breakpoint, or after `duration' steps. *)
540 let step duration =
541 if duration >= _0 then
542 step_forward duration
543 else
544 step_backward (_0 -- duration)
545
546 (*** Next, finish. ***)
547
548 (* Finish current function. *)
549 let finish () =
550 Symbols.update_current_event ();
551 match !current_event with
552 None ->
553 prerr_endline "`finish' not meaningful in outermost frame.";
554 raise Toplevel
555 | Some {ev_ev={ev_stacksize}} ->
556 set_initial_frame();
557 let (frame, pc) = up_frame ev_stacksize in
558 if frame < 0 then begin
559 prerr_endline "`finish' not meaningful in outermost frame.";
560 raise Toplevel
561 end;
562 begin
563 try ignore(Symbols.any_event_at_pc pc)
564 with Not_found ->
565 prerr_endline "Calling function has no debugging information.";
566 raise Toplevel
567 end;
568 exec_with_trap_barrier
569 frame
570 (fun () ->
571 exec_with_temporary_breakpoint
572 pc
573 (fun () ->
574 while
575 run ();
576 match !last_breakpoint with
577 Some (pc', frame') when pc = pc' ->
578 interrupted := false;
579 frame <> frame'
580 | _ ->
581 false
582 do
583 ()
584 done))
585
586 let next_1 () =
587 Symbols.update_current_event ();
588 match !current_event with
589 None -> (* Beginning of the program. *)
590 step _1
591 | Some {ev_ev={ev_stacksize=ev_stacksize1}} ->
592 let (frame1, _pc1) = initial_frame() in
593 step _1;
594 if not !interrupted then begin
595 Symbols.update_current_event ();
596 match !current_event with
597 None -> ()
598 | Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
599 let (frame2, _pc2) = initial_frame() in
600 (* Call `finish' if we've entered a function. *)
601 if frame1 >= 0 && frame2 >= 0 &&
602 frame2 - ev_stacksize2 > frame1 - ev_stacksize1
603 then finish()
604 end
605
606 (* Same as `step' (forward) but skip over function calls. *)
607 let rec next =
608 function
609 0 -> ()
610 | n ->
611 next_1 ();
612 if not !interrupted then
613 next (n - 1)
614
615 (* Run backward until just before current function. *)
616 let start () =
617 Symbols.update_current_event ();
618 match !current_event with
619 None ->
620 prerr_endline "`start not meaningful in outermost frame.";
621 raise Toplevel
622 | Some {ev_ev={ev_stacksize}} ->
623 let (frame, _) = initial_frame() in
624 let (frame', pc) = up_frame ev_stacksize in
625 if frame' < 0 then begin
626 prerr_endline "`start not meaningful in outermost frame.";
627 raise Toplevel
628 end;
629 let nargs =
630 match
631 try Symbols.any_event_at_pc pc with Not_found ->
632 prerr_endline "Calling function has no debugging information.";
633 raise Toplevel
634 with
635 {ev_ev = {ev_info = Event_return nargs}} -> nargs
636 | _ -> Misc.fatal_error "Time_travel.start"
637 in
638 let offset = if nargs < 4 then 1 else 2 in
639 let pc = { pc with pos = pc.pos - 4 * offset } in
640 while
641 exec_with_temporary_breakpoint pc back_run;
642 match !last_breakpoint with
643 Some (pc', frame') when pc = pc' ->
644 step _minus1;
645 (not !interrupted)
646 &&
647 (frame' - nargs > frame - ev_stacksize)
648 | _ ->
649 false
650 do
651 ()
652 done
653
654 let previous_1 () =
655 Symbols.update_current_event ();
656 match !current_event with
657 None -> (* End of the program. *)
658 step _minus1
659 | Some {ev_ev={ev_stacksize=ev_stacksize1}} ->
660 let (frame1, _pc1) = initial_frame() in
661 step _minus1;
662 if not !interrupted then begin
663 Symbols.update_current_event ();
664 match !current_event with
665 None -> ()
666 | Some {ev_ev={ev_stacksize=ev_stacksize2}} ->
667 let (frame2, _pc2) = initial_frame() in
668 (* Call `start' if we've entered a function. *)
669 if frame1 >= 0 && frame2 >= 0 &&
670 frame2 - ev_stacksize2 > frame1 - ev_stacksize1
671 then start()
672 end
673
674 (* Same as `step' (backward) but skip over function calls. *)
675 let rec previous =
676 function
677 0 -> ()
678 | n ->
679 previous_1 ();
680 if not !interrupted then
681 previous (n - 1)
682