diff options
Diffstat (limited to 'debugger')
63 files changed, 0 insertions, 6791 deletions
diff --git a/debugger/.cvsignore b/debugger/.cvsignore deleted file mode 100644 index b608cf5532..0000000000 --- a/debugger/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -lexer.ml -parser.ml -parser.mli -ocamldebug diff --git a/debugger/.depend b/debugger/.depend deleted file mode 100644 index 3a303e336d..0000000000 --- a/debugger/.depend +++ /dev/null @@ -1,189 +0,0 @@ -breakpoints.cmi: ../bytecomp/instruct.cmi primitives.cmi -checkpoints.cmi: debugcom.cmi primitives.cmi -debugcom.cmi: primitives.cmi -envaux.cmi: ../typing/env.cmi ../bytecomp/instruct.cmi ../typing/path.cmi -eval.cmi: debugcom.cmi ../typing/env.cmi ../typing/ident.cmi \ - ../bytecomp/instruct.cmi ../parsing/longident.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/types.cmi -events.cmi: ../bytecomp/instruct.cmi -frames.cmi: ../bytecomp/instruct.cmi primitives.cmi -input_handling.cmi: primitives.cmi -loadprinter.cmi: ../otherlibs/dynlink/dynlink.cmi ../parsing/longident.cmi -parser.cmi: ../parsing/longident.cmi parser_aux.cmi -parser_aux.cmi: ../parsing/longident.cmi primitives.cmi -pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi -pos.cmi: ../bytecomp/instruct.cmi -primitives.cmi: ../otherlibs/unix/unix.cmi -printval.cmi: debugcom.cmi ../typing/env.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/types.cmi -program_loading.cmi: primitives.cmi -show_information.cmi: ../bytecomp/instruct.cmi -symbols.cmi: ../bytecomp/instruct.cmi -time_travel.cmi: primitives.cmi -unix_tools.cmi: ../otherlibs/unix/unix.cmi -breakpoints.cmo: checkpoints.cmi debugcom.cmi exec.cmi \ - ../bytecomp/instruct.cmi pos.cmi primitives.cmi source.cmi symbols.cmi \ - breakpoints.cmi -breakpoints.cmx: checkpoints.cmx debugcom.cmx exec.cmx \ - ../bytecomp/instruct.cmx pos.cmx primitives.cmx source.cmx symbols.cmx \ - breakpoints.cmi -checkpoints.cmo: debugcom.cmi int64ops.cmi primitives.cmi checkpoints.cmi -checkpoints.cmx: debugcom.cmx int64ops.cmx primitives.cmx checkpoints.cmi -command_line.cmo: breakpoints.cmi checkpoints.cmi ../utils/config.cmi \ - ../typing/ctype.cmi debugcom.cmi debugger_config.cmi envaux.cmi eval.cmi \ - events.cmi frames.cmi history.cmi input_handling.cmi \ - ../bytecomp/instruct.cmi int64ops.cmi ../parsing/lexer.cmi \ - loadprinter.cmi ../utils/misc.cmi parameters.cmi parser.cmi \ - parser_aux.cmi pos.cmi primitives.cmi printval.cmi program_loading.cmi \ - program_management.cmi show_information.cmi show_source.cmi source.cmi \ - symbols.cmi time_travel.cmi ../typing/types.cmi \ - ../otherlibs/unix/unix.cmi unix_tools.cmi command_line.cmi -command_line.cmx: breakpoints.cmx checkpoints.cmx ../utils/config.cmx \ - ../typing/ctype.cmx debugcom.cmx debugger_config.cmx envaux.cmx eval.cmx \ - events.cmx frames.cmx history.cmx input_handling.cmx \ - ../bytecomp/instruct.cmx int64ops.cmx ../parsing/lexer.cmx \ - loadprinter.cmx ../utils/misc.cmx parameters.cmx parser.cmx \ - parser_aux.cmi pos.cmx primitives.cmx printval.cmx program_loading.cmx \ - program_management.cmx show_information.cmx show_source.cmx source.cmx \ - symbols.cmx time_travel.cmx ../typing/types.cmx \ - ../otherlibs/unix/unix.cmx unix_tools.cmx command_line.cmi -debugcom.cmo: input_handling.cmi int64ops.cmi ../utils/misc.cmi \ - primitives.cmi debugcom.cmi -debugcom.cmx: input_handling.cmx int64ops.cmx ../utils/misc.cmx \ - primitives.cmx debugcom.cmi -debugger_config.cmo: int64ops.cmi debugger_config.cmi -debugger_config.cmx: int64ops.cmx debugger_config.cmi -envaux.cmo: ../typing/env.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi \ - ../typing/mtype.cmi ../typing/path.cmi ../typing/printtyp.cmi \ - ../typing/types.cmi envaux.cmi -envaux.cmx: ../typing/env.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx \ - ../typing/mtype.cmx ../typing/path.cmx ../typing/printtyp.cmx \ - ../typing/types.cmx envaux.cmi -eval.cmo: ../typing/btype.cmi ../typing/ctype.cmi debugcom.cmi \ - debugger_config.cmi ../typing/env.cmi frames.cmi ../typing/ident.cmi \ - ../bytecomp/instruct.cmi ../parsing/longident.cmi ../utils/misc.cmi \ - parser_aux.cmi ../typing/path.cmi ../typing/predef.cmi \ - ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi eval.cmi -eval.cmx: ../typing/btype.cmx ../typing/ctype.cmx debugcom.cmx \ - debugger_config.cmx ../typing/env.cmx frames.cmx ../typing/ident.cmx \ - ../bytecomp/instruct.cmx ../parsing/longident.cmx ../utils/misc.cmx \ - parser_aux.cmi ../typing/path.cmx ../typing/predef.cmx \ - ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx eval.cmi -events.cmo: checkpoints.cmi ../bytecomp/instruct.cmi primitives.cmi \ - symbols.cmi events.cmi -events.cmx: checkpoints.cmx ../bytecomp/instruct.cmx primitives.cmx \ - symbols.cmx events.cmi -exec.cmo: exec.cmi -exec.cmx: exec.cmi -frames.cmo: checkpoints.cmi debugcom.cmi events.cmi ../bytecomp/instruct.cmi \ - ../utils/misc.cmi primitives.cmi symbols.cmi frames.cmi -frames.cmx: checkpoints.cmx debugcom.cmx events.cmx ../bytecomp/instruct.cmx \ - ../utils/misc.cmx primitives.cmx symbols.cmx frames.cmi -history.cmo: checkpoints.cmi debugger_config.cmi int64ops.cmi \ - ../utils/misc.cmi primitives.cmi history.cmi -history.cmx: checkpoints.cmx debugger_config.cmx int64ops.cmx \ - ../utils/misc.cmx primitives.cmx history.cmi -input_handling.cmo: ../parsing/lexer.cmi primitives.cmi \ - ../otherlibs/unix/unix.cmi input_handling.cmi -input_handling.cmx: ../parsing/lexer.cmx primitives.cmx \ - ../otherlibs/unix/unix.cmx input_handling.cmi -int64ops.cmo: int64ops.cmi -int64ops.cmx: int64ops.cmi -lexer.cmo: parser.cmi primitives.cmi -lexer.cmx: parser.cmx primitives.cmx -loadprinter.cmo: ../utils/config.cmi ../typing/ctype.cmi debugger_config.cmi \ - ../otherlibs/dynlink/dynlink.cmi ../typing/env.cmi ../typing/ident.cmi \ - ../parsing/longident.cmi ../utils/misc.cmi ../typing/path.cmi \ - ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi loadprinter.cmi -loadprinter.cmx: ../utils/config.cmx ../typing/ctype.cmx debugger_config.cmx \ - ../otherlibs/dynlink/dynlink.cmx ../typing/env.cmx ../typing/ident.cmx \ - ../parsing/longident.cmx ../utils/misc.cmx ../typing/path.cmx \ - ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx loadprinter.cmi -main.cmo: checkpoints.cmi command_line.cmi ../utils/config.cmi \ - debugger_config.cmi exec.cmi frames.cmi input_handling.cmi \ - ../utils/misc.cmi parameters.cmi primitives.cmi program_management.cmi \ - show_information.cmi time_travel.cmi ../otherlibs/unix/unix.cmi \ - unix_tools.cmi -main.cmx: checkpoints.cmx command_line.cmx ../utils/config.cmx \ - debugger_config.cmx exec.cmx frames.cmx input_handling.cmx \ - ../utils/misc.cmx parameters.cmx primitives.cmx program_management.cmx \ - show_information.cmx time_travel.cmx ../otherlibs/unix/unix.cmx \ - unix_tools.cmx -parameters.cmo: ../utils/config.cmi envaux.cmi ../utils/misc.cmi \ - primitives.cmi parameters.cmi -parameters.cmx: ../utils/config.cmx envaux.cmx ../utils/misc.cmx \ - primitives.cmx parameters.cmi -parser.cmo: input_handling.cmi int64ops.cmi ../parsing/longident.cmi \ - parser_aux.cmi primitives.cmi parser.cmi -parser.cmx: input_handling.cmx int64ops.cmx ../parsing/longident.cmx \ - parser_aux.cmi primitives.cmx parser.cmi -pattern_matching.cmo: ../typing/ctype.cmi debugcom.cmi debugger_config.cmi \ - ../utils/misc.cmi parser_aux.cmi ../typing/typedtree.cmi \ - pattern_matching.cmi -pattern_matching.cmx: ../typing/ctype.cmx debugcom.cmx debugger_config.cmx \ - ../utils/misc.cmx parser_aux.cmi ../typing/typedtree.cmx \ - pattern_matching.cmi -pos.cmo: ../bytecomp/instruct.cmi primitives.cmi source.cmi pos.cmi -pos.cmx: ../bytecomp/instruct.cmx primitives.cmx source.cmx pos.cmi -primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi -primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi -printval.cmo: debugcom.cmi ../toplevel/genprintval.cmi ../utils/misc.cmi \ - ../typing/oprint.cmi ../typing/outcometree.cmi parser_aux.cmi \ - ../typing/path.cmi ../typing/printtyp.cmi ../bytecomp/symtable.cmi \ - ../typing/types.cmi printval.cmi -printval.cmx: debugcom.cmx ../toplevel/genprintval.cmx ../utils/misc.cmx \ - ../typing/oprint.cmx ../typing/outcometree.cmi parser_aux.cmi \ - ../typing/path.cmx ../typing/printtyp.cmx ../bytecomp/symtable.cmx \ - ../typing/types.cmx printval.cmi -program_loading.cmo: debugger_config.cmi input_handling.cmi ../utils/misc.cmi \ - parameters.cmi primitives.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \ - program_loading.cmi -program_loading.cmx: debugger_config.cmx input_handling.cmx ../utils/misc.cmx \ - parameters.cmx primitives.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \ - program_loading.cmi -program_management.cmo: breakpoints.cmi debugcom.cmi debugger_config.cmi \ - history.cmi input_handling.cmi ../bytecomp/instruct.cmi int64ops.cmi \ - ../utils/misc.cmi parameters.cmi primitives.cmi program_loading.cmi \ - symbols.cmi time_travel.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \ - program_management.cmi -program_management.cmx: breakpoints.cmx debugcom.cmx debugger_config.cmx \ - history.cmx input_handling.cmx ../bytecomp/instruct.cmx int64ops.cmx \ - ../utils/misc.cmx parameters.cmx primitives.cmx program_loading.cmx \ - symbols.cmx time_travel.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \ - program_management.cmi -show_information.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi events.cmi \ - frames.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi primitives.cmi \ - printval.cmi show_source.cmi symbols.cmi show_information.cmi -show_information.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx events.cmx \ - frames.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx primitives.cmx \ - printval.cmx show_source.cmx symbols.cmx show_information.cmi -show_source.cmo: debugger_config.cmi ../utils/misc.cmi parameters.cmi \ - primitives.cmi source.cmi show_source.cmi -show_source.cmx: debugger_config.cmx ../utils/misc.cmx parameters.cmx \ - primitives.cmx source.cmx show_source.cmi -source.cmo: ../utils/config.cmi ../utils/misc.cmi primitives.cmi source.cmi -source.cmx: ../utils/config.cmx ../utils/misc.cmx primitives.cmx source.cmi -symbols.cmo: ../bytecomp/bytesections.cmi debugcom.cmi debugger_config.cmi \ - ../bytecomp/instruct.cmi primitives.cmi ../bytecomp/symtable.cmi \ - symbols.cmi -symbols.cmx: ../bytecomp/bytesections.cmx debugcom.cmx debugger_config.cmx \ - ../bytecomp/instruct.cmx primitives.cmx ../bytecomp/symtable.cmx \ - symbols.cmi -time_travel.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi \ - debugger_config.cmi events.cmi exec.cmi input_handling.cmi \ - ../bytecomp/instruct.cmi int64ops.cmi ../utils/misc.cmi primitives.cmi \ - program_loading.cmi symbols.cmi trap_barrier.cmi time_travel.cmi -time_travel.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx \ - debugger_config.cmx events.cmx exec.cmx input_handling.cmx \ - ../bytecomp/instruct.cmx int64ops.cmx ../utils/misc.cmx primitives.cmx \ - program_loading.cmx symbols.cmx trap_barrier.cmx time_travel.cmi -trap_barrier.cmo: checkpoints.cmi debugcom.cmi exec.cmi trap_barrier.cmi -trap_barrier.cmx: checkpoints.cmx debugcom.cmx exec.cmx trap_barrier.cmi -unix_tools.cmo: ../utils/misc.cmi primitives.cmi ../otherlibs/unix/unix.cmi \ - unix_tools.cmi -unix_tools.cmx: ../utils/misc.cmx primitives.cmx ../otherlibs/unix/unix.cmx \ - unix_tools.cmi diff --git a/debugger/Makefile b/debugger/Makefile deleted file mode 100644 index 674fda9c7a..0000000000 --- a/debugger/Makefile +++ /dev/null @@ -1,114 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id$ - -include ../config/Makefile - -CAMLC=../ocamlcomp.sh -COMPFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=-linkall -I ../otherlibs/unix -CAMLYACC=../boot/ocamlyacc -YACCFLAGS= -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep -DEPFLAGS=$(INCLUDES) - -INCLUDES=\ - -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ - -I ../otherlibs/unix -I ../otherlibs/dynlink - -OTHEROBJS=\ - ../otherlibs/unix/unix.cma \ - ../utils/misc.cmo ../utils/config.cmo \ - ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ - ../parsing/longident.cmo \ - ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ - ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ - ../typing/subst.cmo ../typing/predef.cmo \ - ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \ - ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ - ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ - ../bytecomp/dll.cmo ../bytecomp/symtable.cmo \ - ../bytecomp/opcodes.cmo ../bytecomp/meta.cmo \ - ../toplevel/genprintval.cmo \ - ../otherlibs/dynlink/dynlink.cmo - -OBJS=\ - int64ops.cmo \ - primitives.cmo \ - unix_tools.cmo \ - debugger_config.cmo \ - envaux.cmo \ - parameters.cmo \ - lexer.cmo \ - input_handling.cmo \ - debugcom.cmo \ - exec.cmo \ - source.cmo \ - pos.cmo \ - checkpoints.cmo \ - symbols.cmo \ - events.cmo \ - breakpoints.cmo \ - trap_barrier.cmo \ - history.cmo \ - program_loading.cmo \ - printval.cmo \ - show_source.cmo \ - time_travel.cmo \ - program_management.cmo \ - frames.cmo \ - eval.cmo \ - show_information.cmo \ - loadprinter.cmo \ - parser.cmo \ - command_line.cmo \ - main.cmo - -all: ocamldebug$(EXE) - -ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) - $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) - -install: - cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) - -clean:: - rm -f ocamldebug$(EXE) - rm -f *.cmo *.cmi - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll -clean:: - rm -f lexer.ml -beforedepend:: lexer.ml - -parser.ml parser.mli: parser.mly - $(CAMLYACC) parser.mly -clean:: - rm -f parser.ml parser.mli -beforedepend:: parser.ml parser.mli - -include .depend diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml deleted file mode 100644 index 09695d87ba..0000000000 --- a/debugger/breakpoints.ml +++ /dev/null @@ -1,222 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(******************************* Breakpoints ***************************) - -open Checkpoints -open Debugcom -open Instruct -open Primitives -open Printf -open Source - -(*** Debugging. ***) -let debug_breakpoints = ref false - -(*** Data. ***) - -(* Number of the last added breakpoint. *) -let breakpoint_number = ref 0 - -(* Breakpoint number -> event. *) -let breakpoints = ref ([] : (int * debug_event) list) - -(* Program counter -> breakpoint count. *) -let positions = ref ([] : (int * int ref) list) - -(* Versions of the breakpoint list. *) -let current_version = ref 0 -let max_version = ref 0 - -(*** Miscellaneous. ***) - -(* Mark breakpoints as installed in current checkpoint. *) -let copy_breakpoints () = - !current_checkpoint.c_breakpoints <- !positions; - !current_checkpoint.c_breakpoint_version <- !current_version - -(* Announce a new version of the breakpoint list. *) -let new_version () = - incr max_version; - current_version := !max_version - -(*** Information about breakpoints. ***) - -let breakpoints_count () = - List.length !breakpoints - -(* 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 -> - [] - end - @ - List.map fst (filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) - -(* Is there a breakpoint at `pc' ? *) -let breakpoint_at_pc pc = - breakpoints_at_pc pc <> [] - -(*** Set and remove breakpoints ***) - -(* Remove all breakpoints. *) -let remove_breakpoints pos = - if !debug_breakpoints then - (print_string "Removing breakpoints..."; print_newline ()); - 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 - -(* Set all breakpoints. *) -let set_breakpoints pos = - if !debug_breakpoints then - (print_string "Setting breakpoints..."; print_newline ()); - List.iter - (function (pos, _) -> - if !debug_breakpoints then begin - print_int pos; - print_newline() - end; - set_breakpoint pos) - pos - -(* Ensure the current version in installed in current checkpoint. *) -let update_breakpoints () = - if !debug_breakpoints then begin - prerr_string "Updating breakpoints... "; - prerr_int !current_checkpoint.c_breakpoint_version; - prerr_string " "; - prerr_int !current_version; - prerr_endline "" - end; - if !current_checkpoint.c_breakpoint_version <> !current_version then - Exec.protect - (function () -> - remove_breakpoints !current_checkpoint.c_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 - x -> - change_version version pos - -(* Add a position in the position list. *) -(* Change version if necessary. *) -let insert_position pos = - try - incr (List.assoc pos !positions) - with - Not_found -> - positions := (pos, ref 1) :: !positions; - new_version () - -(* Remove a position in the position list. *) -(* Change version if necessary. *) -let remove_position pos = - let count = List.assoc pos !positions in - decr count; - if !count = 0 then begin - positions := assoc_remove !positions pos; - new_version () - 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); - printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos - (Pos.get_desc event); - print_newline () - -(* Remove a breakpoint from lists. *) -let remove_breakpoint number = - try - let pos = (List.assoc number !breakpoints).ev_pos in - Exec.protect - (function () -> - breakpoints := assoc_remove !breakpoints number; - remove_position pos) - with - Not_found -> - prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ "."); - raise Not_found - -let remove_all_breakpoints () = - List.iter (function (number, _) -> remove_breakpoint number) !breakpoints - -(*** Temporary breakpoints. ***) - -(* Temporary breakpoint position. *) -let temporary_breakpoint_position = ref (None : int option) - -(* Execute `funct' with a breakpoint added at `pc'. *) -(* --- Used by `finish'. *) -let exec_with_temporary_breakpoint pc funct = - let previous_version = !current_version in - let remove () = - temporary_breakpoint_position := None; - current_version := previous_version; - let count = List.assoc pc !positions in - decr count; - if !count = 0 then begin - positions := assoc_remove !positions pc; - reset_instr pc; - Symbols.set_event_at_pc pc - end - - in - Exec.protect (function () -> insert_position pc); - temporary_breakpoint_position := Some pc; - try - funct (); - Exec.protect remove - with - x -> - Exec.protect remove; - raise x diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli deleted file mode 100644 index 091f609981..0000000000 --- a/debugger/breakpoints.mli +++ /dev/null @@ -1,61 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(******************************* Breakpoints ***************************) - -open Primitives -open Instruct - -(*** Debugging. ***) -val debug_breakpoints : bool ref - -(*** Information about breakpoints. ***) - -val breakpoints_count : unit -> int - -(* Breakpoint number -> debug_event_kind. *) -val breakpoints : (int * debug_event) list ref - -(* Is there a breakpoint at `pc' ? *) -val breakpoint_at_pc : int -> bool - -(* List of breakpoints at `pc'. *) -val breakpoints_at_pc : int -> int list - -(*** Set and remove breakpoints ***) - -(* Ensure the current version in installed in current checkpoint. *) -val update_breakpoints : unit -> unit - -(* Execute given function with no breakpoint in current checkpoint. *) -(* --- `goto' run faster so (does not stop on each breakpoint). *) -val execute_without_breakpoints : (unit -> unit) -> unit - -(* Insert a new breakpoint in lists. *) -val new_breakpoint : debug_event -> unit - -(* Remove a breakpoint from lists. *) -val remove_breakpoint : int -> unit - -val remove_all_breakpoints : unit -> unit - -(*** Temporary breakpoints. ***) - -(* Temporary breakpoint position. *) -val temporary_breakpoint_position : int option ref - -(* Execute `funct' with a breakpoint added at `pc'. *) -(* --- Used by `finish'. *) -val exec_with_temporary_breakpoint : int -> (unit -> unit) -> unit diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml deleted file mode 100644 index ffcff35e36..0000000000 --- a/debugger/checkpoints.ml +++ /dev/null @@ -1,85 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*************************** Checkpoints *******************************) - -open Int64ops -open Debugcom -open Primitives - -(*** A type for checkpoints. ***) - -type checkpoint_state = - C_stopped - | C_running of int64 - -(* `c_valid' is true if and only if the corresponding - * process is connected to the debugger. - * `c_parent' is the checkpoint whose process is parent - * of the checkpoint one (`root' if no parent). - * c_pid = -2 for root pseudo-checkpoint. - * c_pid = 0 for ghost checkpoints. - * c_pid = -1 for kill checkpoints. - *) -type checkpoint = { - mutable c_time : int64; - mutable c_pid : int; - mutable c_fd : io_channel; - mutable c_valid : bool; - mutable c_report : report option; - 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 - } - -(*** Pseudo-checkpoint `root'. ***) -(* --- Parents of all checkpoints which have no parent. *) -let rec root = { - c_time = _0; - c_pid = -2; - c_fd = std_io; - c_valid = false; - c_report = None; - c_state = C_stopped; - c_parent = root; - c_breakpoint_version = 0; - c_breakpoints = []; - c_trap_barrier = 0 - } - -(*** Current state ***) -let checkpoints = - ref ([] : checkpoint list) - -let current_checkpoint = - ref root - -let current_time () = - !current_checkpoint.c_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 () = - match current_report () with - None | Some {rep_type = Exited | Uncaught_exc} -> None - | Some {rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp) diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli deleted file mode 100644 index 17c1037aa2..0000000000 --- a/debugger/checkpoints.mli +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Checkpoints *****************************) - -open Primitives -open Debugcom - -(*** A type for checkpoints. ***) - -type checkpoint_state = - C_stopped - | C_running of int64 - -(* `c_valid' is true if and only if the corresponding - * process is connected to the debugger. - * `c_parent' is the checkpoint whose process is parent - * of the checkpoint one (`root' if no parent). - * c_pid = 2 for root pseudo-checkpoint. - * c_pid = 0 for ghost checkpoints. - * c_pid = -1 for kill checkpoints. - *) -type checkpoint = - {mutable c_time : int64; - mutable c_pid : int; - mutable c_fd : io_channel; - mutable c_valid : bool; - mutable c_report : report option; - 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} - -(*** Pseudo-checkpoint `root'. ***) -(* --- Parents of all checkpoints which have no parent. *) -val root : checkpoint - -(*** Current state ***) -val checkpoints : checkpoint list ref -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 diff --git a/debugger/command_line.ml b/debugger/command_line.ml deleted file mode 100644 index 7651b53f32..0000000000 --- a/debugger/command_line.ml +++ /dev/null @@ -1,1084 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Reading and executing commands ***************) - -open Int64ops -open Format -open Misc -open Instruct -open Unix -open Debugger_config -open Types -open Primitives -open Unix_tools -open Parser -open Parser_aux -open Lexer -open Input_handling -open Debugcom -open Program_loading -open Program_management -open Lexing -open Parameters -open Show_source -open Show_information -open Time_travel -open Events -open Symbols -open Source -open Breakpoints -open Checkpoints -open Frames -open Printval - -(** Instructions, variables and infos lists. **) -type dbg_instruction = - { instr_name: string; (* Name of command *) - instr_prio: bool; (* Has priority *) - instr_action: formatter -> lexbuf -> unit; - (* What to do *) - instr_repeat: bool; (* Can be repeated *) - instr_help: string } (* Help message *) - -let instruction_list = ref ([] : dbg_instruction list) - -type dbg_variable = - { var_name: string; (* Name of variable *) - var_action: (lexbuf -> unit) * (formatter -> unit); - (* Reading, writing fns *) - var_help: string } (* Help message *) - -let variable_list = ref ([] : dbg_variable list) - -type dbg_info = - { info_name: string; (* Name of info *) - info_action: lexbuf -> unit; (* What to do *) - info_help: string } (* Help message *) - -let info_list = ref ([] : dbg_info list) - -(** Utilities. **) -let error text = - eprintf "%s@." text; - raise Toplevel - -let eol = - end_of_line Lexer.lexeme - -let matching_elements list name instr = - filter (function a -> isprefix instr (name a)) !list - -let all_matching_instructions = - matching_elements instruction_list (fun i -> i.instr_name) - -(* itz 04-21-96 don't do priority completion in emacs mode *) -(* XL 25-02-97 why? I find it very confusing. *) - -let matching_instructions instr = - let all = all_matching_instructions instr in - let prio = filter (fun i -> i.instr_prio) all in - if prio = [] then all else prio - -let matching_variables = - matching_elements variable_list (fun v -> v.var_name) - -let matching_infos = - matching_elements info_list (fun i -> i.info_name) - -let find_ident name matcher action alternative ppf lexbuf = - match identifier_or_eol Lexer.lexeme lexbuf with - | None -> alternative ppf - | Some ident -> - match matcher ident with - | [] -> error ("Unknown " ^ name ^ ".") - | [a] -> action a ppf lexbuf - | _ -> error ("Ambiguous " ^ name ^ ".") - -let find_variable action alternative ppf lexbuf = - find_ident "variable name" matching_variables action alternative ppf lexbuf - -let find_info action alternative ppf lexbuf = - find_ident "info command" matching_infos action alternative ppf lexbuf - -let add_breakpoint_at_pc pc = - try - new_breakpoint (any_event_at_pc pc) - with - | Not_found -> - eprintf "Can't add breakpoint at pc %i : no event there.@." pc; - 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)) - with - | Not_found -> - try_add (n+1) - end else begin - error - "Can't add breakpoint at beginning of function: no event there" - end - in try_add 0 - -let convert_module mdle = - match mdle with - | Some m -> - (* Strip .ml extension if any, and capitalize *) - String.capitalize(if Filename.check_suffix m ".ml" - then Filename.chop_suffix m ".ml" - else m) - | None -> - try - let (x, _) = current_point () in x - with - | Not_found -> - error "Not in a module." - -(** Toplevel. **) -let current_line = ref "" - -let interprete_line ppf line = - current_line := line; - let lexbuf = Lexing.from_string line in - try - match identifier_or_eol Lexer.lexeme lexbuf with - | Some x -> - begin match matching_instructions x with - | [] -> - error "Unknown command." - | [i] -> - i.instr_action ppf lexbuf; - resume_user_input (); - i.instr_repeat - | l -> - error "Ambiguous command." - end - | None -> - resume_user_input (); - false - with - | Parsing.Parse_error -> - error "Syntax error." - -let line_loop ppf line_buffer = - resume_user_input (); - let previous_line = ref "" in - try - while true do - if !loaded then - History.add_current_time (); - let new_line = string_trim (line line_buffer) in - let line = - if new_line <> "" then - new_line - else - !previous_line - in - previous_line := ""; - if interprete_line ppf line then - previous_line := line - done - with - | Exit -> - stop_user_input () - | Sys_error s -> - error ("System error : " ^ s) - -(** Instructions. **) -let instr_cd ppf lexbuf = - let dir = argument_eol argument lexbuf in - if ask_kill_program () then - try - Sys.chdir (expand_path dir) - with - | Sys_error s -> - error s - -let instr_shell ppf lexbuf = - let cmdarg = argument_list_eol argument lexbuf in - let cmd = String.concat " " cmdarg in - (* perhaps we should use $SHELL -c ? *) - let err = Sys.command cmd in - if (err != 0) then - eprintf "Shell command %S failed with exit code %d\n%!" cmd err - -let instr_pwd ppf lexbuf = - eol lexbuf; - ignore(system "/bin/pwd") - -let instr_dir ppf lexbuf = - let new_directory = argument_list_eol argument lexbuf in - if new_directory = [] then begin - if yes_or_no "Reinitialize directory list" then begin - Config.load_path := !default_load_path; - Envaux.reset_cache (); - flush_buffer_list () - end - end - else - List.iter (function x -> add_path (expand_path x)) - (List.rev new_directory); - let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in - fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path - -let instr_kill ppf lexbuf = - eol lexbuf; - if not !loaded then error "The program is not being run."; - if (yes_or_no "Kill the program being debugged") then begin - kill_program (); - show_no_point() - end - -let instr_run ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values (); - run (); - show_current_event ppf;; - -let instr_reverse ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - back_run (); - show_current_event ppf - -let instr_step ppf lexbuf = - let step_count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - step step_count; - show_current_event ppf - -let instr_back ppf lexbuf = - let step_count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - step (_0 -- step_count); - show_current_event ppf - -let instr_finish ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - finish (); - show_current_event ppf - -let instr_next ppf lexbuf = - let step_count = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - next step_count; - show_current_event ppf - -let instr_start ppf lexbuf = - eol lexbuf; - ensure_loaded (); - reset_named_values(); - start (); - show_current_event ppf - -let instr_previous ppf lexbuf = - let step_count = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - reset_named_values(); - previous step_count; - show_current_event ppf - -let instr_goto ppf lexbuf = - let time = int64_eol Lexer.lexeme lexbuf in - ensure_loaded (); - reset_named_values(); - go_to time; - show_current_event ppf - -let instr_quit _ = - raise Exit - -let print_variable_list ppf = - let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in - fprintf ppf "List of variables :%a@." pr_vars !variable_list - -let print_info_list ppf = - let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in - fprintf ppf "List of info commands :%a@." pr_infos !info_list - -let instr_complete ppf lexbuf = - let ppf = Format.err_formatter in - let rec print_list l = - try - eol lexbuf; - List.iter (function i -> fprintf ppf "%s@." i) l - with _ -> - remove_file !user_channel - and match_list lexbuf = - match identifier_or_eol Lexer.lexeme lexbuf with - | None -> - List.map (fun i -> i.instr_name) !instruction_list - | Some x -> - match matching_instructions x with - | [ {instr_name = ("set" | "show" as i_full)} ] -> - if x = i_full then begin - match identifier_or_eol Lexer.lexeme lexbuf with - | Some ident -> - begin match matching_variables ident with - | [v] -> if v.var_name = ident then [] else [v.var_name] - | l -> List.map (fun v -> v.var_name) l - end - | None -> - List.map (fun v -> v.var_name) !variable_list - end - else [i_full] - | [ {instr_name = "info"} ] -> - if x = "info" then begin - match identifier_or_eol Lexer.lexeme lexbuf with - | Some ident -> - begin match matching_infos ident with - | [i] -> if i.info_name = ident then [] else [i.info_name] - | l -> List.map (fun i -> i.info_name) l - end - | None -> - List.map (fun i -> i.info_name) !info_list - end - else ["info"] - | [ {instr_name = "help"} ] -> - if x = "help" then match_list lexbuf else ["help"] - | [ i ] -> - if x = i.instr_name then [] else [i.instr_name] - | l -> - List.map (fun i -> i.instr_name) l - in - print_list(match_list lexbuf) - -let instr_help ppf lexbuf = - let pr_instrs ppf = - List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in - match identifier_or_eol Lexer.lexeme lexbuf with - | Some x -> - let print_help nm hlp = - eol lexbuf; - fprintf ppf "%s : %s@." nm hlp in - begin match matching_instructions x with - | [] -> - eol lexbuf; - fprintf ppf "No matching command.@." - | [ {instr_name = "set"} ] -> - find_variable - (fun v _ _ -> - print_help ("set " ^ v.var_name) ("set " ^ v.var_help)) - (fun ppf -> - print_help "set" "set debugger variable."; - print_variable_list ppf) - ppf - lexbuf - | [ {instr_name = "show"} ] -> - find_variable - (fun v _ _ -> - print_help ("show " ^ v.var_name) ("show " ^ v.var_help)) - (fun v -> - print_help "show" "display debugger variable."; - print_variable_list ppf) - ppf - lexbuf - | [ {instr_name = "info"} ] -> - find_info - (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help) - (fun ppf -> - print_help "info" - "display infos about the program being debugged."; - print_info_list ppf) - ppf - lexbuf - | [i] -> - print_help i.instr_name i.instr_help - | l -> - eol lexbuf; - fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l - end - | None -> - fprintf ppf "List of commands :%a@." pr_instrs !instruction_list - -(* Printing values *) - -let print_expr depth ev env ppf expr = - try - let (v, ty) = Eval.expression ev env expr in - print_named_value depth expr env v ppf ty - with - | Eval.Error msg -> - Eval.report_error ppf msg; - raise Toplevel - -let print_command depth ppf lexbuf = - let exprs = expression_list_eol Lexer.lexeme lexbuf in - ensure_loaded (); - let env = - try - Envaux.env_of_event !selected_event - with - | Envaux.Error msg -> - Envaux.report_error ppf msg; - raise Toplevel - in - List.iter (print_expr depth !selected_event env ppf) exprs - -let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf - -let instr_display ppf lexbuf = print_command 1 ppf lexbuf - -(* Loading of command files *) - -let extract_filename arg = - (* Allow enclosing filename in quotes *) - let l = String.length arg in - let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in - let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in - String.sub arg pos1 (pos2 - pos1) - -let instr_source ppf lexbuf = - let file = extract_filename(argument_eol argument lexbuf) - and old_state = !interactif - and old_channel = !user_channel in - let io_chan = - try - io_channel_of_descr - (openfile (find_in_path !Config.load_path (expand_path file)) - [O_RDONLY] 0) - with - | Not_found -> error "Source file not found." - | (Unix_error _) as x -> Unix_tools.report_error x; raise Toplevel - in - try - interactif := false; - user_channel := io_chan; - line_loop ppf (Lexing.from_function read_user_input); - close_io io_chan; - interactif := old_state; - user_channel := old_channel - with - | x -> - stop_user_input (); - close_io io_chan; - interactif := old_state; - user_channel := old_channel; - raise x - -let instr_set = - find_variable - (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf) - (function ppf -> error "Argument required.") - -let instr_show = - find_variable - (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf) - (function ppf -> - List.iter - (function {var_name = nm; var_action = (_, funct)} -> - fprintf ppf "%s : " nm; - funct ppf) - !variable_list) - -let instr_info = - find_info - (fun i ppf lexbuf -> i.info_action lexbuf) - (function ppf -> - error "\"info\" must be followed by the name of an info command.") - -let instr_break ppf lexbuf = - let argument = break_argument_eol Lexer.lexeme lexbuf in - ensure_loaded (); - match argument with - | BA_none -> (* break *) - (match !selected_event with - | Some ev -> - new_breakpoint ev - | None -> - error "Can't add breakpoint at this point.") - | BA_pc pc -> (* break PC *) - add_breakpoint_at_pc pc - | BA_function expr -> (* break FUNCTION *) - let env = - try - Envaux.env_of_event !selected_event - with - | Envaux.Error msg -> - Envaux.report_error ppf msg; - raise Toplevel - in - begin try - let (v, ty) = Eval.expression !selected_event env expr in - match (Ctype.repr ty).desc with - | Tarrow _ -> - add_breakpoint_after_pc (Remote_value.closure_code v) - | _ -> - eprintf "Not a function.@."; - raise Toplevel - with - | Eval.Error msg -> - Eval.report_error ppf msg; - raise Toplevel - end - | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *) - let module_name = convert_module mdle in - new_breakpoint - (try - let buffer = - try get_buffer module_name with - | Not_found -> - eprintf "No source file for %s.@." module_name; - raise Toplevel - in - match column with - | None -> - event_at_pos module_name (fst (pos_of_line buffer line)) - | Some col -> - event_near_pos module_name (point_of_coord buffer line col) - with - | Not_found -> (* event_at_pos / event_near pos *) - eprintf "Can't find any event there.@."; - raise Toplevel - | Out_of_range -> (* pos_of_line / point_of_coord *) - eprintf "Position out of range.@."; - raise Toplevel) - | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) - try - new_breakpoint (event_near_pos (convert_module mdle) position) - with - | Not_found -> - eprintf "Can't find any event there.@." - -let instr_delete ppf lexbuf = - match integer_list_eol Lexer.lexeme lexbuf with - | [] -> - if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints" - then remove_all_breakpoints () - | breakpoints -> - List.iter - (function x -> try remove_breakpoint x with | Not_found -> ()) - breakpoints - -let instr_frame ppf lexbuf = - let frame_number = - match opt_integer_eol Lexer.lexeme lexbuf with - | None -> !current_frame - | Some x -> x - in - ensure_loaded (); - try - select_frame frame_number; - show_current_frame ppf true - with - | Not_found -> - error ("No frame number " ^ string_of_int frame_number ^ ".") - -let instr_backtrace ppf lexbuf = - let number = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 0 - | Some x -> x in - ensure_loaded (); - match current_report() with - | None | Some {rep_type = Exited | Uncaught_exc} -> () - | Some _ -> - let frame_counter = ref 0 in - let print_frame first_frame last_frame = function - | None -> - fprintf ppf - "(Encountered a function with no debugging information)@."; - false - | Some event -> - if !frame_counter >= first_frame then - show_one_frame !frame_counter ppf event; - incr frame_counter; - if !frame_counter >= last_frame then begin - fprintf ppf "(More frames follow)@." - end; - !frame_counter < last_frame in - if number = 0 then - do_backtrace (print_frame 0 max_int) - else if number > 0 then - do_backtrace (print_frame 0 number) - else begin - let num_frames = stack_depth() in - if num_frames < 0 then begin - fprintf ppf - "(Encountered a function with no debugging information)"; - print_newline() - end else - do_backtrace (print_frame (num_frames + number) max_int) - end - -let instr_up ppf lexbuf = - let offset = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - try - select_frame (!current_frame + offset); - show_current_frame ppf true - with - | Not_found -> error "No such frame." - -let instr_down ppf lexbuf = - let offset = - match opt_signed_integer_eol Lexer.lexeme lexbuf with - | None -> 1 - | Some x -> x - in - ensure_loaded (); - try - select_frame (!current_frame - offset); - show_current_frame ppf true - with - | Not_found -> error "No such frame." - -let instr_last ppf lexbuf = - let count = - match opt_signed_int64_eol Lexer.lexeme lexbuf with - | None -> _1 - | Some x -> x - in - reset_named_values(); - go_to (History.previous_time count); - show_current_event ppf - -let instr_list ppf lexbuf = - let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in - let (curr_mod, point) = - try - selected_point () - with - | Not_found -> - ("", -1) - in - let mdle = convert_module mo in - let beginning = - match beg with - | None when (mo <> None) || (point = -1) -> - 1 - | None -> - let buffer = - try get_buffer mdle with - | Not_found -> error ("No source file for " ^ mdle ^ ".") - in - begin try - max 1 ((snd (line_of_pos buffer point)) - 10) - with Out_of_range -> - 1 - end - | Some x -> x - in - let en = - match e with - | None -> beginning + 20 - | Some x -> x - in - if mdle = curr_mod then - show_listing mdle beginning en point - (current_event_is_before ()) - else - show_listing mdle beginning en (-1) true - -(** Variables. **) -let raw_variable kill name = - (function lexbuf -> - let argument = argument_eol argument lexbuf in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." !name - -let raw_line_variable kill name = - (function lexbuf -> - let argument = argument_eol line_argument lexbuf in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." !name - -let integer_variable kill min msg name = - (function lexbuf -> - let argument = integer_eol Lexer.lexeme lexbuf in - if argument < min then print_endline msg - else if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%i@." !name - -let int64_variable kill min msg name = - (function lexbuf -> - let argument = int64_eol Lexer.lexeme lexbuf in - if argument < min then print_endline msg - else if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%Li@." !name - -let boolean_variable kill name = - (function lexbuf -> - let argument = - match identifier_eol Lexer.lexeme lexbuf with - | "on" -> true - | "of" | "off" -> false - | _ -> error "Syntax error." - in - if (not kill) || ask_kill_program () then name := argument), - function ppf -> fprintf ppf "%s@." (if !name then "on" else "off") - -let path_variable kill name = - (function lexbuf -> - let argument = argument_eol argument lexbuf in - if (not kill) || ask_kill_program () then - name := make_absolute (expand_path argument)), - function ppf -> fprintf ppf "%s@." !name - -let loading_mode_variable ppf = - (find_ident - "loading mode" - (matching_elements (ref loading_modes) fst) - (fun (_, mode) ppf lexbuf -> - eol lexbuf; set_launching_function mode) - (function ppf -> error "Syntax error.") - ppf), - function ppf -> - let rec find = function - | [] -> () - | (name, funct) :: l -> - if funct == !launching_func then fprintf ppf "%s" name else find l - in - find loading_modes; - fprintf ppf "@." - -(** Infos. **) - -let pr_modules ppf mods = - let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in - fprintf ppf "Used modules :@.%a@?" pr_mods mods - -let info_modules ppf lexbuf = - eol lexbuf; - ensure_loaded (); - pr_modules ppf !modules -(******** - print_endline "Opened modules :"; - if !opened_modules_names = [] then - print_endline "(no module opened)." - else - (List.iter (function x -> print_string x; print_space) !opened_modules_names; - print_newline ()) -*********) - -let info_checkpoints ppf lexbuf = - eol lexbuf; - if !checkpoints = [] then fprintf ppf "No checkpoint.@." - else - (if !debug_breakpoints then - (prerr_endline " Time Pid Version"; - List.iter - (function - {c_time = time; c_pid = pid; c_breakpoint_version = version} -> - Printf.printf "%19Ld %5d %d\n" time pid version) - !checkpoints) - else - (print_endline " Time Pid"; - List.iter - (function - {c_time = time; c_pid = pid} -> - Printf.printf "%19Ld %5d\n" time pid) - !checkpoints)) - -let info_one_breakpoint ppf (num, ev) = - fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev); -;; - -let info_breakpoints ppf lexbuf = - eol lexbuf; - if !breakpoints = [] then fprintf ppf "No breakpoints.@." - else begin - fprintf ppf "Num Address Where@."; - List.iter (info_one_breakpoint ppf) (List.rev !breakpoints); - end -;; - -let info_events ppf lexbuf = - ensure_loaded (); - let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in - print_endline ("Module : " ^ mdle); - print_endline " Address Character Kind Repr."; - List.iter - (function ev -> - Printf.printf - "%10d %10d %10s %10s\n" - ev.ev_pos - ev.ev_char.Lexing.pos_cnum - ((match ev.ev_kind with - Event_before -> "before" - | Event_after _ -> "after" - | Event_pseudo -> "pseudo") - ^ - (match ev.ev_info with - Event_function -> "/fun" - | Event_return _ -> "/ret" - | Event_other -> "")) - (match ev.ev_repr with - Event_none -> "" - | Event_parent _ -> "(repr)" - | Event_child repr -> string_of_int !repr)) - (events_in_module mdle) - -(** User-defined printers **) - -let instr_load_printer ppf lexbuf = - let filename = extract_filename(argument_eol argument lexbuf) in - try - Loadprinter.loadfile ppf filename - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -let instr_install_printer ppf lexbuf = - let lid = longident_eol Lexer.lexeme lexbuf in - try - Loadprinter.install_printer ppf lid - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -let instr_remove_printer ppf lexbuf = - let lid = longident_eol Lexer.lexeme lexbuf in - try - Loadprinter.remove_printer lid - with Loadprinter.Error e -> - Loadprinter.report_error ppf e; raise Toplevel - -(** Initialization. **) -let init ppf = - instruction_list := [ - { instr_name = "cd"; instr_prio = false; - instr_action = instr_cd; instr_repeat = true; instr_help = -"set working directory to DIR for debugger and program being debugged." }; - { instr_name = "complete"; instr_prio = false; - instr_action = instr_complete; instr_repeat = false; instr_help = -"complete word at cursor according to context. Useful for Emacs." }; - { instr_name = "pwd"; instr_prio = false; - instr_action = instr_pwd; instr_repeat = true; instr_help = -"print working directory." }; - { instr_name = "directory"; instr_prio = false; - instr_action = instr_dir; instr_repeat = false; instr_help = -"add directory DIR to beginning of search path for source and\n\ -interface files.\n\ -Forget cached info on source file locations and line positions.\n\ -With no argument, reset the search path." }; - { instr_name = "kill"; instr_prio = false; - instr_action = instr_kill; instr_repeat = true; instr_help = -"kill the program being debugged." }; - { instr_name = "help"; instr_prio = false; - instr_action = instr_help; instr_repeat = true; instr_help = -"print list of commands." }; - { instr_name = "quit"; instr_prio = false; - instr_action = instr_quit; instr_repeat = false; instr_help = -"exit the debugger." }; - { instr_name = "shell"; instr_prio = false; - instr_action = instr_shell; instr_repeat = true; instr_help = -"Execute a given COMMAND thru the system shell." }; - (* Displacements *) - { instr_name = "run"; instr_prio = true; - instr_action = instr_run; instr_repeat = true; instr_help = -"run the program from current position." }; - { instr_name = "reverse"; instr_prio = false; - instr_action = instr_reverse; instr_repeat = true; instr_help = -"run the program backward from current position." }; - { instr_name = "step"; instr_prio = true; - instr_action = instr_step; instr_repeat = true; instr_help = -"step program until it reaches the next event.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "backstep"; instr_prio = true; - instr_action = instr_back; instr_repeat = true; instr_help = -"step program backward until it reaches the previous event.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "goto"; instr_prio = false; - instr_action = instr_goto; instr_repeat = true; instr_help = -"go to the given time." }; - { instr_name = "finish"; instr_prio = true; - instr_action = instr_finish; instr_repeat = true; instr_help = -"execute until topmost stack frame returns." }; - { instr_name = "next"; instr_prio = true; - instr_action = instr_next; instr_repeat = true; instr_help = -"step program until it reaches the next event.\n\ -Skip over function calls.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "start"; instr_prio = false; - instr_action = instr_start; instr_repeat = true; instr_help = -"execute backward until the current function is exited." }; - { instr_name = "previous"; instr_prio = false; - instr_action = instr_previous; instr_repeat = true; instr_help = -"step program until it reaches the previous event.\n\ -Skip over function calls.\n\ -Argument N means do this N times (or till program stops for another reason)." }; - { instr_name = "print"; instr_prio = true; - instr_action = instr_print; instr_repeat = true; instr_help = -"print value of expressions (deep printing)." }; - { instr_name = "display"; instr_prio = true; - instr_action = instr_display; instr_repeat = true; instr_help = -"print value of expressions (shallow printing)." }; - { instr_name = "source"; instr_prio = false; - instr_action = instr_source; instr_repeat = true; instr_help = -"read command from file FILE." }; - (* Breakpoints *) - { instr_name = "break"; instr_prio = false; - instr_action = instr_break; instr_repeat = false; instr_help = -"Set breakpoint at specified line or function.\n\ -Syntax: break function-name\n\ - break @ [module] linenum\n\ - break @ [module] # characternum" }; - { instr_name = "delete"; instr_prio = false; - instr_action = instr_delete; instr_repeat = false; instr_help = -"delete some breakpoints.\n\ -Arguments are breakpoint numbers with spaces in between.\n\ -To delete all breakpoints, give no argument." }; - { instr_name = "set"; instr_prio = false; - instr_action = instr_set; instr_repeat = false; instr_help = -"--unused--" }; - { instr_name = "show"; instr_prio = false; - instr_action = instr_show; instr_repeat = true; instr_help = -"--unused--" }; - { instr_name = "info"; instr_prio = false; - instr_action = instr_info; instr_repeat = true; instr_help = -"--unused--" }; - (* Frames *) - { instr_name = "frame"; instr_prio = false; - instr_action = instr_frame; instr_repeat = true; instr_help = -"select and print a stack frame.\n\ -With no argument, print the selected stack frame.\n\ -An argument specifies the frame to select." }; - { instr_name = "backtrace"; instr_prio = false; - instr_action = instr_backtrace; instr_repeat = true; instr_help = -"print backtrace of all stack frames, or innermost COUNT frames.\n\ -With a negative argument, print outermost -COUNT frames." }; - { instr_name = "bt"; instr_prio = false; - instr_action = instr_backtrace; instr_repeat = true; instr_help = -"print backtrace of all stack frames, or innermost COUNT frames.\n\ -With a negative argument, print outermost -COUNT frames." }; - { instr_name = "up"; instr_prio = false; - instr_action = instr_up; instr_repeat = true; instr_help = -"select and print stack frame that called this one.\n\ -An argument says how many frames up to go." }; - { instr_name = "down"; instr_prio = false; - instr_action = instr_down; instr_repeat = true; instr_help = -"select and print stack frame called by this one.\n\ -An argument says how many frames down to go." }; - { instr_name = "last"; instr_prio = true; - instr_action = instr_last; instr_repeat = true; instr_help = -"go back to previous time." }; - { instr_name = "list"; instr_prio = false; - instr_action = instr_list; instr_repeat = true; instr_help = -"list the source code." }; - (* User-defined printers *) - { instr_name = "load_printer"; instr_prio = false; - instr_action = instr_load_printer; instr_repeat = false; instr_help = -"load in the debugger a .cmo or .cma file containing printing functions." }; - { instr_name = "install_printer"; instr_prio = false; - instr_action = instr_install_printer; instr_repeat = false; instr_help = -"use the given function for printing values of its input type.\n\ -The code for the function must have previously been loaded in the debugger\n\ -using \"load_printer\"." }; - { instr_name = "remove_printer"; instr_prio = false; - instr_action = instr_remove_printer; instr_repeat = false; instr_help = -"stop using the given function for printing values of its input type." } -]; - variable_list := [ - (* variable name, (writing, reading), help reading, help writing *) - { var_name = "arguments"; - var_action = raw_line_variable true arguments; - var_help = -"arguments to give program being debugged when it is started." }; - { var_name = "program"; - var_action = path_variable true program_name; - var_help = -"name of program to be debugged." }; - { var_name = "loadingmode"; - var_action = loading_mode_variable ppf; - var_help = -"mode of loading.\n\ -It can be either : - direct : the program is directly called by the debugger.\n\ - runtime : the debugger execute `ocamlrun programname arguments'.\n\ - manual : the program is not launched by the debugger,\n\ - but manually by the user." }; - { var_name = "processcount"; - var_action = integer_variable false 1 "Must be >= 1." - checkpoint_max_count; - var_help = -"maximum number of process to keep." }; - { var_name = "checkpoints"; - var_action = boolean_variable false make_checkpoints; - var_help = -"whether to make checkpoints or not." }; - { var_name = "bigstep"; - var_action = int64_variable false _1 "Must be >= 1." - checkpoint_big_step; - var_help = -"step between checkpoints during long displacements." }; - { var_name = "smallstep"; - var_action = int64_variable false _1 "Must be >= 1." - checkpoint_small_step; - var_help = -"step between checkpoints during small displacements." }; - { var_name = "socket"; - var_action = raw_variable true socket_name; - var_help = -"name of the socket used by communications debugger-runtime." }; - { var_name = "history"; - var_action = integer_variable false 0 "" history_size; - var_help = -"history size." }; - { var_name = "print_depth"; - var_action = integer_variable false 1 "Must be at least 1" - max_printer_depth; - var_help = -"maximal depth for printing of values." }; - { var_name = "print_length"; - var_action = integer_variable false 1 "Must be at least 1" - max_printer_steps; - var_help = -"maximal number of value nodes printed." }]; - - info_list := - (* info name, function, help *) - [{ info_name = "modules"; - info_action = info_modules ppf; - info_help = "list opened modules." }; - { info_name = "checkpoints"; - info_action = info_checkpoints ppf; - info_help = "list checkpoints." }; - { info_name = "breakpoints"; - info_action = info_breakpoints ppf; - info_help = "list breakpoints." }; - { info_name = "events"; - info_action = info_events ppf; - info_help = "list events in MODULE (default is current module)." }] - -let _ = init std_formatter diff --git a/debugger/command_line.mli b/debugger/command_line.mli deleted file mode 100644 index dd2349d2c4..0000000000 --- a/debugger/command_line.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Reading and executing commands ***************) - -open Lexing;; -open Format;; - -val interprete_line : formatter -> string -> bool;; -val line_loop : formatter -> lexbuf -> unit;; diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml deleted file mode 100644 index edec454727..0000000000 --- a/debugger/debugcom.ml +++ /dev/null @@ -1,278 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Low-level communication with the debuggee *) - -open Int64ops -open Primitives - -(* The current connection with the debuggee *) - -let conn = ref Primitives.std_io - -let set_current_connection io_chan = - conn := io_chan - -(* Modify the program code *) - -let set_event pos = - output_char !conn.io_out 'e'; - output_binary_int !conn.io_out pos - -let set_breakpoint pos = - output_char !conn.io_out 'B'; - output_binary_int !conn.io_out pos - -let reset_instr pos = - output_char !conn.io_out 'i'; - output_binary_int !conn.io_out pos - -(* Basic commands for flow control *) - -type execution_summary = - Event - | Breakpoint - | Exited - | Trap_barrier - | Uncaught_exc - -type report = { - rep_type : execution_summary; - rep_event_count : int; - rep_stack_pointer : int; - rep_program_pointer : int -} - -type checkpoint_report = - Checkpoint_done of int - | Checkpoint_failed - -(* Run the debuggee for N events *) - -let do_go_smallint n = - output_char !conn.io_out 'g'; - output_binary_int !conn.io_out n; - flush !conn.io_out; - Input_handling.execute_with_other_controller - Input_handling.exit_main_loop - !conn - (function () -> - Input_handling.main_loop (); - let summary = - match input_char !conn.io_in with - 'e' -> Event - | 'b' -> Breakpoint - | 'x' -> Exited - | 's' -> Trap_barrier - | 'u' -> Uncaught_exc - | _ -> Misc.fatal_error "Debugcom.do_go" 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 - { rep_type = summary; - rep_event_count = event_counter; - rep_stack_pointer = stack_pos; - rep_program_pointer = pc }) - -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( - do_go_smallint (Int64.to_int n) - ) -;; - -(* Perform a checkpoint *) - -let do_checkpoint () = - output_char !conn.io_out 'c'; - flush !conn.io_out; - let pid = input_binary_int !conn.io_in in - if pid = -1 then Checkpoint_failed else Checkpoint_done pid - -(* Kill the given process. *) -let stop chan = - try - output_char chan.io_out 's'; - flush chan.io_out - with - Sys_error _ | End_of_file -> () - -(* Ask a process to wait for its child which has been killed. *) -(* (so as to eliminate zombies). *) -let wait_child chan = - try - output_char chan.io_out 'w' - with - Sys_error _ | End_of_file -> () - -(* Move to initial frame (that of current function). *) -(* Return stack position and current pc *) - -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 set_initial_frame () = - ignore(initial_frame ()) - -(* Move up one frame *) -(* Return stack position and current pc. - If there's no frame above, return (-1, 0). *) - -let up_frame stacksize = - output_char !conn.io_out 'U'; - 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) - -(* Get and set the current frame position *) - -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 set_frame stack_pos = - output_char !conn.io_out 'S'; - output_binary_int !conn.io_out stack_pos - -(* Set the trap barrier to given stack position. *) - -let set_trap_barrier pos = - output_char !conn.io_out 'b'; - output_binary_int !conn.io_out pos - -(* Handling of remote values *) - -let value_size = if 1 lsl 31 = 0 then 4 else 8 - -let input_remote_value ic = - let v = String.create value_size in - really_input ic v 0 value_size; v - -let output_remote_value ic v = - output ic v 0 value_size - -exception Marshalling_error - -module Remote_value = - struct - type t = Remote of string | Local of Obj.t - - let obj = function - | Local obj -> Obj.obj obj - | Remote v -> - output_char !conn.io_out 'M'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - try - input_value !conn.io_in - with End_of_file | Failure _ -> - raise Marshalling_error - - let is_block = function - | Local obj -> Obj.is_block obj - | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0) - - let tag = function - | Local obj -> Obj.tag obj - | Remote v -> - output_char !conn.io_out 'H'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - let header = input_binary_int !conn.io_in in - header land 0xFF - - let size = function - | Local obj -> Obj.size obj - | Remote v -> - output_char !conn.io_out 'H'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - let header = input_binary_int !conn.io_in in - if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32 - then header lsr 11 - else header lsr 10 - - let field v n = - match v with - | Local obj -> Local(Obj.field obj n) - | Remote v -> - output_char !conn.io_out 'F'; - output_remote_value !conn.io_out v; - output_binary_int !conn.io_out n; - flush !conn.io_out; - if input_byte !conn.io_in = 0 then - Remote(input_remote_value !conn.io_in) - else begin - let buf = String.create 8 in - really_input !conn.io_in buf 0 8; - let floatbuf = float n (* force allocation of a new float *) in - String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; - Local(Obj.repr floatbuf) - end - - let of_int n = - Local(Obj.repr n) - - let local pos = - output_char !conn.io_out 'L'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let from_environment pos = - output_char !conn.io_out 'E'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let global pos = - output_char !conn.io_out 'G'; - output_binary_int !conn.io_out pos; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let accu () = - output_char !conn.io_out 'A'; - flush !conn.io_out; - Remote(input_remote_value !conn.io_in) - - let closure_code = function - | Local obj -> assert false - | Remote v -> - output_char !conn.io_out 'C'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - input_binary_int !conn.io_in - - let same rv1 rv2 = - match (rv1, rv2) with - (Local obj1, Local obj2) -> obj1 == obj2 - | (Remote v1, Remote v2) -> v1 = v2 - (* string equality -> equality of remote pointers *) - | (_, _) -> false - - end diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli deleted file mode 100644 index 447e45d9e2..0000000000 --- a/debugger/debugcom.mli +++ /dev/null @@ -1,102 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Low-level communication with the debuggee *) - -type execution_summary = - Event - | Breakpoint - | Exited - | Trap_barrier - | Uncaught_exc - -type report = - { rep_type : execution_summary; - rep_event_count : int; - rep_stack_pointer : int; - rep_program_pointer : int } - -type checkpoint_report = - Checkpoint_done of int - | Checkpoint_failed - -(* Set the current connection with the debuggee *) -val set_current_connection : Primitives.io_channel -> unit - -(* Put an event at given pc *) -val set_event : int -> unit - -(* Put a breakpoint at given pc *) -val set_breakpoint : int -> unit - -(* Remove breakpoint or event at given pc *) -val reset_instr : int -> unit - -(* Create a new checkpoint (the current process forks). *) -val do_checkpoint : unit -> checkpoint_report - -(* Step N events. *) -val do_go : int64 -> report - -(* Tell given process to terminate *) -val stop : Primitives.io_channel -> unit - -(* Tell given process to wait for its children *) -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 set_initial_frame : unit -> unit - -(* Get the current frame position *) -(* Return stack position and current pc *) -val get_frame : unit -> int * int - -(* Set the current frame *) -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 - -(* Set the trap barrier to given stack position. *) -val set_trap_barrier : int -> unit - -(* Handling of remote values *) - -exception Marshalling_error - -module Remote_value : - sig - type t - - val obj : t -> 'a - val is_block : t -> bool - val tag : t -> int - val size : t -> int - val field : t -> int -> t - val same : t -> t -> bool - - val of_int : int -> t - - val local : int -> t - val from_environment : int -> t - val global : int -> t - val accu : unit -> t - val closure_code : t -> int - - end diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml deleted file mode 100644 index fa6fd7018f..0000000000 --- a/debugger/debugger_config.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Configuration file ***********************) - -open Int64ops - -exception Toplevel - -(*** Miscellaneous parameters. ***) - -(*ISO 6429 color sequences -00 to restore default color -01 for brighter colors -04 for underlined text -05 for flashing text -30 for black foreground -31 for red foreground -32 for green foreground -33 for yellow (or brown) foreground -34 for blue foreground -35 for purple foreground -36 for cyan foreground -37 for white (or gray) foreground -40 for black background -41 for red background -42 for green background -43 for yellow (or brown) background -44 for blue background -45 for purple background -46 for cyan background -47 for white (or gray) background -let debugger_prompt = "\027[1;04m(ocd)\027[0m " -and event_mark_before = "\027[1;31m$\027[0m" -and event_mark_after = "\027[1;34m$\027[0m" -*) -let debugger_prompt = "(ocd) " -let event_mark_before = "<|b|>" -let event_mark_after = "<|a|>" - -(* Name of shell used to launch the debuggee *) -let shell = "/bin/sh" - -(* Name of the Objective Caml runtime. *) -let runtime_program = "ocamlrun" - -(* Time history size (for `last') *) -let history_size = ref 30 - -(*** Time travel parameters. ***) - -(* Step between checkpoints for long displacements.*) -let checkpoint_big_step = ref (~~ "10000") - -(* Idem for small ones. *) -let checkpoint_small_step = ref (~~ "1000") - -(* Maximum number of checkpoints. *) -let checkpoint_max_count = ref 15 - -(* Whether to keep checkpoints or not. *) -let make_checkpoints = ref true - diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli deleted file mode 100644 index 44f4fe582a..0000000000 --- a/debugger/debugger_config.mli +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************** Configuration file *****************************) - -exception Toplevel - -(*** Miscellaneous parameters. ***) - -val debugger_prompt : string -val event_mark_before : string -val event_mark_after : string -val shell : string -val runtime_program : string -val history_size : int ref - -(*** Time travel paramaters. ***) - -val checkpoint_big_step : int64 ref -val checkpoint_small_step : int64 ref -val checkpoint_max_count : int ref -val make_checkpoints : bool ref - diff --git a/debugger/envaux.ml b/debugger/envaux.ml deleted file mode 100644 index ba8d6dff59..0000000000 --- a/debugger/envaux.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Misc -open Types -open Env - -type error = - Module_not_found of Path.t - -exception Error of error - -let env_cache = - (Hashtbl.create 59 : (Env.summary, Env.t) Hashtbl.t) - -let reset_cache () = - Hashtbl.clear env_cache; - Env.reset_cache() - -let extract_sig env mty = - match Mtype.scrape env mty with - Tmty_signature sg -> sg - | _ -> fatal_error "Envaux.extract_sig" - -let rec env_from_summary sum = - try - Hashtbl.find env_cache sum - with Not_found -> - let env = - match sum with - Env_empty -> - Env.empty - | Env_value(s, id, desc) -> - Env.add_value id desc (env_from_summary s) - | Env_type(s, id, desc) -> - Env.add_type id desc (env_from_summary s) - | Env_exception(s, id, desc) -> - Env.add_exception id desc (env_from_summary s) - | Env_module(s, id, desc) -> - Env.add_module id desc (env_from_summary s) - | Env_modtype(s, id, desc) -> - Env.add_modtype id desc (env_from_summary s) - | Env_class(s, id, desc) -> - Env.add_class id desc (env_from_summary s) - | Env_cltype (s, id, desc) -> - Env.add_cltype id desc (env_from_summary s) - | Env_open(s, path) -> - let env = env_from_summary s in - let mty = - try - Env.find_module path env - with Not_found -> - raise (Error (Module_not_found path)) - in - Env.open_signature path (extract_sig env mty) env - in - Hashtbl.add env_cache sum env; - env - -let env_of_event = - function - None -> Env.empty - | Some ev -> env_from_summary ev.Instruct.ev_typenv - -(* Error report *) - -open Format - -let report_error ppf = function - | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p diff --git a/debugger/envaux.mli b/debugger/envaux.mli deleted file mode 100644 index 8b122cc347..0000000000 --- a/debugger/envaux.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -(* Convert environment summaries to environments *) - -val env_of_event: Instruct.debug_event option -> Env.t - -(* Empty the environment caches. To be called when load_path changes. *) - -val reset_cache: unit -> unit - -(* Error report *) - -type error = - Module_not_found of Path.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/eval.ml b/debugger/eval.ml deleted file mode 100644 index a53589382a..0000000000 --- a/debugger/eval.ml +++ /dev/null @@ -1,207 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Debugger_config -open Misc -open Path -open Instruct -open Types -open Parser_aux - -type error = - Unbound_identifier of Ident.t - | Not_initialized_yet of Path.t - | Unbound_long_identifier of Longident.t - | Unknown_name of int - | Tuple_index of type_expr * int * int - | Array_index of int * int - | List_index of int * int - | String_index of string * int * int - | Wrong_item_type of type_expr * int - | Wrong_label of type_expr * string - | Not_a_record of type_expr - | No_result - -exception Error of error - -let abstract_type = - Btype.newgenty (Tconstr (Pident (Ident.create "<abstr>"), [], ref Mnil)) - -let rec path event = function - Pident id -> - if Ident.global id then - Debugcom.Remote_value.global (Symtable.get_global_position id) - else - begin match event with - Some ev -> - begin try - let pos = Ident.find_same id ev.ev_compenv.ce_stack in - Debugcom.Remote_value.local (ev.ev_stacksize - pos) - with Not_found -> - try - let pos = Ident.find_same id ev.ev_compenv.ce_heap in - Debugcom.Remote_value.from_environment pos - with Not_found -> - raise(Error(Unbound_identifier id)) - end - | None -> - raise(Error(Unbound_identifier id)) - end - | Pdot(root, fieldname, pos) -> - let v = path event root in - if not (Debugcom.Remote_value.is_block v) then - raise(Error(Not_initialized_yet root)); - Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> - fatal_error "Eval.path: Papply" - -let rec expression event env = function - E_ident lid -> - begin try - let (p, valdesc) = Env.lookup_value lid env in - (begin match valdesc.val_kind with - Val_ivar (_, cl_num) -> - let (p0, _) = - Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env - in - let v = path event p0 in - let i = path event p in - Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i) - | _ -> - path event p - end, - Ctype.correct_levels valdesc.val_type) - with Not_found -> - raise(Error(Unbound_long_identifier lid)) - end - | E_result -> - begin match event with - Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 -> - (Debugcom.Remote_value.accu(), ty) - | _ -> - raise(Error(No_result)) - end - | E_name n -> - begin try - Printval.find_named_value n - with Not_found -> - raise(Error(Unknown_name n)) - end - | E_item(arg, n) -> - let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with - Ttuple ty_list -> - if n < 1 || n > List.length ty_list - then raise(Error(Tuple_index(ty, List.length ty_list, n))) - else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1)) - | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> - let size = Debugcom.Remote_value.size v in - if n >= size - then raise(Error(Array_index(size, n))) - else (Debugcom.Remote_value.field v n, ty_arg) - | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> - let rec nth pos v = - if not (Debugcom.Remote_value.is_block v) then - raise(Error(List_index(pos, n))) - else if pos = n then - (Debugcom.Remote_value.field v 0, ty_arg) - else - nth (pos + 1) (Debugcom.Remote_value.field v 1) - in nth 0 v - | Tconstr(path, [], _) when Path.same path Predef.path_string -> - let s = (Debugcom.Remote_value.obj v : string) in - if n >= String.length s - then raise(Error(String_index(s, String.length s, n))) - else (Debugcom.Remote_value.of_int(Char.code s.[n]), - Predef.type_char) - | _ -> - raise(Error(Wrong_item_type(ty, n))) - end - | E_field(arg, lbl) -> - let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with - Tconstr(path, args, _) -> - let tydesc = Env.find_type path env in - begin match tydesc.type_kind with - Type_record(lbl_list, repr, priv) -> - let (pos, ty_res) = - find_label lbl env ty path tydesc 0 lbl_list in - (Debugcom.Remote_value.field v pos, ty_res) - | _ -> raise(Error(Not_a_record ty)) - end - | _ -> raise(Error(Not_a_record ty)) - end - -and find_label lbl env ty path tydesc pos = function - [] -> - raise(Error(Wrong_label(ty, lbl))) - | (name, mut, ty_arg) :: rem -> - if name = lbl then begin - let ty_res = - Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) - in - (pos, - try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply -> - abstract_type) - end else - find_label lbl env ty path tydesc (pos + 1) rem - -(* Error report *) - -open Format - -let report_error ppf = function - | Unbound_identifier id -> - fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id) - | Not_initialized_yet path -> - fprintf ppf - "@[The module path %a is not yet initialized.@ \ - Please run program forward@ \ - until its initialization code is executed.@]@." - Printtyp.path path - | Unbound_long_identifier lid -> - fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid - | Unknown_name n -> - fprintf ppf "@[Unknown value name $%i@]@." n - | Tuple_index(ty, len, pos) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf - "@[Cannot extract field number %i from a %i-components \ - tuple of type@ %a@]@." - pos len Printtyp.type_expr ty - | Array_index(len, pos) -> - fprintf ppf - "@[Cannot extract element number %i from array of length %i@]@." pos len - | List_index(len, pos) -> - fprintf ppf - "@[Cannot extract element number %i from list of length %i@]@." pos len - | String_index(s, len, pos) -> - fprintf ppf - "@[Cannot extract character number %i@ \ - from the following string of length %i:@ %S@]@." - pos len s - | Wrong_item_type(ty, pos) -> - fprintf ppf - "@[Cannot extract item number %i from a value of type@ %a@]@." - pos Printtyp.type_expr ty - | Wrong_label(ty, lbl) -> - fprintf ppf - "@[The record type@ %a@ has no label named %s@]@." - Printtyp.type_expr ty lbl - | Not_a_record ty -> - fprintf ppf - "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty - | No_result -> - fprintf ppf "@[No result available at current program event@]@." diff --git a/debugger/eval.mli b/debugger/eval.mli deleted file mode 100644 index b2a2998f14..0000000000 --- a/debugger/eval.mli +++ /dev/null @@ -1,40 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Types -open Parser_aux -open Format - -val expression : - Instruct.debug_event option -> Env.t -> expression -> - Debugcom.Remote_value.t * type_expr - -type error = - | Unbound_identifier of Ident.t - | Not_initialized_yet of Path.t - | Unbound_long_identifier of Longident.t - | Unknown_name of int - | Tuple_index of type_expr * int * int - | Array_index of int * int - | List_index of int * int - | String_index of string * int * int - | Wrong_item_type of type_expr * int - | Wrong_label of type_expr * string - | Not_a_record of type_expr - | No_result - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/events.ml b/debugger/events.ml deleted file mode 100644 index 5fb501ed34..0000000000 --- a/debugger/events.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************************* Events ******************************) - -open Instruct -open Primitives -open Checkpoints - -(* Previous `pc'. *) -(* Save time if `update_current_event' is called *) -(* several times at the same point. *) -let old_pc = ref (None : int option) - -(*** Current events. ***) - -(* Event at current position *) -let current_event = - ref (None : debug_event option) - -(* Recompute the current event *) -let update_current_event () = - match current_pc () with - None -> - current_event := None; - old_pc := None - | (Some pc) as opt_pc when opt_pc <> !old_pc -> - current_event := begin try - Some (Symbols.event_at_pc pc) - with Not_found -> - None - end; - old_pc := opt_pc - | _ -> - () - -(* Current position in source. *) -(* Raise `Not_found' if not on an event (beginning or end of program). *) -let current_point () = - match !current_event with - None -> - raise Not_found - | Some {ev_char = point; ev_module = mdle} -> - (mdle, point.Lexing.pos_cnum) - -let current_event_is_before () = - match !current_event with - None -> - raise Not_found - | Some {ev_kind = Event_before} -> - true - | _ -> - false diff --git a/debugger/events.mli b/debugger/events.mli deleted file mode 100644 index 8c47399571..0000000000 --- a/debugger/events.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct - -(** Current events. **) - -(* The event at current position. *) -val current_event : debug_event option ref - -(* Recompute the current event *) -val update_current_event : unit -> unit - -(* Current position in source. *) -(* Raise `Not_found' if not on an event (beginning or end of program). *) -val current_point : unit -> string * int - -val current_event_is_before : unit -> bool - diff --git a/debugger/exec.ml b/debugger/exec.ml deleted file mode 100644 index d97a8c4e7d..0000000000 --- a/debugger/exec.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of keyboard interrupts *) - -let interrupted = ref false - -let is_protected = ref false - -let break signum = - if !is_protected - then interrupted := true - else raise Sys.Break - -let _ = - Sys.set_signal Sys.sigint (Sys.Signal_handle break); - Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) - -let protect f = - if !is_protected then - f () - else begin - is_protected := true; - if not !interrupted then - f (); - is_protected := false; - if !interrupted then begin interrupted := false; raise Sys.Break end - end - -let unprotect f = - if not !is_protected then - f () - else begin - is_protected := false; - if !interrupted then begin interrupted := false; raise Sys.Break end; - f (); - is_protected := true - end diff --git a/debugger/exec.mli b/debugger/exec.mli deleted file mode 100644 index 9d3b986048..0000000000 --- a/debugger/exec.mli +++ /dev/null @@ -1,19 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of keyboard interrupts *) - -val protect : (unit -> unit) -> unit -val unprotect : (unit -> unit) -> unit diff --git a/debugger/frames.ml b/debugger/frames.ml deleted file mode 100644 index cb76e013a6..0000000000 --- a/debugger/frames.ml +++ /dev/null @@ -1,129 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Frames **********************************) - -open Instruct -open Primitives -open Debugcom -open Checkpoints -open Events -open Symbols - -(* Current frame number *) -let current_frame = ref 0 - -(* Event at selected position *) -let selected_event = ref (None : debug_event option) - -(* Selected position in source. *) -(* Raise `Not_found' if not on an event. *) -let selected_point () = - match !selected_event with - None -> - raise Not_found - | Some {ev_char = point; ev_module = mdle} -> - (mdle, point.Lexing.pos_cnum) - -let selected_event_is_before () = - match !selected_event with - None -> - raise Not_found - | Some {ev_kind = Event_before} -> - true - | _ -> - false - -(* Move up `frame_count' frames, assuming current frame pointer - corresponds to event `event'. Return event of final frame. *) - -let rec move_up frame_count event = - if frame_count <= 0 then event else begin - let (sp, pc) = up_frame event.ev_stacksize in - if sp < 0 then raise Not_found; - move_up (frame_count - 1) (any_event_at_pc pc) - end - -(* Select a frame. *) -(* Raise `Not_found' if no such frame. *) -(* --- Assume the current events have already been updated. *) -let select_frame frame_number = - if frame_number < 0 then raise Not_found; - let (initial_sp, _) = get_frame() in - try - match !current_event with - None -> - raise Not_found - | Some curr_event -> - match !selected_event with - Some sel_event when frame_number >= !current_frame -> - selected_event := - Some(move_up (frame_number - !current_frame) sel_event); - current_frame := frame_number - | _ -> - set_initial_frame(); - selected_event := Some(move_up frame_number curr_event); - current_frame := frame_number - with Not_found -> - set_frame initial_sp; - raise Not_found - -(* Select a frame. *) -(* Same as `select_frame' but raise no exception if the frame is not found. *) -(* --- Assume the currents events have already been updated. *) -let try_select_frame frame_number = - try - select_frame frame_number - with - Not_found -> - () - -(* Return to default frame (frame 0). *) -let reset_frame () = - set_initial_frame(); - selected_event := !current_event; - current_frame := 0 - -(* Perform a stack backtrace. - Call the given function with the events for each stack frame, - 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. *) - -let do_backtrace action = - match !current_event with - None -> Misc.fatal_error "Frames.do_backtrace" - | Some curr_ev -> - let (initial_sp, _) = get_frame() in - set_initial_frame(); - let event = ref curr_ev in - begin try - while action (Some !event) do - let (sp, pc) = up_frame !event.ev_stacksize in - if sp < 0 then raise Exit; - event := any_event_at_pc pc - done - with Exit -> () - | Not_found -> ignore (action None) - end; - set_frame initial_sp - -(* Return the number of frames in the stack *) - -let stack_depth () = - let num_frames = ref 0 in - do_backtrace (function Some ev -> incr num_frames; true - | None -> num_frames := -1; false); - !num_frames diff --git a/debugger/frames.mli b/debugger/frames.mli deleted file mode 100644 index 0906171f2e..0000000000 --- a/debugger/frames.mli +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************************** Frames *********************************) - -open Instruct -open Primitives - -(* Current frame number *) -val current_frame : int ref - -(* Event at selected position. *) -val selected_event : debug_event option ref - -(* Selected position in source. *) -(* Raise `Not_found' if not on an event. *) -val selected_point : unit -> string * int - -val selected_event_is_before : unit -> bool - -(* Select a frame. *) -(* Raise `Not_found' if no such frame. *) -(* --- Assume the currents events have already been updated. *) -val select_frame : int -> unit - -(* Select a frame. *) -(* Same as `select_frame' but raise no exception if the frame is not found. *) -(* --- Assume the currents events have already been updated. *) -val try_select_frame : int -> unit - -(* Return to default frame (frame 0). *) -val reset_frame : unit -> unit - -(* Perform a stack backtrace. - Call the given function with the events for each stack frame, - 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 - -(* Return the number of frames in the stack, or (-1) if it can't be - determined because some frames have no debugging info. *) -val stack_depth : unit -> int diff --git a/debugger/history.ml b/debugger/history.ml deleted file mode 100644 index 31a6e7ad2a..0000000000 --- a/debugger/history.ml +++ /dev/null @@ -1,44 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Int64ops -open Checkpoints -open Misc -open Primitives -open Debugger_config - -let history = ref ([] : int64 list) - -let empty_history () = - history := [] - -let add_current_time () = - let time = current_time () in - if !history = [] then - history := [time] - else if time <> List.hd !history then - history := list_truncate !history_size (time::!history) - -let previous_time_1 () = - match !history with - _::((time::_) as hist) -> - history := hist; time - | _ -> - prerr_endline "No more information."; raise Toplevel - -let rec previous_time n = - if n = _1 - then previous_time_1() - else begin ignore(previous_time_1()); previous_time(pre64 n) end diff --git a/debugger/history.mli b/debugger/history.mli deleted file mode 100644 index 249629fdb9..0000000000 --- a/debugger/history.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val empty_history : unit -> unit - -val add_current_time : unit -> unit - -val previous_time : int64 -> int64 diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml deleted file mode 100644 index 5aac814b9a..0000000000 --- a/debugger/input_handling.ml +++ /dev/null @@ -1,148 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Input control ****************************) - -open Unix -open Primitives - -(*** Actives files. ***) - -(* List of the actives files. *) -let active_files = - ref ([] : (file_descr * ((io_channel -> unit) * io_channel)) list) - -(* Add a file to the list of actives files. *) -let add_file file controller = - active_files := (file.io_fd, (controller, file))::!active_files - -(* Remove a file from the list of actives files. *) -let remove_file file = - active_files := assoc_remove !active_files file.io_fd - -(* Change the controller for the given file. *) -let change_controller file controller = - remove_file file; add_file file controller - -(* Return the controller currently attached to the given file. *) -let current_controller file = - fst (List.assoc file.io_fd !active_files) - -(* Execute a function with `controller' attached to `file'. *) -(* ### controller file funct *) -let execute_with_other_controller controller file funct = - let old_controller = current_controller file in - change_controller file controller; - try - let result = funct () in - change_controller file old_controller; - result - with - x -> - change_controller file old_controller; - raise x - -(*** The "Main Loop" ***) - -let continue_main_loop = - ref true - -let exit_main_loop _ = - continue_main_loop := false - -(* Handle active files until `continue_main_loop' is false. *) -let main_loop () = - let old_state = !continue_main_loop in - try - continue_main_loop := true; - while !continue_main_loop do - try - let (input, _, _) = - select (List.map fst !active_files) [] [] (-1.) - in - List.iter - (function fd -> - let (funct, iochan) = (List.assoc fd !active_files) in - funct iochan) - input - with - Unix_error (EINTR, _, _) -> () - done; - continue_main_loop := old_state - with - x -> - continue_main_loop := old_state; - raise x - -(*** Managing user inputs ***) - -(* Are we in interactive mode ? *) -let interactif = ref true - -let current_prompt = ref "" - -(* Where the user input come from. *) -let user_channel = ref std_io - -let read_user_input buffer length = - main_loop (); - input !user_channel.io_in buffer 0 length - -(* Stop reading user input. *) -let stop_user_input () = - remove_file !user_channel - -(* Resume reading user input. *) -let resume_user_input () = - if not (List.mem_assoc !user_channel.io_fd !active_files) then begin - if !interactif then begin - print_string !current_prompt; - flush Pervasives.stdout - end; - add_file !user_channel exit_main_loop - end - -(* Ask user a yes or no question. *) -let yes_or_no message = - if !interactif then - let old_prompt = !current_prompt in - try - current_prompt := message ^ " ? (y or n) "; - let answer = - let rec ask () = - resume_user_input (); - let line = - string_trim (Lexer.line (Lexing.from_function read_user_input)) - in - stop_user_input (); - match (if String.length line > 0 then line.[0] else ' ') with - 'y' -> true - | 'n' -> false - | _ -> - print_string "Please answer y or n."; - print_newline (); - ask () - in - ask () - in - current_prompt := old_prompt; - answer - with - x -> - current_prompt := old_prompt; - stop_user_input (); - raise x - else - false diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli deleted file mode 100644 index 872b880816..0000000000 --- a/debugger/input_handling.mli +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(***************************** Input control ***************************) - -open Primitives - -(*** Actives files. ***) - -(* Add a file to the list of active files. *) -val add_file : io_channel -> (io_channel -> unit) -> unit - -(* Remove a file from the list of actives files. *) -val remove_file : io_channel -> unit - -(* Return the controller currently attached to the given file. *) -val current_controller : io_channel -> (io_channel -> unit) - -(* Execute a function with `controller' attached to `file'. *) -(* ### controller file funct *) -val execute_with_other_controller : - (io_channel -> unit) -> io_channel -> (unit -> 'a) -> 'a - -(*** The "Main Loop" ***) - -(* Call this function for exiting the main loop. *) -val exit_main_loop : 'a -> unit - -(* Handle active files until `continue_main_loop' is false. *) -val main_loop : unit -> unit - -(*** Managing user inputs ***) - -(* Are we in interactive mode ? *) -val interactif : bool ref - -val current_prompt : string ref - -(* Where the user input come from. *) -val user_channel : io_channel ref - -val read_user_input : string -> int -> int - -(* Stop reading user input. *) -val stop_user_input : unit -> unit - -(* Resume reading user input. *) -val resume_user_input : unit -> unit - -(* Ask user a yes or no question. *) -val yes_or_no : string -> bool diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml deleted file mode 100644 index b854a6c343..0000000000 --- a/debugger/int64ops.ml +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocqencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** arithmetic operators for Int64 *********************) - -let ( ++ ) = Int64.add;; -let ( -- ) = Int64.sub;; -let suc64 = Int64.succ;; -let pre64 = Int64.pred;; -let _0 = Int64.zero;; -let _1 = Int64.one;; -let _minus1 = Int64.minus_one;; -let ( ~~ ) = Int64.of_string;; -let max_small_int = Int64.of_int max_int;; -let to_int = Int64.to_int;; diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli deleted file mode 100644 index 98f7228d3d..0000000000 --- a/debugger/int64ops.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocqencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** arithmetic operators for Int64 *********************) - -val ( ++ ) : int64 -> int64 -> int64;; -val ( -- ) : int64 -> int64 -> int64;; -val suc64 : int64 -> int64;; -val pre64 : int64 -> int64;; -val _0 : int64;; -val _1 : int64;; -val _minus1 : int64;; -val ( ~~ ) : string -> int64;; -val max_small_int : int64;; -val to_int : int64 -> int;; diff --git a/debugger/lexer.mll b/debugger/lexer.mll deleted file mode 100644 index 17293f62c4..0000000000 --- a/debugger/lexer.mll +++ /dev/null @@ -1,98 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -{ - -open Primitives -open Parser - -} - -rule line = (* Read a whole line *) - parse - ([ ^ '\n' '\r' ]* as s) ('\n' | '\r' | "\r\n") - { s } - | [ ^ '\n' '\r' ]* - { Lexing.lexeme lexbuf } - | eof - { raise Exit } - -and argument = (* Read a raw argument *) - parse - [ ^ ' ' '\t' ]+ - { ARGUMENT (Lexing.lexeme lexbuf) } - | [' ' '\t']+ - { argument lexbuf } - | eof - { EOL } - | _ - { raise Parsing.Parse_error } - -and line_argument = - parse - _ * - { ARGUMENT (Lexing.lexeme lexbuf) } - | eof - { EOL } - -and lexeme = (* Read a lexeme *) - parse - [' ' '\t'] + - { lexeme lexbuf } - | ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] - (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' - '\'' '0'-'9' ]) * - { LIDENT(Lexing.lexeme lexbuf) } - | ['A'-'Z' '\192'-'\214' '\216'-'\222' ] - (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' - '\'' '0'-'9' ]) * - { UIDENT(Lexing.lexeme lexbuf) } - | '"' [^ '"']* "\"" - { let s = Lexing.lexeme lexbuf in - LIDENT(String.sub s 1 (String.length s - 2)) } - | ['0'-'9']+ - | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ - | '0' ['o' 'O'] ['0'-'7']+ - | '0' ['b' 'B'] ['0'-'1']+ - { INTEGER (Int64.of_string (Lexing.lexeme lexbuf)) } - | '*' - { STAR } - | "-" - { MINUS } - | "." - { DOT } - | "#" - { SHARP } - | "@" - { AT } - | "$" - { DOLLAR } - | "!" - { BANG } - | "(" - { LPAREN } - | ")" - { RPAREN } - | "[" - { LBRACKET } - | "]" - { RBRACKET } - | ['!' '?' '~' '=' '<' '>' '|' '&' '$' '@' '^' '+' '-' '*' '/' '%'] - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * - { OPERATOR (Lexing.lexeme lexbuf) } - | eof - { EOL } - | _ - { raise Parsing.Parse_error } diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml deleted file mode 100644 index ef86b7146e..0000000000 --- a/debugger/loadprinter.ml +++ /dev/null @@ -1,172 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Loading and installation of user-defined printer functions *) - -open Misc -open Debugger_config -open Longident -open Path -open Types - -(* Error report *) - -type error = - | Load_failure of Dynlink.error - | Unbound_identifier of Longident.t - | Unavailable_module of string * Longident.t - | Wrong_type of Longident.t - | No_active_printer of Longident.t - -exception Error of error - -(* Symtable has global state, and normally holds the symbol table - for the debuggee. We need to switch it temporarily to the - symbol table for the debugger. *) - -let debugger_symtable = ref (None: Symtable.global_map option) - -let use_debugger_symtable fn arg = - let old_symtable = Symtable.current_state() in - begin match !debugger_symtable with - | None -> - Dynlink.init(); - Dynlink.allow_unsafe_modules true; - debugger_symtable := Some(Symtable.current_state()) - | Some st -> - Symtable.restore_state st - end; - try - let result = fn arg in - debugger_symtable := Some(Symtable.current_state()); - Symtable.restore_state old_symtable; - result - with exn -> - Symtable.restore_state old_symtable; - raise exn - -(* Load a .cmo or .cma file *) - -open Format - -let rec loadfiles ppf name = - try - let filename = find_in_path !Config.load_path name in - use_debugger_symtable Dynlink.loadfile filename; - let d = Filename.dirname name in - if d <> Filename.current_dir_name then begin - if not (List.mem d !Config.load_path) then - Config.load_path := d :: !Config.load_path; - end; - fprintf ppf "File %s loaded@." filename; - true - with - | Dynlink.Error (Dynlink.Unavailable_unit unit) -> - loadfiles ppf (String.uncapitalize unit ^ ".cmo") - && - loadfiles ppf name - | Not_found -> - fprintf ppf "Cannot find file %s@." name; - false - | Dynlink.Error e -> - raise(Error(Load_failure e)) - -let loadfile ppf name = - ignore(loadfiles ppf name) - -(* Return the value referred to by a path (as in toplevel/topdirs) *) -(* Note: evaluation proceeds in the debugger memory space, not in - the debuggee. *) - -let rec eval_path = function - Pident id -> Symtable.get_global_value id - | Pdot(p, s, pos) -> Obj.field (eval_path p) pos - | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path" - -(* Install, remove a printer (as in toplevel/topdirs) *) - -let match_printer_type desc typename = - let (printer_type, _) = - try - Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty - with Not_found -> - raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in - Ctype.init_def(Ident.current_time()); - Ctype.begin_def(); - let ty_arg = Ctype.newvar() in - Ctype.unify Env.empty - (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); - Ctype.end_def(); - Ctype.generalize ty_arg; - ty_arg - -let find_printer_type lid = - try - let (path, desc) = Env.lookup_value lid Env.empty in - let (ty_arg, is_old_style) = - try - (match_printer_type desc "printer_type_new", false) - with Ctype.Unify _ -> - (match_printer_type desc "printer_type_old", true) in - (ty_arg, path, is_old_style) - with - | Not_found -> raise(Error(Unbound_identifier lid)) - | Ctype.Unify _ -> raise(Error(Wrong_type lid)) - -let install_printer ppf lid = - let (ty_arg, path, is_old_style) = find_printer_type lid in - let v = - try - use_debugger_symtable eval_path path - with Symtable.Error(Symtable.Undefined_global s) -> - raise(Error(Unavailable_module(s, lid))) in - let print_function = - if is_old_style then - (fun formatter repr -> (Obj.obj v) (Obj.obj repr)) - else - (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in - Printval.install_printer path ty_arg ppf print_function - -let remove_printer lid = - let (ty_arg, path, is_old_style) = find_printer_type lid in - try - Printval.remove_printer path - with Not_found -> - raise(Error(No_active_printer lid)) - -(* Error report *) - -open Format - -let report_error ppf = function - | Load_failure e -> - fprintf ppf "@[Error during code loading: %s@]@." - (Dynlink.error_message e) - | Unbound_identifier lid -> - fprintf ppf "@[Unbound identifier %a@]@." - Printtyp.longident lid - | Unavailable_module(md, lid) -> - fprintf ppf - "@[The debugger does not contain the code for@ %a.@ \ - Please load an implementation of %s first.@]@." - Printtyp.longident lid md - | Wrong_type lid -> - fprintf ppf "@[%a has the wrong type for a printing function.@]@." - Printtyp.longident lid - | No_active_printer lid -> - fprintf ppf "@[%a is not currently active as a printing function.@]@." - Printtyp.longident lid - - diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli deleted file mode 100644 index bdaf77a285..0000000000 --- a/debugger/loadprinter.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Loading and installation of user-defined printer functions *) - -open Format - -val loadfile : formatter -> string -> unit -val install_printer : formatter -> Longident.t -> unit -val remove_printer : Longident.t -> unit - -(* Error report *) - -type error = - | Load_failure of Dynlink.error - | Unbound_identifier of Longident.t - | Unavailable_module of string * Longident.t - | Wrong_type of Longident.t - | No_active_printer of Longident.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/main.ml b/debugger/main.ml deleted file mode 100644 index 0bb2dda19c..0000000000 --- a/debugger/main.ml +++ /dev/null @@ -1,132 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Primitives -open Misc -open Input_handling -open Command_line -open Debugger_config -open Checkpoints -open Time_travel -open Parameters -open Program_management -open Frames -open Show_information -open Format - -let line_buffer = Lexing.from_function read_user_input - -let rec loop ppf = - line_loop ppf line_buffer; - if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then - loop ppf - -let rec protect ppf loop = - try - loop ppf - with - | End_of_file -> - protect ppf (function ppf -> - forget_process - !current_checkpoint.c_fd - !current_checkpoint.c_pid; - pp_print_flush ppf (); - stop_user_input (); - loop ppf) - | Toplevel -> - protect ppf (function ppf -> - pp_print_flush ppf (); - stop_user_input (); - loop ppf) - | Sys.Break -> - protect ppf (function ppf -> - fprintf ppf "Interrupted.@."; - Exec.protect (function () -> - stop_user_input (); - if !loaded then begin - try_select_frame 0; - show_current_event ppf; - end); - loop ppf) - | Current_checkpoint_lost -> - protect ppf (function ppf -> - fprintf ppf "Trying to recover...@."; - stop_user_input (); - recover (); - try_select_frame 0; - show_current_event ppf; - loop ppf) - | x -> - kill_program (); - raise x - -let toplevel_loop () = protect Format.std_formatter loop - -(* Parsing of command-line arguments *) - -exception Found_program_name - -let anonymous s = - program_name := Unix_tools.make_absolute s; raise Found_program_name -let add_include d = - default_load_path := - Misc.expand_directory Config.standard_library d :: !default_load_path -let set_socket s = - socket_name := s -let set_checkpoints n = - checkpoint_max_count := n -let set_directory dir = - Sys.chdir dir -let set_emacs () = - emacs := true - -let speclist = - ["-I", Arg.String add_include, - "<dir> Add <dir> to the list of include directories"; - "-s", Arg.String set_socket, - "<filename> Set the name of the communication socket"; - "-c", Arg.Int set_checkpoints, - "<count> Set max number of checkpoints kept"; - "-cd", Arg.String set_directory, - "<dir> Change working directory"; - "-emacs", Arg.Unit set_emacs, - "For running the debugger under emacs"] - -let main () = - try - socket_name := "/tmp/camldebug" ^ (string_of_int (Unix.getpid ())); - begin try - Arg.parse speclist anonymous ""; - Arg.usage speclist - "No program name specified\n\ - Usage: ocamldebug [options] <program> [arguments]\n\ - Options are:"; - exit 2 - with Found_program_name -> - for j = !Arg.current + 1 to Array.length Sys.argv - 1 do - arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j)) - done - end; - current_prompt := debugger_prompt; - printf "\tObjective Caml Debugger version %s@.@." Config.version; - Config.load_path := !default_load_path; - toplevel_loop (); (* Toplevel. *) - kill_program (); - exit 0 - with Toplevel -> - exit 2 - -let _ = - Printexc.catch (Unix.handle_unix_error main) () diff --git a/debugger/parameters.ml b/debugger/parameters.ml deleted file mode 100644 index 67078b2fc3..0000000000 --- a/debugger/parameters.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Miscellaneous parameters *) - -open Primitives -open Config -open Misc - -let program_loaded = ref false -let program_name = ref "" -let socket_name = ref "" -let arguments = ref "" - -let default_load_path = - ref [ Filename.current_dir_name; Config.standard_library ] - -let add_path dir = - load_path := dir :: except dir !load_path; - Envaux.reset_cache() - -(* Used by emacs ? *) -let emacs = ref false diff --git a/debugger/parameters.mli b/debugger/parameters.mli deleted file mode 100644 index c80d39d124..0000000000 --- a/debugger/parameters.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Miscellaneous parameters *) - -val program_name : string ref -val socket_name : string ref -val arguments : string ref -val default_load_path : string list ref - -val add_path : string -> unit - -(* Used by emacs ? *) -val emacs : bool ref diff --git a/debugger/parser.mly b/debugger/parser.mly deleted file mode 100644 index 6c7b2ddb26..0000000000 --- a/debugger/parser.mly +++ /dev/null @@ -1,239 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */ -/* Objective Caml port by John Malecki and Xavier Leroy */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the Q Public License version 1.0. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -%{ - -open Int64ops -open Primitives -open Input_handling -open Longident -open Parser_aux - -%} - -%token <string> ARGUMENT -%token <string> LIDENT -%token <string> UIDENT -%token <string> OPERATOR -%token <int64> INTEGER -%token STAR /* * */ -%token MINUS /* - */ -%token DOT /* . */ -%token SHARP /* # */ -%token AT /* @ */ -%token DOLLAR /* $ */ -%token BANG /* ! */ -%token LPAREN /* ( */ -%token RPAREN /* ) */ -%token LBRACKET /* [ */ -%token RBRACKET /* ] */ -%token EOL - -%right DOT -%right BANG - -%start argument_list_eol -%type <string list> argument_list_eol - -%start argument_eol -%type <string> argument_eol - -%start integer_list_eol -%type <int list> integer_list_eol - -%start integer_eol -%type <int> integer_eol - -%start int64_eol -%type <int64> int64_eol - -%start integer -%type <int> integer - -%start opt_integer_eol -%type <int option> opt_integer_eol - -%start opt_signed_integer_eol -%type <int option> opt_signed_integer_eol - -%start opt_signed_int64_eol -%type <int64 option> opt_signed_int64_eol - -%start identifier -%type <string> identifier - -%start identifier_eol -%type <string> identifier_eol - -%start identifier_or_eol -%type <string option> identifier_or_eol - -%start opt_identifier -%type <string option> opt_identifier - -%start opt_identifier_eol -%type <string option> opt_identifier_eol - -%start expression_list_eol -%type <Parser_aux.expression list> expression_list_eol - -%start break_argument_eol -%type <Parser_aux.break_arg> break_argument_eol - -%start list_arguments_eol -%type <string option * int option * int option> list_arguments_eol - -%start end_of_line -%type <unit> end_of_line - -%start longident_eol -%type <Longident.t> longident_eol - -%% - -/* Raw arguments */ - -argument_list_eol : - ARGUMENT argument_list_eol - { $1::$2 } - | end_of_line - { [] }; - -argument_eol : - ARGUMENT end_of_line - { $1 }; - -/* Integer */ - -integer_list_eol : - INTEGER integer_list_eol - { (to_int $1) :: $2 } - | end_of_line - { [] }; - -integer_eol : - INTEGER end_of_line - { to_int $1 }; - -int64_eol : - INTEGER end_of_line - { $1 }; - -integer : - INTEGER - { to_int $1 }; - -opt_integer_eol : - INTEGER end_of_line - { Some (to_int $1) } - | end_of_line - { None }; - -opt_int64_eol : - INTEGER end_of_line - { Some $1 } - | end_of_line - { None }; - -opt_signed_integer_eol : - MINUS integer_eol - { Some (- $2) } - | opt_integer_eol - { $1 }; - -opt_signed_int64_eol : - MINUS int64_eol - { Some (Int64.neg $2) } - | opt_int64_eol - { $1 }; - -/* Identifiers and long identifiers */ - -longident : - LIDENT { Lident $1 } - | module_path DOT LIDENT { Ldot($1, $3) } - | OPERATOR { Lident $1 } -; - -module_path : - UIDENT { Lident $1 } - | module_path DOT UIDENT { Ldot($1, $3) } -; - -longident_eol : - longident end_of_line { $1 }; - -identifier : - LIDENT { $1 } - | UIDENT { $1 }; - -identifier_eol : - identifier end_of_line { $1 }; - -identifier_or_eol : - identifier { Some $1 } - | end_of_line { None }; - -opt_identifier : - identifier { Some $1 } - | { None }; - -opt_identifier_eol : - opt_identifier end_of_line { $1 }; - -/* Expressions */ - -expression: - longident { E_ident $1 } - | STAR { E_result } - | DOLLAR INTEGER { E_name (to_int $2) } - | expression DOT INTEGER { E_item($1, (to_int $3)) } - | expression DOT LBRACKET INTEGER RBRACKET { E_item($1, (to_int $4)) } - | expression DOT LPAREN INTEGER RPAREN { E_item($1, (to_int $4)) } - | expression DOT LIDENT { E_field($1, $3) } - | BANG expression { E_field($2, "contents") } - | LPAREN expression RPAREN { $2 } -; - -/* Lists of expressions */ - -expression_list_eol : - expression expression_list_eol { $1::$2 } - | end_of_line { [] } -; - -/* Arguments for breakpoint */ - -break_argument_eol : - end_of_line { BA_none } - | integer_eol { BA_pc $1 } - | expression end_of_line { BA_function $1 } - | AT opt_identifier INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} - | AT opt_identifier SHARP integer_eol { BA_pos2 ($2, $4) } -; - -/* Arguments for list */ - -list_arguments_eol : - opt_identifier integer opt_integer_eol - { ($1, Some $2, $3) } - | opt_identifier_eol - { ($1, None, None) }; - -/* End of line */ - -end_of_line : - EOL { stop_user_input () } -; diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli deleted file mode 100644 index 7ea63fb8c2..0000000000 --- a/debugger/parser_aux.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*open Globals*) - -open Primitives - -type expression = - E_ident of Longident.t (* x or Mod.x *) - | E_name of int (* $xxx *) - | E_item of expression * int (* x.1 x.[2] x.(3) *) - | E_field of expression * string (* x.lbl !x *) - | E_result - -type break_arg = - BA_none (* break *) - | BA_pc of int (* break PC *) - | BA_function of expression (* break FUNCTION *) - | BA_pos1 of string option * int * int option - (* break @ [MODULE] LINE [POS] *) - | BA_pos2 of string option * int (* break @ [MODULE] # OFFSET *) - diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml deleted file mode 100644 index a04dcae5b0..0000000000 --- a/debugger/pattern_matching.ml +++ /dev/null @@ -1,251 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Simple pattern matching **********************) - -open Debugger_config -(*open Primitives*) -open Misc -(*open Const*) -(*open Globals*) -(*open Builtins*) -open Typedtree -(*open Modules*) -(*open Symtable*) -(*open Value*) -open Parser_aux - -(* -let rec find_constr tag = function - [] -> - fatal_error "find_constr: unknown constructor for this type" - | constr::rest -> - match constr.info.cs_tag with - ConstrRegular(t, _) -> - if t == tag then constr else find_constr tag rest - | ConstrExtensible _ -> - fatal_error "find_constr: extensible" - -let find_exception tag = - let (qualid, stamp) = get_exn_of_num tag in - let rec select_exn = function - [] -> - raise Not_found - | constr :: rest -> - match constr.info.cs_tag with - ConstrExtensible(_,st) -> - if st == stamp then constr else select_exn rest - | ConstrRegular(_,_) -> - fatal_error "find_exception: regular" in - select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id) -*) - -let error_matching () = - prerr_endline "Pattern matching failed"; - raise Toplevel - -(* -let same_name {qualid = name1} = - function - GRname name2 -> - (name2 = "") || (name1.id = name2) - | GRmodname name2 -> - name1 = name2 - -let check_same_constr constr constr2 = - try - if not (same_name constr constr2) then - error_matching () - with - Desc_not_found -> - prerr_endline "Undefined constructor."; - raise Toplevel -*) - -let rec pattern_matching pattern obj ty = - match pattern with - P_dummy -> - [] - | P_variable var -> - [var, obj, ty] - | _ -> - match (Ctype.repr ty).desc with - Tvar | Tarrow _ -> - error_matching () - | Ttuple(ty_list) -> - (match pattern with - P_tuple pattern_list -> - pattern_matching_list pattern_list obj ty_list - | P_nth (n, patt) -> - if n >= List.length ty_list then - (prerr_endline "Out of range."; raise Toplevel); - pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n) - | _ -> - error_matching ()) - | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list -> - (match pattern with - P_list pattern_list -> - let (last, list) = - it_list - (fun (current, list) pattern -> - if value_tag current = 0 then error_matching (); - (Debugcom.get_field current 1, - (pattern, Debugcom.get_field current 0)::list)) - (obj, []) - pattern_list - in - if value_tag last <> 0 then error_matching (); - flat_map - (function (x, y) -> pattern_matching x y ty_arg) - (rev list) - | P_nth (n, patt) -> - let rec find k current = - if value_tag current = 0 then - (prerr_endline "Out of range."; raise Toplevel); - if k = 0 then - pattern_matching patt (Debugcom.get_field current 0) ty_arg - else - find (k - 1) (Debugcom.get_field current 1) - in - find n obj - | P_concat (pattern1, pattern2) -> - if value_tag obj == 0 then error_matching (); - (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg) - @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty) - | _ -> - error_matching ()) - | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect -> - (match pattern with - P_nth (n, patt) -> - if n >= value_size obj then - (prerr_endline "Out of range."; raise Toplevel); - pattern_matching patt (Debugcom.get_field obj n) ty_arg - | _ -> - error_matching ()) - | Tconstr(cstr, ty_list) -> - (match cstr.info.ty_abbr with - Tabbrev(params, body) -> - pattern_matching pattern obj (expand_abbrev params body ty_list) - | _ -> - match_concrete_type pattern obj cstr ty ty_list) - -and match_concrete_type pattern obj cstr ty ty_list = - let typ_descr = - type_descr_of_type_constr cstr in - match typ_descr.info.ty_desc with - Abstract_type -> - error_matching () - | Variant_type constr_list -> - let tag = value_tag obj in - (try - let constr = - if same_type_constr cstr constr_type_exn then - find_exception tag - else - find_constr tag constr_list - in - let (ty_res, ty_arg) = - type_pair_instance (constr.info.cs_res, constr.info.cs_arg) - in - filter (ty_res, ty); - match constr.info.cs_kind with - Constr_constant -> - error_matching () - | Constr_regular -> - (match pattern with - P_constr (constr2, patt) -> - check_same_constr constr constr2; - pattern_matching patt (Debugcom.get_field obj 0) ty_arg - | _ -> - error_matching ()) - | Constr_superfluous n -> - (match pattern with - P_constr (constr2, patt) -> - check_same_constr constr constr2; - (match patt with - P_tuple pattern_list -> - pattern_matching_list - pattern_list - obj - (filter_product n ty_arg) - | P_nth (n2, patt) -> - let ty_list = filter_product n ty_arg in - if n2 >= n then - (prerr_endline "Out of range."; - raise Toplevel); - pattern_matching - patt - (Debugcom.get_field obj n2) - (List.nth ty_list n2) - | P_variable var -> - [var, - obj, - {typ_desc = Tproduct (filter_product n ty_arg); - typ_level = generic}] - | P_dummy -> - [] - | _ -> - error_matching ()) - | _ -> - error_matching ()) - with - Not_found -> - error_matching () - | Unify -> - fatal_error "pattern_matching: types should match") - | Record_type label_list -> - let match_field (label, patt) = - let lbl = - try - primitives__find - (function l -> same_name l label) - label_list - with Not_found -> - prerr_endline "Label not found."; - raise Toplevel - in - let (ty_res, ty_arg) = - type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg) - in - (try - filter (ty_res, ty) - with Unify -> - fatal_error "pattern_matching: types should match"); - pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg - in - (match pattern with - P_record pattern_label_list -> - flat_map match_field pattern_label_list - | _ -> - error_matching ()) - | Abbrev_type(_,_) -> - fatal_error "pattern_matching: abbrev type" - -and pattern_matching_list pattern_list obj ty_list = - let val_list = - try - pair__combine (pattern_list, ty_list) - with - Invalid_argument _ -> error_matching () - in - flat_map - (function (x, y, z) -> pattern_matching x y z) - (rev - (snd - (it_list - (fun (num, list) (pattern, typ) -> - (num + 1, (pattern, Debugcom.get_field obj num, typ)::list)) - (0, []) - val_list))) diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli deleted file mode 100644 index 3490edef69..0000000000 --- a/debugger/pattern_matching.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Simple pattern matching **********************) - -open Parser_aux - -val pattern_matching : - pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;; diff --git a/debugger/pos.ml b/debugger/pos.ml deleted file mode 100644 index 235de121d0..0000000000 --- a/debugger/pos.ml +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2003 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct;; -open Lexing;; -open Primitives;; -open Source;; - -let get_desc ev = - if ev.ev_char.pos_fname <> "" - then Printf.sprintf "file %s, line %d, character %d" - ev.ev_char.pos_fname ev.ev_char.pos_lnum - (ev.ev_char.pos_cnum - ev.ev_char.pos_bol + 1) - else begin - let filename = source_of_module ev.ev_module in - try - let (start, line) = line_of_pos (get_buffer ev.ev_module) - ev.ev_char.pos_cnum - in - Printf.sprintf "file %s, line %d, character %d" - filename line (ev.ev_char.pos_cnum - start + 1) - with Not_found | Out_of_range -> - Printf.sprintf "file %s, character %d" - filename (ev.ev_char.pos_cnum + 1) - end -;; diff --git a/debugger/pos.mli b/debugger/pos.mli deleted file mode 100644 index e7632e4274..0000000000 --- a/debugger/pos.mli +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2003 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val get_desc : Instruct.debug_event -> string;; diff --git a/debugger/primitives.ml b/debugger/primitives.ml deleted file mode 100644 index 1ad27e8a68..0000000000 --- a/debugger/primitives.ml +++ /dev/null @@ -1,194 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*********************** Basic functions and types *********************) - -(*** Miscellaneous ***) -exception Out_of_range - -let nothing _ = () - -(*** Operations on lists. ***) - -(* Remove an element from a list *) -let except e l = - let rec except_e = function - [] -> [] - | elem::l -> if e = elem then l else elem::except_e l - in except_e l - -(* Position of an element in a list. Head of list has position 0. *) -let index a l = - let rec index_rec i = function - [] -> raise Not_found - | b::l -> if a = b then i else index_rec (i + 1) l - in index_rec 0 l - -(* Remove an element from an association list *) -let assoc_remove lst elem = - let rec remove = - function - [] -> [] - | ((a, _) as c::t) -> - if a = elem then t - else c::(remove t) - in remove lst - -(* Nth element of a list. *) -let rec list_nth p0 p1 = - match (p0,p1) with - ([], _) -> - invalid_arg "list_nth" - | ((a::_), 0) -> - a - | ((_::l), n) -> - list_nth l (n - 1) - -(* Return the `n' first elements of `l' *) -(* ### n l -> l' *) -let rec list_truncate = - fun - p0 p1 -> match (p0,p1) with (0, _) -> [] - | (_, []) -> [] - | (n, (a::l)) -> a::(list_truncate (n - 1) l) - -(* Separe the `n' first elements of `l' and the others *) -(* ### n list -> (first, last) *) -let rec list_truncate2 = - fun - p0 p1 -> match (p0,p1) with (0, l) -> - ([], l) - | (_, []) -> - ([], []) - | (n, (a::l)) -> - let (first, last) = (list_truncate2 (n - 1) l) in - (a::first, last) - -(* Replace x by y in list l *) -(* ### x y l -> l' *) -let list_replace x y = - let rec repl = - function - [] -> [] - | a::l -> - if a == x then y::l - else a::(repl l) - in repl - -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -let filter p = - let rec filter2 = - function - [] -> - [] - | a::l -> - if p a then - a::(filter2 l) - else - filter2 l - in filter2 - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* ### predicate list -> element *) -let find p = - let rec find2 = - function - [] -> - raise Not_found - | a::l -> - if p a then a - else find2 l - in find2 - -(*** Operations on strings. ***) - -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -let string_pos s c = - let i = ref 0 and l = String.length s in - while !i < l && String.get s !i != c do i := !i + 1 done; - if !i = l then raise Not_found; - !i - -(* Remove blanks (spaces and tabs) at beginning and end of a string. *) -let is_space = function - | ' ' | '\t' -> true | _ -> false - -let string_trim s = - let l = String.length s and i = ref 0 in - while - !i < l && is_space (String.get s !i) - do - incr i - done; - let j = ref (l - 1) in - while - !j >= !i && is_space (String.get s !j) - do - decr j - done; - String.sub s !i (!j - !i + 1) - -(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) - -let isprefix s1 s2 = - let l1 = String.length s1 and l2 = String.length s2 in - (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1) - -(* Split a string at the given delimiter char *) - -let split_string sep str = - let rec split i j = - if j >= String.length str then - if i >= j then [] else [String.sub str i (j-i)] - else if str.[j] = sep then - if i >= j - then skip_sep (j+1) - else String.sub str i (j-i) :: skip_sep (j+1) - else - split i (j+1) - and skip_sep j = - if j < String.length str && str.[j] = sep - then skip_sep (j+1) - else split j j - in split 0 0 - -(*** I/O channels ***) - -type io_channel = { - io_in : in_channel; - io_out : out_channel; - io_fd : Unix.file_descr - } - -let io_channel_of_descr fd = { - io_in = Unix.in_channel_of_descr fd; - io_out = Unix.out_channel_of_descr fd; - io_fd = fd - } - -let close_io io_channel = - close_out_noerr io_channel.io_out; - close_in_noerr io_channel.io_in; -;; - -let std_io = { - io_in = stdin; - io_out = stdout; - io_fd = Unix.stdin - } diff --git a/debugger/primitives.mli b/debugger/primitives.mli deleted file mode 100644 index 40effea556..0000000000 --- a/debugger/primitives.mli +++ /dev/null @@ -1,86 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(********************* Basic functions and types ***********************) - -(*** Miscellaneous ***) -val nothing : 'a -> unit - -(*** Types and exceptions. ***) -exception Out_of_range - -(*** Operations on lists. ***) - -(* Remove an element from a list *) -val except : 'a -> 'a list -> 'a list - -(* Position of an element in a list. Head of list has position 0. *) -val index : 'a -> 'a list -> int - -(* Remove on element from an association list. *) -val assoc_remove : ('a * 'b) list -> 'a -> ('a * 'b) list - -(* Nth element of a list. *) -val list_nth : 'a list -> int -> 'a - -(* Return the `n' first elements of `l'. *) -(* ### n l -> l' *) -val list_truncate : int -> 'a list -> 'a list - -(* Separe the `n' first elements of `l' and the others. *) -(* ### n list -> (first, last) *) -val list_truncate2 : int -> 'a list -> 'a list * 'a list - -(* Replace x by y in list l *) -(* ### x y l -> l' *) -val list_replace : 'a -> 'a -> 'a list -> 'a list - -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -val filter : ('a -> bool) -> 'a list -> 'a list - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* Raise `Not_found' if no such element. *) -(* ### predicate list -> element *) -val find : ('a -> bool) -> 'a list -> 'a - -(*** Operations on strings. ***) - -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -val string_pos : string -> char -> int - -(* Remove blanks (spaces and tabs) at beginning and end of a string. *) -val string_trim : string -> string - -(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) -val isprefix : string -> string -> bool - -(* Split a string at the given delimiter char *) -val split_string : char -> string -> string list - -(*** I/O channels ***) - -type io_channel = { - io_in : in_channel; - io_out : out_channel; - io_fd : Unix.file_descr - } - -val io_channel_of_descr : Unix.file_descr -> io_channel -val close_io : io_channel -> unit -val std_io : io_channel diff --git a/debugger/printval.ml b/debugger/printval.ml deleted file mode 100644 index 4fa3055b04..0000000000 --- a/debugger/printval.ml +++ /dev/null @@ -1,111 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* To print values *) - -open Misc -open Obj -open Format -open Parser_aux -open Path -open Types - -(* To name printed and ellipsed values *) - -let named_values = - (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t) -let next_name = ref 1 - -let reset_named_values () = - Hashtbl.clear named_values; - next_name := 1 - -let name_value v ty = - let name = !next_name in - incr next_name; - Hashtbl.add named_values name (v, ty); - name - -let find_named_value name = - Hashtbl.find named_values name - -let check_depth ppf depth obj ty = - if depth <= 0 then begin - let n = name_value obj ty in - Some (Outcometree.Oval_stuff ("$" ^ string_of_int n)) - end else None - -module EvalPath = - struct - type value = Debugcom.Remote_value.t - exception Error - let rec eval_path = function - Pident id -> - begin try - Debugcom.Remote_value.global (Symtable.get_global_position id) - with Symtable.Error _ -> - raise Error - end - | Pdot(root, fieldname, pos) -> - let v = eval_path root in - if not (Debugcom.Remote_value.is_block v) - then raise Error - else Debugcom.Remote_value.field v pos - | Papply(p1, p2) -> - raise Error - let same_value = Debugcom.Remote_value.same - end - -module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath) - -let install_printer path ty ppf fn = - Printer.install_printer path ty - (fun ppf remote_val -> - try - fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val)) - with - Debugcom.Marshalling_error -> - fprintf ppf "<cannot fetch remote object>") - -let remove_printer = Printer.remove_printer - -let max_printer_depth = ref 20 -let max_printer_steps = ref 300 - -let print_exception ppf obj = - let t = Printer.outval_of_untyped_exception obj in - !Oprint.out_value ppf t - -let print_value max_depth env obj (ppf : Format.formatter) ty = - let t = - Printer.outval_of_value !max_printer_steps max_depth - (check_depth ppf) env obj ty in - !Oprint.out_value ppf t - -let print_named_value max_depth exp env obj ppf ty = - let print_value_name ppf = function - | E_ident lid -> - Printtyp.longident ppf lid - | E_name n -> - fprintf ppf "$%i" n - | _ -> - let n = name_value obj ty in - fprintf ppf "$%i" n in - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@." - print_value_name exp - Printtyp.type_expr ty - (print_value max_depth env obj) ty - diff --git a/debugger/printval.mli b/debugger/printval.mli deleted file mode 100644 index d100a4333b..0000000000 --- a/debugger/printval.mli +++ /dev/null @@ -1,33 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format - -val max_printer_depth : int ref -val max_printer_steps : int ref - -val print_exception: formatter -> Debugcom.Remote_value.t -> unit -val print_named_value : - int -> Parser_aux.expression -> Env.t -> - Debugcom.Remote_value.t -> formatter -> Types.type_expr -> - unit - -val reset_named_values : unit -> unit -val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr - -val install_printer : - Path.t -> Types.type_expr -> formatter -> - (formatter -> Obj.t -> unit) -> unit -val remove_printer : Path.t -> unit diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml deleted file mode 100644 index edcf3b1ed7..0000000000 --- a/debugger/program_loading.ml +++ /dev/null @@ -1,114 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Program loading *) - -open Unix -open Misc -open Debugger_config -open Parameters -open Input_handling - -(*** Debugging. ***) - -let debug_loading = ref false - -(*** Load a program. ***) - -(* Function used for launching the program. *) -let launching_func = ref (function () -> ()) - -let load_program () = - !launching_func (); - main_loop () - -(*** Launching functions. ***) - -(* A generic function for launching the program *) -let generic_exec cmdline = function () -> - if !debug_loading then - prerr_endline "Launching program..."; - let child = - try - fork () - with x -> - Unix_tools.report_error x; - raise Toplevel in - match child with - 0 -> - begin try - match fork () with - 0 -> (* Try to detach the process from the controlling terminal, - so that it does not receive SIGINT on ctrl-C. *) - begin try ignore(setsid()) with Invalid_argument _ -> () end; - execv shell [| shell; "-c"; cmdline() |] - | _ -> exit 0 - with x -> - Unix_tools.report_error x; - exit 1 - end - | _ -> - match wait () with - (_, WEXITED 0) -> () - | _ -> raise Toplevel - -(* Execute the program by calling the runtime explicitely *) -let exec_with_runtime = - generic_exec - (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" - !socket_name - runtime_program - !program_name - !arguments) - -(* Excute the program directly *) -let exec_direct = - generic_exec - (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" - !socket_name - !program_name - !arguments) - -(* Ask the user. *) -let exec_manual = - function () -> - print_newline (); - print_string "Waiting for connection..."; - print_string ("(the socket is " ^ !socket_name ^ ")"); - print_newline () - -(*** Selection of the launching function. ***) - -type launching_function = (unit -> unit) - -let loading_modes = - ["direct", exec_direct; - "runtime", exec_with_runtime; - "manual", exec_manual] - -let set_launching_function func = - launching_func := func - -(* Initialization *) - -let _ = - set_launching_function exec_direct - -(*** Connection. ***) - -let connection = ref Primitives.std_io -let connection_opened = ref false diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli deleted file mode 100644 index d1210d1ab0..0000000000 --- a/debugger/program_loading.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*** Debugging. ***) - -val debug_loading : bool ref - -(*** Load program ***) - -(* Function used for launching the program. *) -val launching_func : (unit -> unit) ref - -val load_program : unit -> unit - -type launching_function = (unit -> unit) - -val loading_modes : (string * launching_function) list -val set_launching_function : launching_function -> unit - -(** Connection **) -val connection : Primitives.io_channel ref -val connection_opened : bool ref diff --git a/debugger/program_management.ml b/debugger/program_management.ml deleted file mode 100644 index ec5877fc26..0000000000 --- a/debugger/program_management.ml +++ /dev/null @@ -1,157 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Manage the loading of the program *) - -open Int64ops -open Unix -open Unix_tools -open Debugger_config -open Misc -open Instruct -open Primitives -open Parameters -open Input_handling -open Debugcom -open Program_loading -open Time_travel - -(*** Connection opening and control. ***) - -(* Name of the file if the socket is in the unix domain.*) -let file_name = ref (None : string option) - -(* Default connection handler. *) -let buffer = String.create 1024 -let control_connection pid fd = - if (read fd.io_fd buffer 0 1024) = 0 then - forget_process fd pid - else begin - prerr_string "Garbage data from process "; - prerr_int pid; - prerr_endline "" - end - -(* Accept a connection from another process. *) -let accept_connection continue fd = - let (sock, _) = accept fd.io_fd in - let io_chan = io_channel_of_descr sock in - let pid = input_binary_int io_chan.io_in in - if pid = -1 then begin - let pid' = input_binary_int io_chan.io_in in - new_checkpoint pid' io_chan; - Input_handling.add_file io_chan (control_connection pid'); - continue () - end - else begin - if set_file_descriptor pid io_chan then - Input_handling.add_file io_chan (control_connection pid) - end - -(* Initialize the socket. *) -let open_connection address continue = - try - let (sock_domain, sock_address) = convert_address address in - file_name := - (match sock_address with - ADDR_UNIX file -> - Some file - | _ -> - None); - let sock = socket sock_domain SOCK_STREAM 0 in - (try - bind sock sock_address; - listen sock 3; - connection := io_channel_of_descr sock; - Input_handling.add_file !connection (accept_connection continue); - connection_opened := true - with x -> close sock; raise x) - with - Failure _ -> raise Toplevel - | (Unix_error _) as err -> report_error err; raise Toplevel - -(* Close the socket. *) -let close_connection () = - if !connection_opened then begin - connection_opened := false; - Input_handling.remove_file !connection; - close_io !connection; - match !file_name with - Some file -> - unlink file - | None -> - () - end - -(*** Kill program. ***) -let loaded = ref false - -let kill_program () = - Breakpoints.remove_all_breakpoints (); - History.empty_history (); - kill_all_checkpoints (); - loaded := false; - close_connection () - -let ask_kill_program () = - if not !loaded then - true - else - let answer = yes_or_no "A program is being debugged already. Kill it" in - if answer then - kill_program (); - answer - -(*** Program loading and initializations. ***) - -let initialize_loading () = - if !debug_loading then - prerr_endline "Loading debugging informations..."; - begin try access !program_name [F_OK] - with Unix_error _ -> - prerr_endline "Program not found."; - raise Toplevel; - end; - Symbols.read_symbols !program_name; - if !debug_loading then - prerr_endline "Opening a socket..."; - open_connection !socket_name - (function () -> - go_to _0; - Symbols.set_all_events(); - exit_main_loop ()) - -(* Ensure the program is already loaded. *) -let ensure_loaded () = - if not !loaded then begin - print_string "Loading program... "; - flush Pervasives.stdout; - if !program_name = "" then begin - prerr_endline "No program specified."; - raise Toplevel - end; - try - initialize_loading(); - !launching_func (); - if !debug_loading then - prerr_endline "Waiting for connection..."; - main_loop (); - loaded := true; - prerr_endline "done." - with - x -> - kill_program(); - raise x - end diff --git a/debugger/program_management.mli b/debugger/program_management.mli deleted file mode 100644 index 8e2f28e54e..0000000000 --- a/debugger/program_management.mli +++ /dev/null @@ -1,27 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(*** Program loading and initializations. ***) - -val loaded : bool ref -val ensure_loaded : unit -> unit - -(*** Kill program. ***) -val kill_program : unit -> unit - -(* Ask wether to kill the program or not. *) -(* If yes, kill it. *) -(* Return true iff the program has been killed. *) -val ask_kill_program : unit -> bool diff --git a/debugger/show_information.ml b/debugger/show_information.ml deleted file mode 100644 index 7492ddc2e1..0000000000 --- a/debugger/show_information.ml +++ /dev/null @@ -1,94 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Instruct -open Format -open Primitives -open Debugcom -open Checkpoints -open Events -open Symbols -open Frames -open Show_source -open Breakpoints - -(* Display information about the current event. *) -let show_current_event ppf = - fprintf ppf "Time : %Li" (current_time ()); - (match current_pc () with - | Some pc -> - fprintf ppf " - pc : %i" pc - | _ -> ()); - update_current_event (); - reset_frame (); - match current_report () with - | None -> - fprintf ppf "@.Beginning of program.@."; - show_no_point () - | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} -> - let (mdle, point) = current_point () in - fprintf ppf " - module %s@." mdle; - (match breakpoints_at_pc pc with - | [] -> - () - | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint - | breakpoints -> - fprintf ppf "Breakpoints : %a@." - (fun ppf l -> - List.iter - (function x -> fprintf ppf "%i " x) l) - (List.sort compare breakpoints)); - show_point mdle point (current_event_is_before ()) true - | Some {rep_type = Exited} -> - fprintf ppf "@.Program exit.@."; - show_no_point () - | Some {rep_type = Uncaught_exc} -> - fprintf ppf - "@.Program end.@.\ - @[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'. *) - Misc.fatal_error "Show_information.show_current_event" - -(* Display short information about one frame. *) - -let show_one_frame framenum ppf event = - fprintf ppf "#%i Pc : %i %s char %i@." - framenum event.ev_pos event.ev_module event.ev_char.Lexing.pos_cnum - -(* Display information about the current frame. *) -(* --- `select frame' must have succeded before calling this function. *) -let show_current_frame ppf selected = - match !selected_event with - | None -> - 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 - | [] -> () - | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint - | breakpoints -> - fprintf ppf "Breakpoints : %a@." - (fun ppf l -> - List.iter (function x -> fprintf ppf "%i " x) l) - (List.sort compare breakpoints); - end; - show_point sel_ev.ev_module sel_ev.ev_char.Lexing.pos_cnum - (selected_event_is_before ()) selected diff --git a/debugger/show_information.mli b/debugger/show_information.mli deleted file mode 100644 index 3069f93321..0000000000 --- a/debugger/show_information.mli +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format;; - -(* Display information about the current event. *) -val show_current_event : formatter -> unit;; - -(* Display information about the current frame. *) -(* --- `select frame' must have succeded before calling this function. *) -val show_current_frame : formatter -> bool -> unit;; - -(* Display short information about one frame. *) -val show_one_frame : int -> formatter -> Instruct.debug_event -> unit diff --git a/debugger/show_source.ml b/debugger/show_source.ml deleted file mode 100644 index dd798cd5c8..0000000000 --- a/debugger/show_source.ml +++ /dev/null @@ -1,79 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Debugger_config -open Parameters -open Misc -open Primitives -open Source -open Printf - -(* Print a line; return the beginning of the next line *) -let print_line buffer line_number start point before = - let next = next_linefeed buffer start - and content = buffer_content buffer - in - printf "%i " line_number; - if point <= next && point >= start then - (print_string (String.sub content start (point - start)); - print_string (if before then event_mark_before else event_mark_after); - print_string (String.sub content point (next - point))) - else - print_string (String.sub content start (next - start)); - print_newline (); - next - -(* Tell Emacs we are nowhere in the source. *) -let show_no_point () = - if !emacs then printf "\026\026H\n" - -(* Print the line containing the point *) -let show_point mdle point before selected = - if !emacs && selected then - begin try - let source = source_of_module mdle in - printf "\026\026M%s:%i" source point; - printf "%s\n" (if before then ":before" else ":after") - with - Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ "."); - show_no_point () - end - else - begin try - let buffer = get_buffer mdle in - let (start, line_number) = line_of_pos buffer point in - ignore(print_line buffer line_number start point before) - with - Out_of_range -> (* line_of_pos *) - prerr_endline "Position out of range." - | Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ ".") - end - -(* Display part of the source. *) -let show_listing mdle start stop point before = - try - let buffer = get_buffer mdle in - let rec aff (line_start, line_number) = - if line_number <= stop then - aff (print_line buffer line_number line_start point before + 1, line_number + 1) - in - aff (pos_of_line buffer start) - with - Out_of_range -> (* pos_of_line *) - prerr_endline "Position out of range." - | Not_found -> (* get_buffer *) - prerr_endline ("No source file for " ^ mdle ^ ".") diff --git a/debugger/show_source.mli b/debugger/show_source.mli deleted file mode 100644 index 29f2f8c67e..0000000000 --- a/debugger/show_source.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Print the line containing the point *) -val show_point : string -> int -> bool -> bool -> unit;; - -(* Tell Emacs we are nowhere in the source. *) -val show_no_point : unit -> unit;; - -(* Display part of the source. *) -val show_listing : string -> int -> int -> int -> bool -> unit;; diff --git a/debugger/source.ml b/debugger/source.ml deleted file mode 100644 index f937c782a0..0000000000 --- a/debugger/source.ml +++ /dev/null @@ -1,153 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Source management ****************************) - -open Misc -open Primitives - -(*** Conversion function. ***) - -let source_of_module mdle = - find_in_path_uncap !Config.load_path (mdle ^ ".ml") - -(*** Buffer cache ***) - -(* Buffer and cache (to associate lines and positions in the buffer). *) -type buffer = string * (int * int) list ref - -let buffer_max_count = ref 10 - -let cache_size = 30 - -let buffer_list = - ref ([] : (string * buffer) list) - -let flush_buffer_list () = - buffer_list := [] - -let get_buffer mdle = - try List.assoc mdle !buffer_list with - Not_found -> - let inchan = open_in_bin (source_of_module mdle) in - let (content, _) as buffer = - (String.create (in_channel_length inchan), ref []) - in - unsafe_really_input inchan content 0 (in_channel_length inchan); - buffer_list := - (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); - buffer - -let buffer_content = - (fst : buffer -> string) - -let buffer_length x = - String.length (buffer_content x) - -(*** Position conversions. ***) - -type position = int * int - -(* Insert a new pair (position, line) in the cache of the given buffer. *) -let insert_pos buffer ((position, line) as pair) = - let rec new_list = - function - [] -> - [(position, line)] - | ((pos, lin) as a::l) as l' -> - if lin < line then - pair::l' - else if lin = line then - l' - else - a::(new_list l) - in - let buffer_cache = snd buffer in - buffer_cache := new_list !buffer_cache - -(* Position of the next linefeed after `pos'. *) -(* Position just after the buffer end if no linefeed found. *) -(* Raise `Out_of_range' if already there. *) -let next_linefeed (buffer, _) pos = - let len = String.length buffer in - if pos >= len then - raise Out_of_range - else - let rec search p = - if p = len || String.get buffer p = '\n' then - p - else - search (succ p) - in - search pos - -(* Go to next line. *) -let next_line buffer (pos, line) = - (next_linefeed buffer pos + 1, line + 1) - -(* Convert a position in the buffer to a line number. *) -let line_of_pos buffer position = - let rec find = - function - | [] -> - if position < 0 then - raise Out_of_range - else - (0, 1) - | ((pos, line) as pair)::l -> - if pos > position then - find l - else - pair - and find_line previous = - let (pos, line) as next = next_line buffer previous in - if pos <= position then - find_line next - else - previous - in - let result = find_line (find !(snd buffer)) in - insert_pos buffer result; - result - -(* Convert a line number to a position. *) -let pos_of_line buffer line = - let rec find = - function - [] -> - if line <= 0 then - raise Out_of_range - else - (0, 1) - | ((pos, lin) as pair)::l -> - if lin > line then - find l - else - pair - and find_pos previous = - let (_, lin) as next = next_line buffer previous in - if lin <= line then - find_pos next - else - previous - in - let result = find_pos (find !(snd buffer)) in - insert_pos buffer result; - result - -(* Convert a coordinate (line / column) into a position. *) -(* --- The first line and column are line 1 and column 1. *) -let point_of_coord buffer line column = - fst (pos_of_line buffer line) + (pred column) diff --git a/debugger/source.mli b/debugger/source.mli deleted file mode 100644 index cfd5fe0705..0000000000 --- a/debugger/source.mli +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************ Source management ****************************) - -(*** Conversion function. ***) - -val source_of_module: string -> string - -(*** buffer cache ***) - -type buffer - -val buffer_max_count : int ref - -val flush_buffer_list : unit -> unit - -val get_buffer : string -> buffer - -val buffer_content : buffer -> string -val buffer_length : buffer -> int - -(*** Position conversions. ***) - -(* Pair (position, line) where `position' is the position in character of *) -(* the beginning of the line (first character is 0) and `line' is its *) -(* number (first line number is 1). *) -type position = int * int - -(* Position of the next linefeed after `pos'. *) -(* Position just after the buffer end if no linefeed found. *) -(* Raise `Out_of_range' if already there. *) -val next_linefeed : buffer -> int -> int - -(* Go to next line. *) -val next_line : buffer -> position -> position - -(* Convert a position in the buffer to a line number. *) -val line_of_pos : buffer -> int -> position - -(* Convert a line number to a position. *) -val pos_of_line : buffer -> int -> position - -(* Convert a coordinate (line / column) into a position. *) -(* --- The first line and column are line 1 and column 1. *) -val point_of_coord : buffer -> int -> int -> int diff --git a/debugger/symbols.ml b/debugger/symbols.ml deleted file mode 100644 index 031bec6402..0000000000 --- a/debugger/symbols.ml +++ /dev/null @@ -1,169 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Handling of symbol tables (globals and events) *) - -open Instruct -open Debugger_config (* Toplevel *) - -let modules = - ref ([] : string list) - -let events = - ref ([] : debug_event list) -let events_by_pc = - (Hashtbl.create 257 : (int, debug_event) Hashtbl.t) -let events_by_module = - (Hashtbl.create 17 : (string, debug_event array) Hashtbl.t) -let all_events_by_module = - (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t) - -let relocate_event orig ev = - ev.ev_pos <- orig + ev.ev_pos; - match ev.ev_repr with - Event_parent repr -> repr := ev.ev_pos - | _ -> () - -let read_symbols' bytecode_file = - let ic = open_in_bin bytecode_file in - begin try - Bytesections.read_toc ic; - ignore(Bytesections.seek_section ic "SYMB"); - with Bytesections.Bad_magic_number | Not_found -> - prerr_string bytecode_file; prerr_endline " is not a bytecode file."; - raise Toplevel - end; - Symtable.restore_state (input_value ic); - begin try - ignore (Bytesections.seek_section ic "DBUG") - with Not_found -> - prerr_string bytecode_file; prerr_endline " has no debugging info."; - raise Toplevel - end; - let num_eventlists = input_binary_int ic in - let eventlists = ref [] in - for i = 1 to num_eventlists do - let orig = input_binary_int ic in - let evl = (input_value ic : debug_event list) in - (* Relocate events in event list *) - List.iter (relocate_event orig) evl; - eventlists := evl :: !eventlists - done; - close_in_noerr ic; - !eventlists - -let read_symbols bytecode_file = - let all_events = read_symbols' bytecode_file in - - modules := []; events := []; - Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; - Hashtbl.clear all_events_by_module; - - List.iter - (fun evl -> - List.iter - (fun ev -> - events := ev :: !events; - Hashtbl.add events_by_pc ev.ev_pos ev) - evl) - all_events; - - List.iter - (function - [] -> () - | ev :: _ as evl -> - let md = ev.ev_module in - let cmp ev1 ev2 = compare ev1.ev_char.Lexing.pos_cnum - ev2.ev_char.Lexing.pos_cnum - in - let sorted_evl = List.sort cmp evl in - modules := md :: !modules; - Hashtbl.add all_events_by_module md sorted_evl; - let real_evl = - Primitives.filter - (function - {ev_kind = Event_pseudo} -> false - | _ -> true) - sorted_evl - in - Hashtbl.add events_by_module md (Array.of_list real_evl)) - all_events - -let any_event_at_pc pc = - 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 - -let set_event_at_pc pc = - try ignore(event_at_pc pc); Debugcom.set_event pc - with Not_found -> () - -(* List all events in module *) -let events_in_module mdle = - try - Hashtbl.find all_events_by_module mdle - with Not_found -> - [] - -(* Binary search of event at or just after char *) -let find_event ev char = - let rec bsearch lo hi = - if lo >= hi then begin - if ev.(hi).ev_char.Lexing.pos_cnum < char then raise Not_found; - hi - end else begin - let pivot = (lo + hi) / 2 in - let e = ev.(pivot) in - if char <= e.ev_char.Lexing.pos_cnum then bsearch lo pivot - else bsearch (pivot + 1) hi - end - in - bsearch 0 (Array.length ev - 1) - -(* 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) - -(* 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 - 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 - ev.(pos - 1).ev_char.Lexing.pos_cnum - <= ev.(pos).ev_char.Lexing.pos_cnum - char - then ev.(pos - 1) - else ev.(pos) - with Not_found -> - let pos = Array.length ev - 1 in - if pos < 0 then raise Not_found; - ev.(pos) - -(* Flip "event" bit on all instructions *) -let set_all_events () = - Hashtbl.iter - (fun pc ev -> - match ev.ev_kind with - Event_pseudo -> () - | _ -> Debugcom.set_event ev.ev_pos) - events_by_pc diff --git a/debugger/symbols.mli b/debugger/symbols.mli deleted file mode 100644 index 0cb1e2e573..0000000000 --- a/debugger/symbols.mli +++ /dev/null @@ -1,44 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Modules used by the program. *) -val modules : string list ref - -(* Read debugging info from executable file *) -val read_symbols : string -> unit - -(* Flip "event" bit on all instructions *) -val set_all_events : unit -> 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 - -(* Return event at given PC, or raise Not_found *) -val event_at_pc : int -> Instruct.debug_event -(* Set event at given PC *) -val set_event_at_pc : int -> unit - -(* List the events in `module'. *) -val events_in_module : string -> Instruct.debug_event list - -(* First event after the given position. *) -(* --- Raise `Not_found' if no such event. *) -val event_at_pos : string -> int -> Instruct.debug_event - -(* Closest event from given position. *) -(* --- Raise `Not_found' if no such event. *) -val event_near_pos : string -> int -> Instruct.debug_event - diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml deleted file mode 100644 index eb98f1059c..0000000000 --- a/debugger/time_travel.ml +++ /dev/null @@ -1,642 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Time travel ******************************) - -open Int64ops -open Instruct -open Events -open Debugcom -open Primitives -open Checkpoints -open Breakpoints -open Trap_barrier -open Input_handling -open Debugger_config -open Program_loading - -exception Current_checkpoint_lost - -let remove_1st key list = - let rec remove = - function - [] -> [] - | a::l -> if a == key then l else a::(remove l) - in - remove list - -(*** Debugging. ***) - -let debug_time_travel = ref false - -(*** Internal utilities. ***) - -(* Insert a checkpoint in the checkpoint list. - * Raise `Exit' if there is already a checkpoint at the same time. - *) -let insert_checkpoint ({c_time = time} as checkpoint) = - let rec traverse = - function - [] -> [checkpoint] - | (({c_time = t} as a)::l) as l' -> - if t > time then - a::(traverse l) - else if t = time then - raise Exit - else - checkpoint::l' - in - checkpoints := traverse !checkpoints - -(* Remove a checkpoint from the checkpoint list. - * --- No error if not found. - *) -let remove_checkpoint checkpoint = - checkpoints := remove_1st checkpoint !checkpoints - -(* Wait for the process used by `checkpoint' to connect. - * --- Usually not called (the process is already connected). - *) -let wait_for_connection checkpoint = - try - Exec.unprotect - (function () -> - let old_controller = Input_handling.current_controller !connection in - execute_with_other_controller - (function - fd -> - old_controller fd; - if checkpoint.c_valid = true then - exit_main_loop ()) - !connection - main_loop) - with - Sys.Break -> - checkpoint.c_parent <- root; - remove_checkpoint checkpoint; - checkpoint.c_pid <- -1; - raise Sys.Break - -(* Select a checkpoint as current. *) -let set_current_checkpoint checkpoint = - if !debug_time_travel then - prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid)); - if not checkpoint.c_valid then - wait_for_connection checkpoint; - current_checkpoint := checkpoint; - set_current_connection checkpoint.c_fd - -(* Kill `checkpoint'. *) -let kill_checkpoint checkpoint = - if !debug_time_travel then - prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid)); - if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *) - (if not checkpoint.c_valid then - wait_for_connection checkpoint; - stop checkpoint.c_fd; - if checkpoint.c_parent.c_pid > 0 then - wait_child checkpoint.c_parent.c_fd; - checkpoint.c_parent <- root; - close_io checkpoint.c_fd; - remove_file checkpoint.c_fd; - remove_checkpoint checkpoint); - checkpoint.c_pid <- -1 (* Don't exist anymore *) - -(*** Cleaning the checkpoint list. ***) - -(* Separe checkpoints before (<=) and after (>) `t'. *) -(* ### t checkpoints -> (after, before) *) -let cut t = - let rec cut_t = - function - [] -> ([], []) - | ({c_time = t'} as a::l) as l' -> - if t' <= t then - ([], l') - else - let (b, e) = cut_t l in - (a::b, e) - in - cut_t - -(* Partition the checkpoints list. *) -let cut2 t0 t l = - let rec cut2_t0 t = - function - [] -> [] - | l -> - let (after, before) = cut (t0 -- t -- _1) l in - let l = cut2_t0 (t ++ t) before in - after::l - in - let (after, before) = cut (t0 -- _1) l in - after::(cut2_t0 t before) - -(* Separe first elements and last element of a list of checkpoint. *) -let chk_merge2 cont = - let rec chk_merge2_cont = - function - [] -> cont - | [a] -> - let (accepted, rejected) = cont in - (a::accepted, rejected) - | a::l -> - let (accepted, rejected) = chk_merge2_cont l in - (accepted, a::rejected) - in chk_merge2_cont - -(* Separe the checkpoint list. *) -(* ### list -> accepted * rejected *) -let rec chk_merge = - function - [] -> ([], []) - | l::tail -> - chk_merge2 (chk_merge tail) l - -let new_checkpoint_list checkpoint_count accepted rejected = - if List.length accepted >= checkpoint_count then - let (k, l) = list_truncate2 checkpoint_count accepted in - (k, l @ rejected) - else - let (k, l) = - list_truncate2 (checkpoint_count - List.length accepted) rejected - in - (List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k, - l) - -(* Clean the checkpoint list. *) -(* Reference time is `time'. *) -let clean_checkpoints time checkpoint_count = - let (after, before) = cut time !checkpoints in - let (accepted, rejected) = - chk_merge (cut2 time !checkpoint_small_step before) - in - let (kept, lost) = - new_checkpoint_list checkpoint_count accepted after - in - List.iter kill_checkpoint (lost @ rejected); - checkpoints := kept - -(*** Internal functions for moving. ***) - -(* Find the first checkpoint before (or at) `time'. - * Ask for reloading the program if necessary. - *) -let find_checkpoint_before time = - let rec find = - function - [] -> - print_string "Can't go that far in the past !"; print_newline (); - if yes_or_no "Reload program" then begin - load_program (); - find !checkpoints - end - else - raise Toplevel - | { c_time = t } as a::l -> - if t > time then - find l - else - a - in find !checkpoints - -(* Make a copy of the current checkpoint and clean the checkpoint list. *) -(* --- The new checkpoint in not put in the list. *) -let duplicate_current_checkpoint () = - let checkpoint = !current_checkpoint in - if not checkpoint.c_valid then - wait_for_connection checkpoint; - let new_checkpoint = (* Ghost *) - {c_time = checkpoint.c_time; - c_pid = 0; - c_fd = checkpoint.c_fd; - c_valid = false; - c_report = checkpoint.c_report; - c_state = C_stopped; - c_parent = checkpoint; - c_breakpoint_version = checkpoint.c_breakpoint_version; - c_breakpoints = checkpoint.c_breakpoints; - c_trap_barrier = checkpoint.c_trap_barrier} - in - checkpoints := list_replace checkpoint new_checkpoint !checkpoints; - set_current_checkpoint checkpoint; - clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1); - if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *) - (match do_checkpoint () with (* Duplicate checkpoint *) - Checkpoint_done pid -> - (new_checkpoint.c_pid <- pid; - if !debug_time_travel then - prerr_endline ("Waiting for connection : " ^ (string_of_int pid))) - | Checkpoint_failed -> - prerr_endline - "A fork failed. Reducing maximum number of checkpoints."; - checkpoint_max_count := List.length !checkpoints - 1; - remove_checkpoint new_checkpoint) - -(* Was the movement interrupted ? *) -(* --- An exception could have been used instead, *) -(* --- but it is not clear where it should be caught. *) -(* --- For instance, it should not be caught in `step' *) -(* --- (as `step' is used in `next_1'). *) -(* --- On the other side, other modules does not need to know *) -(* --- about this exception. *) -let interrupted = ref false - -(* Informations about last breakpoint encountered *) -let last_breakpoint = ref None - -(* Ensure we stop on an event. *) -let rec stop_on_event report = - match report with - {rep_type = Breakpoint; rep_program_pointer = pc; - rep_stack_pointer = sp} -> - last_breakpoint := Some (pc, sp); - update_current_event (); - begin match !current_event with - None -> find_event () - | Some _ -> () - end - | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} -> - (* No event at current position. *) - find_event () - | _ -> - () - -and find_event () = - if !debug_time_travel then begin - print_string "Searching next event..."; - print_newline () - end; - let report = do_go _1 in - !current_checkpoint.c_report <- Some report; - stop_on_event report - -(* Internal function for running debugged program. - * Requires `duration > 0'. - *) -let internal_step duration = - match current_report () with - Some {rep_type = Exited | Uncaught_exc} -> () - | _ -> - Exec.protect - (function () -> - if !make_checkpoints then - duplicate_current_checkpoint () - else - remove_checkpoint !current_checkpoint; - update_breakpoints (); - update_trap_barrier (); - !current_checkpoint.c_state <- C_running duration; - let report = do_go duration in - !current_checkpoint.c_report <- Some report; - !current_checkpoint.c_state <- C_stopped; - if report.rep_type = Event then begin - !current_checkpoint.c_time <- - !current_checkpoint.c_time ++ duration; - interrupted := false; - last_breakpoint := None - end - else begin - !current_checkpoint.c_time <- - !current_checkpoint.c_time ++ duration - -- (Int64.of_int report.rep_event_count) ++ _1; - interrupted := true; - last_breakpoint := None; - stop_on_event report - end; - (try - insert_checkpoint !current_checkpoint - with - Exit -> - kill_checkpoint !current_checkpoint; - set_current_checkpoint - (find_checkpoint_before (current_time ())))); - if !debug_time_travel then begin - print_string "Checkpoints : pid(time)"; print_newline (); - List.iter - (function {c_time = time; c_pid = pid; c_valid = valid} -> - Printf.printf "%d(%Ld)%s " pid time - (if valid then "" else "(invalid)")) - !checkpoints; - print_newline () - end - -(*** Miscellaneous functions (exported). ***) - -(* Create a checkpoint at time 0 (new program). *) -let new_checkpoint pid fd = - let new_checkpoint = - {c_time = _0; - c_pid = pid; - c_fd = fd; - c_valid = true; - c_report = None; - c_state = C_stopped; - c_parent = root; - c_breakpoint_version = 0; - c_breakpoints = []; - c_trap_barrier = 0} - in - insert_checkpoint new_checkpoint - -(* Set the file descriptor of a checkpoint *) -(* (a new process has connected with the debugger). *) -(* --- Return `true' on success (close the connection otherwise). *) -let set_file_descriptor pid fd = - let rec find = - function - [] -> - prerr_endline "Unexpected connection"; - close_io fd; - false - | ({c_pid = pid'} as checkpoint)::l -> - if pid <> pid' then - find l - else - (checkpoint.c_fd <- fd; - checkpoint.c_valid <- true; - true) - in - if !debug_time_travel then - prerr_endline ("New connection : " ^(string_of_int pid)); - find (!current_checkpoint::!checkpoints) - -(* Kill all the checkpoints. *) -let kill_all_checkpoints () = - List.iter kill_checkpoint (!current_checkpoint::!checkpoints) - -(* Kill a checkpoint without killing the process. *) -(* (used when connection with the process is lost). *) -(* --- Assume that the checkpoint is valid. *) -let forget_process fd pid = - let checkpoint = - find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) - in - Printf.eprintf "Lost connection with process %d" pid; - if checkpoint = !current_checkpoint then begin - Printf.eprintf " (active process)\n"; - match !current_checkpoint.c_state with - C_stopped -> - Printf.eprintf "at time %Ld" !current_checkpoint.c_time - | C_running duration -> - Printf.eprintf "between time %Ld and time %Ld" - !current_checkpoint.c_time - (!current_checkpoint.c_time ++ duration) - end; - Printf.eprintf "\n"; flush stderr; - Input_handling.remove_file fd; - close_io checkpoint.c_fd; - remove_file checkpoint.c_fd; - remove_checkpoint checkpoint; - checkpoint.c_pid <- -1; (* Don't exist anymore *) - if checkpoint.c_parent.c_pid > 0 then - wait_child checkpoint.c_parent.c_fd; - if checkpoint = !current_checkpoint then - raise Current_checkpoint_lost - -(* Try to recover when the current checkpoint is lost. *) -let recover () = - set_current_checkpoint - (find_checkpoint_before (current_time ())) - -(*** Simple movements. ***) - -(* Forward stepping. Requires `duration >= 0'. *) -let rec step_forward duration = - if duration > !checkpoint_small_step then begin - let first_step = - if duration > !checkpoint_big_step then - !checkpoint_big_step - else - !checkpoint_small_step - in - internal_step first_step; - if not !interrupted then - step_forward (duration -- first_step) - end - else if duration != _0 then - internal_step duration - -(* Go to time `time' from current checkpoint (internal). *) -let internal_go_to time = - let duration = time -- (current_time ()) in - if duration > _0 then - execute_without_breakpoints (function () -> step_forward duration) - -(* Move to a given time. *) -let go_to time = - let checkpoint = find_checkpoint_before time in - set_current_checkpoint checkpoint; - internal_go_to time - -(* Return the time of the last breakpoint *) -(* between current time and `max_time'. *) -let rec find_last_breakpoint max_time = - let rec find break = - let time = current_time () in - step_forward (max_time -- time); - match !last_breakpoint, !temporary_breakpoint_position with - (Some _, _) when current_time () < max_time -> - find !last_breakpoint - | (Some (pc, _), Some pc') when pc = pc' -> - (max_time, !last_breakpoint) - | _ -> - (time, break) - in - find - (match current_pc_sp () with - (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 = - let - {c_time = t} as checkpoint = find_checkpoint_before (pre64 time_max) - in - go_to (max time t); - let (new_time, break) = find_last_breakpoint time_max in - if break <> None || (new_time <= time) then begin - go_to new_time; - interrupted := break <> None; - last_breakpoint := break - end else - back_to time new_time - -(* Backward stepping. *) -(* --- Assume duration > 1 *) -let step_backward duration = - let time = current_time () in - if time > _0 then - back_to (max _0 (time -- duration)) time - -(* Run the program from current time. *) -(* Stop at the first breakpoint, or at the end of the program. *) -let rec run () = - internal_step !checkpoint_big_step; - if not !interrupted then - run () - -(* Run backward the program form current time. *) -(* Stop at the first breakpoint, or at the beginning of the program. *) -let back_run () = - if current_time () > _0 then - back_to _0 (current_time ()) - -(* Step in any direction. *) -(* Stop at the first brakpoint, or after `duration' steps. *) -let step duration = - if duration >= _0 then - step_forward duration - else - step_backward (_0 -- duration) - -(*** Next, finish. ***) - -(* Finish current function. *) -let finish () = - update_current_event (); - match !current_event with - None -> - prerr_endline "`finish' not meaningful in outermost frame."; - raise Toplevel - | Some curr_event -> - set_initial_frame(); - let (frame, pc) = up_frame curr_event.ev_stacksize in - if frame < 0 then begin - prerr_endline "`finish' not meaningful in outermost frame."; - raise Toplevel - end; - begin - try ignore(Symbols.any_event_at_pc pc) - with Not_found -> - prerr_endline "Calling function has no debugging information."; - raise Toplevel - end; - exec_with_trap_barrier - frame - (fun () -> - exec_with_temporary_breakpoint - pc - (fun () -> - while - run (); - match !last_breakpoint with - Some (pc', frame') when pc = pc' -> - interrupted := false; - frame <> frame' - | _ -> - false - do - () - done)) - -let next_1 () = - update_current_event (); - match !current_event with - None -> (* Beginning of the program. *) - step _1 - | Some event1 -> - let (frame1, pc1) = initial_frame() in - step _1; - if not !interrupted then begin - update_current_event (); - match !current_event with - None -> () - | Some event2 -> - 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 - then finish() - end - -(* Same as `step' (forward) but skip over function calls. *) -let rec next = - function - 0 -> () - | n -> - next_1 (); - if not !interrupted then - next (n - 1) - -(* Run backward until just before current function. *) -let start () = - update_current_event (); - match !current_event with - None -> - prerr_endline "`start not meaningful in outermost frame."; - raise Toplevel - | Some curr_event -> - let (frame, _) = initial_frame() in - let (frame', pc) = up_frame curr_event.ev_stacksize in - if frame' < 0 then begin - prerr_endline "`start not meaningful in outermost frame."; - raise Toplevel - end; - let nargs = - match - try Symbols.any_event_at_pc pc with Not_found -> - prerr_endline "Calling function has no debugging information."; - raise Toplevel - with - {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 - while - exec_with_temporary_breakpoint pc back_run; - match !last_breakpoint with - Some (pc', frame') when pc = pc' -> - step _minus1; - (not !interrupted) - && - (frame' - nargs > frame - curr_event.ev_stacksize) - | _ -> - false - do - () - done - -let previous_1 () = - update_current_event (); - match !current_event with - None -> (* End of the program. *) - step _minus1 - | Some event1 -> - let (frame1, pc1) = initial_frame() in - step _minus1; - if not !interrupted then begin - update_current_event (); - match !current_event with - None -> () - | Some event2 -> - 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 - then start() - end - -(* Same as `step' (backward) but skip over function calls. *) -let rec previous = - function - 0 -> () - | n -> - previous_1 (); - if not !interrupted then - previous (n - 1) diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli deleted file mode 100644 index 81d01a6678..0000000000 --- a/debugger/time_travel.mli +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Time travel ******************************) - -open Primitives - -exception Current_checkpoint_lost - -val new_checkpoint : int -> io_channel -> unit -val set_file_descriptor : int -> io_channel -> bool -val kill_all_checkpoints : unit -> unit -val forget_process : io_channel -> int -> unit -val recover : unit -> unit - -val go_to : int64 -> unit - -val run : unit -> unit -val back_run : unit -> unit -val step : int64 -> unit -val finish : unit -> unit -val next : int -> unit -val start : unit -> unit -val previous : int -> unit diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml deleted file mode 100644 index dba9c929f7..0000000000 --- a/debugger/trap_barrier.ml +++ /dev/null @@ -1,47 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************** Trap barrier *******************************) - -open Debugcom -open Checkpoints - -let current_trap_barrier = ref 0 - -let install_trap_barrier pos = - current_trap_barrier := pos - -let remove_trap_barrier () = - current_trap_barrier := 0 - -(* Ensure the trap barrier state is up to date in current checkpoint. *) -let update_trap_barrier () = - if !current_checkpoint.c_trap_barrier <> !current_trap_barrier then - Exec.protect - (function () -> - set_trap_barrier !current_trap_barrier; - !current_checkpoint.c_trap_barrier <- !current_trap_barrier) - -(* Execute `funct' with a trap barrier. *) -(* --- Used by `finish'. *) -let exec_with_trap_barrier trap_barrier funct = - try - install_trap_barrier trap_barrier; - funct (); - remove_trap_barrier () - with - x -> - remove_trap_barrier (); - raise x diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli deleted file mode 100644 index 28bba5a3eb..0000000000 --- a/debugger/trap_barrier.mli +++ /dev/null @@ -1,27 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(************************* Trap barrier ********************************) - -val install_trap_barrier : int -> unit - -val remove_trap_barrier : unit -> unit - -(* Ensure the trap barrier state is up to date in current checkpoint. *) -val update_trap_barrier : unit -> unit - -(* Execute `funct' with a trap barrier. *) -(* --- Used by `finish'. *) -val exec_with_trap_barrier : int -> (unit -> unit) -> unit diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml deleted file mode 100644 index 5061bb1ddf..0000000000 --- a/debugger/unix_tools.ml +++ /dev/null @@ -1,141 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(****************** Tools for Unix *************************************) - -open Misc -open Unix -open Primitives - -(*** Convert a socket name into a socket address. ***) -let convert_address address = - try - let n = string_pos address ':' in - let host = String.sub address 0 n - and port = String.sub address (n + 1) (String.length address - n - 1) - in - (PF_INET, - ADDR_INET - ((try inet_addr_of_string host with Failure _ -> - try (gethostbyname host).h_addr_list.(0) with Not_found -> - prerr_endline ("Unknown host : " ^ host); - failwith "Can't convert address"), - (try int_of_string port with Failure _ -> - prerr_endline "The port number should be an integer"; - failwith "Can't convert address"))) - with Not_found -> - (PF_UNIX, ADDR_UNIX address) - -(*** Report a unix error. ***) -let report_error = function - | Unix_error (err, fun_name, arg) -> - prerr_string "Unix error : '"; - prerr_string fun_name; - prerr_string "' failed"; - if String.length arg > 0 then - (prerr_string " on '"; - prerr_string arg; - prerr_string "'"); - prerr_string " : "; - prerr_endline (error_message err) - | _ -> fatal_error "report_error: not a Unix error" - -(* Find program `name' in `PATH'. *) -(* Return the full path if found. *) -(* Raise `Not_found' otherwise. *) -let search_in_path name = - let check name = - try access name [X_OK]; name with Unix_error _ -> raise Not_found - in - if not (Filename.is_implicit name) then - check name - else - let path = Sys.getenv "PATH" in - let length = String.length path in - let rec traverse pointer = - if (pointer >= length) || (path.[pointer] = ':') then - pointer - else - traverse (pointer + 1) - in - let rec find pos = - let pos2 = traverse pos in - let directory = (String.sub path pos (pos2 - pos)) in - let fullname = - if directory = "" then name else directory ^ "/" ^ name - in - try check fullname with - | Not_found -> - if pos2 < length then find (pos2 + 1) - else raise Not_found - in - find 0 - -(* Expand a path. *) -(* ### path -> path' *) -let rec expand_path ch = - let rec subst_variable ch = - try - let pos = string_pos ch '$' in - if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then - (String.sub ch 0 (pos + 1)) - ^ (subst_variable - (String.sub ch (pos + 2) (String.length ch - pos - 2))) - else - (String.sub ch 0 pos) - ^ (subst2 (String.sub ch (pos + 1) (String.length ch - pos - 1))) - with Not_found -> - ch - and subst2 ch = - let suiv = - let i = ref 0 in - while !i < String.length ch && - (let c = ch.[!i] in (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || (c >= '0' && c <= '9') - || c = '_') - do incr i done; - !i - in (Sys.getenv (String.sub ch 0 suiv)) - ^ (subst_variable (String.sub ch suiv (String.length ch - suiv))) - in - let ch = subst_variable ch in - let concat_root nom ch2 = - try Filename.concat (getpwnam nom).pw_dir ch2 - with Not_found -> - "~" ^ nom - in - if ch.[0] = '~' then - try - match string_pos ch '/' with - 1 -> - (let tail = String.sub ch 2 (String.length ch - 2) - in - try Filename.concat (Sys.getenv "HOME") tail - with Not_found -> - concat_root (Sys.getenv "LOGNAME") tail) - | n -> concat_root - (String.sub ch 1 (n - 1)) - (String.sub ch (n + 1) (String.length ch - n - 1)) - with - Not_found -> - expand_path (ch ^ "/") - else ch - -let make_absolute name = - if Filename.is_relative name - then Filename.concat (getcwd ()) name - else name -;; diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli deleted file mode 100644 index b5e4ee6ca4..0000000000 --- a/debugger/unix_tools.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* Objective Caml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(**************************** Tools for Unix ***************************) - -open Unix - -(* Convert a socket name into a socket address. *) -val convert_address : string -> socket_domain * sockaddr - -(* Report an unix error. *) -val report_error : exn -> unit - -(* Find program `name' in `PATH'. *) -(* Return the full path if found. *) -(* Raise `Not_found' otherwise. *) -val search_in_path : string -> string - -(* Path expansion. *) -val expand_path : string -> string - -val make_absolute : string -> string |