diff options
Diffstat (limited to 'ocaml-binary-annot/debugger')
68 files changed, 7130 insertions, 0 deletions
diff --git a/ocaml-binary-annot/debugger/.cvsignore b/ocaml-binary-annot/debugger/.cvsignore new file mode 100644 index 0000000000..45440f86d7 --- /dev/null +++ b/ocaml-binary-annot/debugger/.cvsignore @@ -0,0 +1,6 @@ +lexer.ml +parser.ml +parser.mli +ocamldebug +dynlink.ml +dynlink.mli diff --git a/ocaml-binary-annot/debugger/.depend b/ocaml-binary-annot/debugger/.depend new file mode 100644 index 0000000000..1a04b1eaaa --- /dev/null +++ b/ocaml-binary-annot/debugger/.depend @@ -0,0 +1,212 @@ +breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi +checkpoints.cmi: primitives.cmi debugcom.cmi +command_line.cmi: +debugcom.cmi: primitives.cmi +debugger_config.cmi: +dynlink.cmi: +envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi +eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ + ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ + ../typing/env.cmi debugcom.cmi +events.cmi: ../bytecomp/instruct.cmi +exec.cmi: +frames.cmi: primitives.cmi ../bytecomp/instruct.cmi +history.cmi: +input_handling.cmi: primitives.cmi +int64ops.cmi: +lexer.cmi: parser.cmi +loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi +parameters.cmi: +parser.cmi: parser_aux.cmi ../parsing/longident.cmi +parser_aux.cmi: primitives.cmi ../parsing/longident.cmi +pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi +pos.cmi: ../bytecomp/instruct.cmi +primitives.cmi: $(UNIXDIR)/unix.cmi +printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ + ../typing/env.cmi debugcom.cmi +program_loading.cmi: primitives.cmi +program_management.cmi: +question.cmi: +show_information.cmi: ../bytecomp/instruct.cmi +show_source.cmi: ../bytecomp/instruct.cmi +source.cmi: +symbols.cmi: ../bytecomp/instruct.cmi +time_travel.cmi: primitives.cmi +trap_barrier.cmi: +unix_tools.cmi: $(UNIXDIR)/unix.cmi +breakpoints.cmo: symbols.cmi primitives.cmi pos.cmi ../bytecomp/instruct.cmi \ + exec.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi +breakpoints.cmx: symbols.cmx primitives.cmx pos.cmx ../bytecomp/instruct.cmx \ + exec.cmx debugcom.cmx checkpoints.cmx breakpoints.cmi +checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi +checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi +command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ + ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ + show_source.cmi show_information.cmi question.cmi program_management.cmi \ + program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \ + parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/longident.cmi \ + ../parsing/location.cmi loadprinter.cmi lexer.cmi int64ops.cmi \ + ../bytecomp/instruct.cmi input_handling.cmi history.cmi frames.cmi \ + events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \ + ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \ + command_line.cmi +command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ + ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \ + show_source.cmx show_information.cmx question.cmx program_management.cmx \ + program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \ + parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/longident.cmx \ + ../parsing/location.cmx loadprinter.cmx lexer.cmx int64ops.cmx \ + ../bytecomp/instruct.cmx input_handling.cmx history.cmx frames.cmx \ + events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \ + ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \ + command_line.cmi +debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \ + input_handling.cmi debugcom.cmi +debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ + input_handling.cmx debugcom.cmi +debugger_config.cmo: int64ops.cmi debugger_config.cmi +debugger_config.cmx: int64ops.cmx debugger_config.cmi +dynlink.cmo: ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ + ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ + ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ + dynlink.cmi +dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ + ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ + ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ + dynlink.cmi +envaux.cmo: ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \ + ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \ + ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi +envaux.cmx: ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \ + ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \ + ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi +eval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ + printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ + ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \ + ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ + frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \ + ../typing/btype.cmi eval.cmi +eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ + printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ + ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \ + ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ + frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \ + ../typing/btype.cmx eval.cmi +events.cmo: ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi +events.cmx: ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi +exec.cmo: exec.cmi +exec.cmx: exec.cmi +frames.cmo: symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi events.cmi \ + debugcom.cmi frames.cmi +frames.cmx: symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx events.cmx \ + debugcom.cmx frames.cmi +history.cmo: primitives.cmi int64ops.cmi debugger_config.cmi checkpoints.cmi \ + history.cmi +history.cmx: primitives.cmx int64ops.cmx debugger_config.cmx checkpoints.cmx \ + history.cmi +input_handling.cmo: $(UNIXDIR)/unix.cmi primitives.cmi \ + input_handling.cmi +input_handling.cmx: $(UNIXDIR)/unix.cmx primitives.cmx \ + input_handling.cmi +int64ops.cmo: int64ops.cmi +int64ops.cmx: int64ops.cmi +lexer.cmo: parser.cmi lexer.cmi +lexer.cmx: parser.cmx lexer.cmi +loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ + ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ + ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ + dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi +loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ + ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ + ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ + dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi +main.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ + show_information.cmi question.cmi program_management.cmi primitives.cmi \ + parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ + ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ + command_line.cmi ../utils/clflags.cmi checkpoints.cmi +main.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ + show_information.cmx question.cmx program_management.cmx primitives.cmx \ + parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ + ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ + command_line.cmx ../utils/clflags.cmx checkpoints.cmx +parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \ + ../utils/config.cmi parameters.cmi +parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \ + ../utils/config.cmx parameters.cmi +parser.cmo: parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ + input_handling.cmi parser.cmi +parser.cmx: parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ + input_handling.cmx parser.cmi +pattern_matching.cmo: ../typing/typedtree.cmi parser_aux.cmi \ + ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \ + pattern_matching.cmi +pattern_matching.cmx: ../typing/typedtree.cmx parser_aux.cmi \ + ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \ + pattern_matching.cmi +pos.cmo: source.cmi primitives.cmi ../parsing/location.cmi \ + ../bytecomp/instruct.cmi pos.cmi +pos.cmx: source.cmx primitives.cmx ../parsing/location.cmx \ + ../bytecomp/instruct.cmx pos.cmi +primitives.cmo: $(UNIXDIR)/unix.cmi primitives.cmi +primitives.cmx: $(UNIXDIR)/unix.cmx primitives.cmi +printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \ + ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \ + ../typing/outcometree.cmi ../typing/oprint.cmi \ + ../toplevel/genprintval.cmi debugcom.cmi printval.cmi +printval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx \ + ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \ + ../typing/outcometree.cmi ../typing/oprint.cmx \ + ../toplevel/genprintval.cmx debugcom.cmx printval.cmi +program_loading.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi primitives.cmi \ + parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi +program_loading.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx primitives.cmx \ + parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi +program_management.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ + time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ + primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ + debugger_config.cmi breakpoints.cmi program_management.cmi +program_management.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ + time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ + primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ + debugger_config.cmx breakpoints.cmx program_management.cmi +question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi +question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi +show_information.cmo: symbols.cmi source.cmi show_source.cmi printval.cmi \ + ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \ + debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi +show_information.cmx: symbols.cmx source.cmx show_source.cmx printval.cmx \ + ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \ + debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi +show_source.cmo: source.cmi primitives.cmi parameters.cmi \ + ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ + debugger_config.cmi show_source.cmi +show_source.cmx: source.cmx primitives.cmx parameters.cmx \ + ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \ + debugger_config.cmx show_source.cmi +source.cmo: primitives.cmi ../utils/misc.cmi debugger_config.cmi \ + ../utils/config.cmi source.cmi +source.cmx: primitives.cmx ../utils/misc.cmx debugger_config.cmx \ + ../utils/config.cmx source.cmi +symbols.cmo: ../bytecomp/symtable.cmi program_loading.cmi \ + ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \ + checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi +symbols.cmx: ../bytecomp/symtable.cmx program_loading.cmx \ + ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \ + checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi +time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \ + program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ + ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ + debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ + time_travel.cmi +time_travel.cmx: trap_barrier.cmx symbols.cmx question.cmx \ + program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \ + ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ + debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ + time_travel.cmi +trap_barrier.cmo: exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi +trap_barrier.cmx: exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi +unix_tools.cmo: $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ + unix_tools.cmi +unix_tools.cmx: $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ + unix_tools.cmi diff --git a/ocaml-binary-annot/debugger/Makefile b/ocaml-binary-annot/debugger/Makefile new file mode 100644 index 0000000000..3ff1b54aa4 --- /dev/null +++ b/ocaml-binary-annot/debugger/Makefile @@ -0,0 +1,16 @@ +######################################################################### +# # +# 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$ + +UNIXDIR=../otherlibs/unix +include Makefile.shared diff --git a/ocaml-binary-annot/debugger/Makefile.nt b/ocaml-binary-annot/debugger/Makefile.nt new file mode 100644 index 0000000000..70263e94d8 --- /dev/null +++ b/ocaml-binary-annot/debugger/Makefile.nt @@ -0,0 +1,16 @@ +######################################################################### +# # +# 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$ + +UNIXDIR=../otherlibs/win32unix +include Makefile.shared diff --git a/ocaml-binary-annot/debugger/Makefile.shared b/ocaml-binary-annot/debugger/Makefile.shared new file mode 100644 index 0000000000..778fcf1129 --- /dev/null +++ b/ocaml-binary-annot/debugger/Makefile.shared @@ -0,0 +1,126 @@ +######################################################################### +# # +# 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 $(UNIXDIR) +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 $(UNIXDIR) + +OTHEROBJS=\ + $(UNIXDIR)/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/meta.cmo ../bytecomp/symtable.cmo \ + ../bytecomp/opcodes.cmo \ + ../toplevel/genprintval.cmo + + +OBJS=\ + dynlink.cmo \ + int64ops.cmo \ + primitives.cmo \ + unix_tools.cmo \ + debugger_config.cmo \ + envaux.cmo \ + parameters.cmo \ + lexer.cmo \ + input_handling.cmo \ + question.cmo \ + debugcom.cmo \ + exec.cmo \ + source.cmo \ + pos.cmo \ + checkpoints.cmo \ + events.cmo \ + program_loading.cmo \ + symbols.cmo \ + breakpoints.cmo \ + trap_barrier.cmo \ + history.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 \ + | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .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 + +dynlink.ml: ../otherlibs/dynlink/dynlink.ml + grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \ + ../otherlibs/dynlink/dynlink.ml >dynlink.ml +dynlink.mli: ../otherlibs/dynlink/dynlink.mli + cp ../otherlibs/dynlink/dynlink.mli . +clean:: + rm -f dynlink.ml dynlink.mli +beforedepend:: dynlink.ml dynlink.mli + +include .depend diff --git a/ocaml-binary-annot/debugger/breakpoints.ml b/ocaml-binary-annot/debugger/breakpoints.ml new file mode 100644 index 0000000000..1da4b74e26 --- /dev/null +++ b/ocaml-binary-annot/debugger/breakpoints.ml @@ -0,0 +1,226 @@ +(***********************************************************************) +(* *) +(* 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 + +(*** 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 (List.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 := List.remove_assoc pos !positions; + 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 ev = List.assoc number !breakpoints in + let pos = ev.ev_pos in + Exec.protect + (function () -> + breakpoints := List.remove_assoc number !breakpoints; + remove_position pos; + printf "Removed breakpoint %d at %d : %s" number ev.ev_pos + (Pos.get_desc ev); + print_newline () + ) + 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 := List.remove_assoc pc !positions; + 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/ocaml-binary-annot/debugger/breakpoints.mli b/ocaml-binary-annot/debugger/breakpoints.mli new file mode 100644 index 0000000000..091f609981 --- /dev/null +++ b/ocaml-binary-annot/debugger/breakpoints.mli @@ -0,0 +1,61 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/checkpoints.ml b/ocaml-binary-annot/debugger/checkpoints.ml new file mode 100644 index 0000000000..ffcff35e36 --- /dev/null +++ b/ocaml-binary-annot/debugger/checkpoints.ml @@ -0,0 +1,85 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/checkpoints.mli b/ocaml-binary-annot/debugger/checkpoints.mli new file mode 100644 index 0000000000..17c1037aa2 --- /dev/null +++ b/ocaml-binary-annot/debugger/checkpoints.mli @@ -0,0 +1,58 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/command_line.ml b/ocaml-binary-annot/debugger/command_line.ml new file mode 100644 index 0000000000..babb65bbe7 --- /dev/null +++ b/ocaml-binary-annot/debugger/command_line.ml @@ -0,0 +1,1149 @@ +(***********************************************************************) +(* *) +(* 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 Question +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 check_not_windows feature = + match Sys.os_type with + | "Win32" -> + error ("'"^feature^"' feature not supported on Windows") + | _ -> + () + +let eol = + end_of_line Lexer.lexeme + +let matching_elements list name instr = + List.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 = List.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 module_of_longident id = + match id with + | Some x -> Some (String.concat "." (Longident.flatten x)) + | None -> None + +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 + (get_current_event ()).ev_module + 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; + fprintf ppf "%s@." (Sys.getcwd ()) + +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 (); + Hashtbl.clear Debugger_config.load_path_for; + flush_buffer_list () + end + end + else begin + let new_directory' = List.rev new_directory in + match new_directory' with + | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 -> + List.iter (function x -> add_path_for mdl (expand_path x)) tl + | _ -> + List.iter (function x -> add_path (expand_path x)) new_directory' + end; + 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; + Hashtbl.iter + (fun mdl dirs -> + fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs) + Debugger_config.load_path_for + +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; + check_not_windows "reverse"; + 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 + check_not_windows "backstep"; + 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; + check_not_windows "start"; + 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 + check_not_windows "previous"; + 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 (module_of_longident mdle) in + new_breakpoint + (try + let buffer = + try get_buffer Lexing.dummy_pos 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 (module_of_longident 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 + fprintf ppf "Backtrace:@."; + 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 + fprintf ppf + "(Encountered a function with no debugging information)@." + 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 + check_not_windows "last"; + 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, line, column) = + try + selected_point () + with + | Not_found -> + ("", -1, -1) + in + let mdle = convert_module (module_of_longident mo) in + let pos = Lexing.dummy_pos in + let buffer = + try get_buffer pos mdle with + | Not_found -> error ("No source file for " ^ mdle ^ ".") in + let point = + if column <> -1 then + (point_of_coord buffer line 1) + column + else + -1 in + let beginning = + match beg with + | None when (mo <> None) || (line = -1) -> + 1 + | None -> + begin try + max 1 (line - 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 pos mdle beginning en point + (current_event_is_before ()) + else + show_listing pos 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 "@." + +let follow_fork_variable = + (function lexbuf -> + let mode = + match identifier_eol Lexer.lexeme lexbuf with + | "child" -> Fork_child + | "parent" -> Fork_parent + | _ -> error "Syntax error." + in + fork_mode := mode; + if !loaded then update_follow_fork_mode ()), + function ppf -> + fprintf ppf "%s@." + (match !fork_mode with + Fork_child -> "child" + | Fork_parent -> "parent") + +(** 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 (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in + print_endline ("Module : " ^ mdle); + print_endline " Address Characters Kind Repr."; + List.iter + (function ev -> + let start_char, end_char = + try + let buffer = get_buffer (Events.get_pos ev) ev.ev_module in + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)), + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)) + with _ -> + ev.ev_loc.Location.loc_start.Lexing.pos_cnum, + ev.ev_loc.Location.loc_end.Lexing.pos_cnum in + Printf.printf + "%10d %6d-%-6d %10s %10s\n" + ev.ev_pos + start_char + end_char + ((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 :\n\ + 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." }; + { var_name = "follow_fork_mode"; + var_action = follow_fork_variable; + var_help = +"process to follow after forking.\n\ +It can be either : + child : the newly created process.\n\ + parent : the process that called fork.\n" }]; + + 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/ocaml-binary-annot/debugger/command_line.mli b/ocaml-binary-annot/debugger/command_line.mli new file mode 100644 index 0000000000..dd2349d2c4 --- /dev/null +++ b/ocaml-binary-annot/debugger/command_line.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/debugcom.ml b/ocaml-binary-annot/debugger/debugcom.ml new file mode 100644 index 0000000000..dfe905bac4 --- /dev/null +++ b/ocaml-binary-annot/debugger/debugcom.ml @@ -0,0 +1,298 @@ +(***********************************************************************) +(* *) +(* 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 + +(* Set which process the debugger follows on fork. *) + +type follow_fork_mode = + Fork_child + | Fork_parent + +let fork_mode = ref Fork_parent + +let update_follow_fork_mode () = + let a = match !fork_mode with Fork_child -> 0 | Fork_parent -> 1 in + output_char !conn.io_out 'K'; + output_binary_int !conn.io_out a + +(* Set the current connection, and update the fork mode in case it has + * changed. *) + +let set_current_connection io_chan = + conn := io_chan; + update_follow_fork_mode () + +(* 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 () = + match Sys.os_type with + "Win32" -> failwith "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/ocaml-binary-annot/debugger/debugcom.mli b/ocaml-binary-annot/debugger/debugcom.mli new file mode 100644 index 0000000000..abf4fd0b2c --- /dev/null +++ b/ocaml-binary-annot/debugger/debugcom.mli @@ -0,0 +1,110 @@ +(***********************************************************************) +(* *) +(* 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 + +type follow_fork_mode = + Fork_child + | Fork_parent + +(* 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 + +(* Set whether the debugger follow the child or the parent process on fork *) +val fork_mode : follow_fork_mode ref +val update_follow_fork_mode : unit -> 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/ocaml-binary-annot/debugger/debugger_config.ml b/ocaml-binary-annot/debugger/debugger_config.ml new file mode 100644 index 0000000000..54d6b2d583 --- /dev/null +++ b/ocaml-binary-annot/debugger/debugger_config.ml @@ -0,0 +1,82 @@ +(***********************************************************************) +(* *) +(* 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 = + match Sys.os_type with + "Win32" -> "cmd" + | _ -> "/bin/sh" + +(* Name of the Objective Caml runtime. *) +let runtime_program = "ocamlrun" + +(* Time history size (for `last') *) +let history_size = ref 30 + +let load_path_for = Hashtbl.create 7 + +(*** 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 + (match Sys.os_type with + "Win32" -> false + | _ -> true) diff --git a/ocaml-binary-annot/debugger/debugger_config.mli b/ocaml-binary-annot/debugger/debugger_config.mli new file mode 100644 index 0000000000..18faf9c62f --- /dev/null +++ b/ocaml-binary-annot/debugger/debugger_config.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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 +val load_path_for : (string, string list) Hashtbl.t + +(*** 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/ocaml-binary-annot/debugger/envaux.ml b/ocaml-binary-annot/debugger/envaux.ml new file mode 100644 index 0000000000..8d462e2f87 --- /dev/null +++ b/ocaml-binary-annot/debugger/envaux.ml @@ -0,0 +1,84 @@ +(***********************************************************************) +(* *) +(* 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 * Subst.t), 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 subst = + try + Hashtbl.find env_cache (sum, subst) + with Not_found -> + let env = + match sum with + Env_empty -> + Env.empty + | Env_value(s, id, desc) -> + Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst) + | Env_type(s, id, desc) -> + Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst) + | Env_exception(s, id, desc) -> + Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst) + | Env_module(s, id, desc) -> + Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst) + | Env_modtype(s, id, desc) -> + Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) + | Env_class(s, id, desc) -> + Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst) + | Env_cltype (s, id, desc) -> + Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) + | Env_open(s, path) -> + let env = env_from_summary s subst in + let path' = Subst.module_path subst path 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, subst) env; + env + +let env_of_event = + function + None -> Env.empty + | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst + +(* 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/ocaml-binary-annot/debugger/envaux.mli b/ocaml-binary-annot/debugger/envaux.mli new file mode 100644 index 0000000000..8b122cc347 --- /dev/null +++ b/ocaml-binary-annot/debugger/envaux.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/eval.ml b/ocaml-binary-annot/debugger/eval.ml new file mode 100644 index 0000000000..7ee1339f01 --- /dev/null +++ b/ocaml-binary-annot/debugger/eval.ml @@ -0,0 +1,207 @@ +(***********************************************************************) +(* *) +(* 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 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 + try + Debugcom.Remote_value.global (Symtable.get_global_position id) + with Symtable.Error _ -> raise(Error(Unbound_identifier 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; ev_typsubst = subst} when !Frames.current_frame = 0 -> + (Debugcom.Remote_value.accu(), Subst.type_expr subst 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_opt 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_opt 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) -> + 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-tuple of type@ %a@]@." + pos len Printtyp.type_expr ty + | Array_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from an array of length %i@]@." pos len + | List_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from a 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/ocaml-binary-annot/debugger/eval.mli b/ocaml-binary-annot/debugger/eval.mli new file mode 100644 index 0000000000..b2a2998f14 --- /dev/null +++ b/ocaml-binary-annot/debugger/eval.mli @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/events.ml b/ocaml-binary-annot/debugger/events.ml new file mode 100644 index 0000000000..2521c064db --- /dev/null +++ b/ocaml-binary-annot/debugger/events.ml @@ -0,0 +1,48 @@ +(***********************************************************************) +(* *) +(* 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 + +let get_pos ev = + match ev.ev_kind with + | Event_before -> ev.ev_loc.Location.loc_start + | Event_after _ -> ev.ev_loc.Location.loc_end + | _ -> ev.ev_loc.Location.loc_start +;; + + +(*** Current events. ***) + +(* Event at current position *) +let current_event = + ref (None : debug_event option) + +(* Current position in source. *) +(* Raise `Not_found' if not on an event (beginning or end of program). *) +let get_current_event () = + match !current_event with + | None -> raise Not_found + | Some ev -> ev + +let current_event_is_before () = + match !current_event with + None -> + raise Not_found + | Some {ev_kind = Event_before} -> + true + | _ -> + false diff --git a/ocaml-binary-annot/debugger/events.mli b/ocaml-binary-annot/debugger/events.mli new file mode 100644 index 0000000000..7166f2c9d0 --- /dev/null +++ b/ocaml-binary-annot/debugger/events.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* 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 + +val get_pos : debug_event -> Lexing.position;; + +(** Current events. **) + +(* The event at current position. *) +val current_event : debug_event option ref + +(* Current position in source. *) +(* Raise `Not_found' if not on an event (beginning or end of program). *) +val get_current_event : unit -> debug_event + +val current_event_is_before : unit -> bool diff --git a/ocaml-binary-annot/debugger/exec.ml b/ocaml-binary-annot/debugger/exec.ml new file mode 100644 index 0000000000..1ea165978f --- /dev/null +++ b/ocaml-binary-annot/debugger/exec.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* 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 _ = + match Sys.os_type with + "Win32" -> () + | _ -> + 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/ocaml-binary-annot/debugger/exec.mli b/ocaml-binary-annot/debugger/exec.mli new file mode 100644 index 0000000000..9d3b986048 --- /dev/null +++ b/ocaml-binary-annot/debugger/exec.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/frames.ml b/ocaml-binary-annot/debugger/frames.ml new file mode 100644 index 0000000000..c533782fc4 --- /dev/null +++ b/ocaml-binary-annot/debugger/frames.ml @@ -0,0 +1,129 @@ +(***********************************************************************) +(* *) +(* 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 Debugcom +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 -> + (ev.ev_module, + (Events.get_pos ev).Lexing.pos_lnum, + (Events.get_pos ev).Lexing.pos_cnum - (Events.get_pos ev).Lexing.pos_bol) + +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/ocaml-binary-annot/debugger/frames.mli b/ocaml-binary-annot/debugger/frames.mli new file mode 100644 index 0000000000..b4863433dd --- /dev/null +++ b/ocaml-binary-annot/debugger/frames.mli @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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 (module, line, column). *) +(* Raise `Not_found' if not on an event. *) +val selected_point : unit -> string * int * 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/ocaml-binary-annot/debugger/history.ml b/ocaml-binary-annot/debugger/history.ml new file mode 100644 index 0000000000..e8c5ed8ff5 --- /dev/null +++ b/ocaml-binary-annot/debugger/history.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* 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 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/ocaml-binary-annot/debugger/history.mli b/ocaml-binary-annot/debugger/history.mli new file mode 100644 index 0000000000..249629fdb9 --- /dev/null +++ b/ocaml-binary-annot/debugger/history.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/input_handling.ml b/ocaml-binary-annot/debugger/input_handling.ml new file mode 100644 index 0000000000..f25d474266 --- /dev/null +++ b/ocaml-binary-annot/debugger/input_handling.ml @@ -0,0 +1,115 @@ +(***********************************************************************) +(* *) +(* 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 := List.remove_assoc file.io_fd !active_files + +(* 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 diff --git a/ocaml-binary-annot/debugger/input_handling.mli b/ocaml-binary-annot/debugger/input_handling.mli new file mode 100644 index 0000000000..959547df79 --- /dev/null +++ b/ocaml-binary-annot/debugger/input_handling.mli @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* 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 diff --git a/ocaml-binary-annot/debugger/int64ops.ml b/ocaml-binary-annot/debugger/int64ops.ml new file mode 100644 index 0000000000..b854a6c343 --- /dev/null +++ b/ocaml-binary-annot/debugger/int64ops.ml @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/int64ops.mli b/ocaml-binary-annot/debugger/int64ops.mli new file mode 100644 index 0000000000..98f7228d3d --- /dev/null +++ b/ocaml-binary-annot/debugger/int64ops.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/lexer.mli b/ocaml-binary-annot/debugger/lexer.mli new file mode 100644 index 0000000000..7214ed2be9 --- /dev/null +++ b/ocaml-binary-annot/debugger/lexer.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* 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 line: Lexing.lexbuf -> string +val lexeme: Lexing.lexbuf -> Parser.token +val argument: Lexing.lexbuf -> Parser.token +val line_argument: Lexing.lexbuf -> Parser.token diff --git a/ocaml-binary-annot/debugger/lexer.mll b/ocaml-binary-annot/debugger/lexer.mll new file mode 100644 index 0000000000..eea8ed0284 --- /dev/null +++ b/ocaml-binary-annot/debugger/lexer.mll @@ -0,0 +1,97 @@ +(***********************************************************************) +(* *) +(* 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 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/ocaml-binary-annot/debugger/loadprinter.ml b/ocaml-binary-annot/debugger/loadprinter.ml new file mode 100644 index 0000000000..ac5aa0187d --- /dev/null +++ b/ocaml-binary-annot/debugger/loadprinter.ml @@ -0,0 +1,169 @@ +(***********************************************************************) +(* *) +(* 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 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/ocaml-binary-annot/debugger/loadprinter.mli b/ocaml-binary-annot/debugger/loadprinter.mli new file mode 100644 index 0000000000..bdaf77a285 --- /dev/null +++ b/ocaml-binary-annot/debugger/loadprinter.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/main.ml b/ocaml-binary-annot/debugger/main.ml new file mode 100644 index 0000000000..f5f0d8b556 --- /dev/null +++ b/ocaml-binary-annot/debugger/main.ml @@ -0,0 +1,225 @@ +(***********************************************************************) +(* *) +(* 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 Input_handling +open Question +open Command_line +open Debugger_config +open Checkpoints +open Time_travel +open Parameters +open Program_management +open Frames +open Show_information +open Format +open Primitives + +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 current_duration = ref (-1L) + +let rec protect ppf restart loop = + try + loop ppf + with + | End_of_file -> + protect ppf restart (function ppf -> + forget_process + !current_checkpoint.c_fd + !current_checkpoint.c_pid; + pp_print_flush ppf (); + stop_user_input (); + restart ppf) + | Toplevel -> + protect ppf restart (function ppf -> + pp_print_flush ppf (); + stop_user_input (); + restart ppf) + | Sys.Break -> + protect ppf restart (function ppf -> + fprintf ppf "Interrupted.@."; + Exec.protect (function () -> + stop_user_input (); + if !loaded then begin + try_select_frame 0; + show_current_event ppf; + end); + restart ppf) + | Current_checkpoint_lost -> + protect ppf restart (function ppf -> + fprintf ppf "Trying to recover...@."; + stop_user_input (); + recover (); + try_select_frame 0; + show_current_event ppf; + restart ppf) + | Current_checkpoint_lost_start_at (time, init_duration) -> + protect ppf restart (function ppf -> + let b = + if !current_duration = -1L then begin + let msg = sprintf "Restart from time %Ld and try to get closer of the problem" time in + stop_user_input (); + if yes_or_no msg then + (current_duration := init_duration; true) + else + false + end + else + true in + if b then + begin + go_to time; + current_duration := Int64.div !current_duration 10L; + if !current_duration > 0L then + while true do + step !current_duration + done + else begin + current_duration := -1L; + stop_user_input (); + show_current_event ppf; + restart ppf; + end + end + else + begin + recover (); + show_current_event ppf; + restart ppf + end) + | x -> + kill_program (); + raise x + +let execute_file_if_any () = + let buffer = Buffer.create 128 in + begin + try + let base = ".ocamldebug" in + let file = + if Sys.file_exists base then + base + else + Filename.concat (Sys.getenv "HOME") base in + let ch = open_in file in + fprintf Format.std_formatter "Executing file %s@." file; + while true do + let line = string_trim (input_line ch) in + if line <> "" && line.[0] <> '#' then begin + Buffer.add_string buffer line; + Buffer.add_char buffer '\n' + end + done; + with _ -> () + end; + let len = Buffer.length buffer in + if len > 0 then + let commands = Buffer.sub buffer 0 (pred len) in + line_loop Format.std_formatter (Lexing.from_string commands) + +let toplevel_loop () = + interactif := false; + current_prompt := ""; + execute_file_if_any (); + interactif := true; + current_prompt := debugger_prompt; + protect Format.std_formatter loop 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 print_version () = + printf "The Objective Caml debugger, version %s@." Sys.ocaml_version; + exit 0; +;; +let print_version_num () = + printf "%s@." Sys.ocaml_version; + exit 0; +;; + +let speclist = [ + "-c", Arg.Int set_checkpoints, + "<count> Set max number of checkpoints kept"; + "-cd", Arg.String set_directory, + "<dir> Change working directory"; + "-emacs", Arg.Set emacs, + "For running the debugger under emacs"; + "-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"; + "-version", Arg.Unit print_version, + " Print version and exit"; + "-vnum", Arg.Unit print_version_num, + " Print version number and exit"; + ] + +let main () = + try + socket_name := + (match Sys.os_type with + "Win32" -> + (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ + ":"^ + (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) + | _ -> Filename.concat Filename.temp_dir_name + ("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; + printf "\tObjective Caml Debugger version %s@.@." Config.version; + Config.load_path := !default_load_path; + Clflags.recursive_types := true; (* Allow recursive types. *) + toplevel_loop (); (* Toplevel. *) + kill_program (); + exit 0 + with + Toplevel -> + exit 2 + | Env.Error e -> + eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; + Env.report_error err_formatter e; + eprintf "@]@."; + exit 2 + +let _ = + Printexc.catch (Unix.handle_unix_error main) () diff --git a/ocaml-binary-annot/debugger/parameters.ml b/ocaml-binary-annot/debugger/parameters.ml new file mode 100644 index 0000000000..9d518e5494 --- /dev/null +++ b/ocaml-binary-annot/debugger/parameters.ml @@ -0,0 +1,39 @@ +(***********************************************************************) +(* *) +(* 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 Debugger_config + +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() + +let add_path_for mdl dir = + let old = try Hashtbl.find load_path_for mdl with Not_found -> [] in + Hashtbl.replace load_path_for mdl (dir :: old) + +(* Used by emacs ? *) +let emacs = ref false diff --git a/ocaml-binary-annot/debugger/parameters.mli b/ocaml-binary-annot/debugger/parameters.mli new file mode 100644 index 0000000000..8f750e68a6 --- /dev/null +++ b/ocaml-binary-annot/debugger/parameters.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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 +val add_path_for : string -> string -> unit + +(* Used by emacs ? *) +val emacs : bool ref diff --git a/ocaml-binary-annot/debugger/parser.mly b/ocaml-binary-annot/debugger/parser.mly new file mode 100644 index 0000000000..6fc8392a86 --- /dev/null +++ b/ocaml-binary-annot/debugger/parser.mly @@ -0,0 +1,253 @@ +/***********************************************************************/ +/* */ +/* 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 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 <Longident.t 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 + +%start opt_longident +%type <Longident.t option> opt_longident + +%start opt_longident_eol +%type <Longident.t option> opt_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 }; + +opt_longident : + UIDENT { Some (Lident $1) } + | LIDENT { Some (Lident $1) } + | module_path DOT UIDENT { Some (Ldot($1, $3)) } + | { None }; + +opt_longident_eol : + opt_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_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} + | AT opt_longident SHARP integer_eol { BA_pos2 ($2, $4) } +; + +/* Arguments for list */ + +list_arguments_eol : + opt_longident integer opt_integer_eol + { ($1, Some $2, $3) } + | opt_longident_eol + { ($1, None, None) }; + +/* End of line */ + +end_of_line : + EOL { stop_user_input () } +; diff --git a/ocaml-binary-annot/debugger/parser_aux.mli b/ocaml-binary-annot/debugger/parser_aux.mli new file mode 100644 index 0000000000..a68e08d5c8 --- /dev/null +++ b/ocaml-binary-annot/debugger/parser_aux.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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 Longident.t option * int * int option + (* break @ [MODULE] LINE [POS] *) + | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *) diff --git a/ocaml-binary-annot/debugger/pattern_matching.ml b/ocaml-binary-annot/debugger/pattern_matching.ml new file mode 100644 index 0000000000..97af9326b5 --- /dev/null +++ b/ocaml-binary-annot/debugger/pattern_matching.ml @@ -0,0 +1,251 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/pattern_matching.mli b/ocaml-binary-annot/debugger/pattern_matching.mli new file mode 100644 index 0000000000..3490edef69 --- /dev/null +++ b/ocaml-binary-annot/debugger/pattern_matching.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/pos.ml b/ocaml-binary-annot/debugger/pos.ml new file mode 100644 index 0000000000..4beba3de0f --- /dev/null +++ b/ocaml-binary-annot/debugger/pos.ml @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* 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 Location;; +open Primitives;; +open Source;; + +let get_desc ev = + let loc = ev.ev_loc in + if loc.loc_start.pos_fname <> "" + then Printf.sprintf "file %s, line %d, characters %d-%d" + loc.loc_start.pos_fname loc.loc_start.pos_lnum + (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) + (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) + else begin + let filename = source_of_module ev.ev_loc.loc_start ev.ev_module in + try + let (start, line) = line_of_pos (get_buffer loc.loc_start ev.ev_module) + loc.loc_start.pos_cnum + in + Printf.sprintf "file %s, line %d, characters %d-%d" + filename line (loc.loc_start.pos_cnum - start + 1) + (loc.loc_end.pos_cnum - start + 1) + with Not_found | Out_of_range -> + Printf.sprintf "file %s, characters %d-%d" + filename (loc.loc_start.pos_cnum + 1) + (loc.loc_end.pos_cnum + 1) + end +;; diff --git a/ocaml-binary-annot/debugger/pos.mli b/ocaml-binary-annot/debugger/pos.mli new file mode 100644 index 0000000000..e7632e4274 --- /dev/null +++ b/ocaml-binary-annot/debugger/pos.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/primitives.ml b/ocaml-binary-annot/debugger/primitives.ml new file mode 100644 index 0000000000..d4ba22e5f8 --- /dev/null +++ b/ocaml-binary-annot/debugger/primitives.ml @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* 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 + +(* 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 + +(*** Operations on strings. ***) + +(* 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/ocaml-binary-annot/debugger/primitives.mli b/ocaml-binary-annot/debugger/primitives.mli new file mode 100644 index 0000000000..4333128fb6 --- /dev/null +++ b/ocaml-binary-annot/debugger/primitives.mli @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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 + +(* 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 + +(*** Operations on strings. ***) + +(* 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/ocaml-binary-annot/debugger/printval.ml b/ocaml-binary-annot/debugger/printval.ml new file mode 100644 index 0000000000..5f36e1a7cc --- /dev/null +++ b/ocaml-binary-annot/debugger/printval.ml @@ -0,0 +1,108 @@ +(***********************************************************************) +(* *) +(* 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 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/ocaml-binary-annot/debugger/printval.mli b/ocaml-binary-annot/debugger/printval.mli new file mode 100644 index 0000000000..bb6318880c --- /dev/null +++ b/ocaml-binary-annot/debugger/printval.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/program_loading.ml b/ocaml-binary-annot/debugger/program_loading.ml new file mode 100644 index 0000000000..79577ff4b9 --- /dev/null +++ b/ocaml-binary-annot/debugger/program_loading.ml @@ -0,0 +1,146 @@ +(***********************************************************************) +(* *) +(* 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 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_unix 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 + +let generic_exec_win cmdline = function () -> + if !debug_loading then + prerr_endline "Launching program..."; + try ignore(create_process "cmd.exe" [| "/C"; cmdline() |] stdin stdout stderr) + with x -> + Unix_tools.report_error x; + raise Toplevel + +let generic_exec = + match Sys.os_type with + "Win32" -> generic_exec_win + | _ -> generic_exec_unix + +(* Execute the program by calling the runtime explicitely *) +let exec_with_runtime = + generic_exec + (function () -> + match Sys.os_type with + "Win32" -> + (* This fould fail on a file name with spaces + but quoting is even worse because Unix.create_process + thinks each command line parameter is a file. + So no good solution so far *) + Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s" + !socket_name + runtime_program + !program_name + !arguments + | _ -> + Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" + !socket_name + (Filename.quote runtime_program) + (Filename.quote !program_name) + !arguments) + +(* Excute the program directly *) +let exec_direct = + generic_exec + (function () -> + match Sys.os_type with + "Win32" -> + (* See the comment above *) + Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s" + !socket_name + !program_name + !arguments + | _ -> + Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" + !socket_name + (Filename.quote !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/ocaml-binary-annot/debugger/program_loading.mli b/ocaml-binary-annot/debugger/program_loading.mli new file mode 100644 index 0000000000..d1210d1ab0 --- /dev/null +++ b/ocaml-binary-annot/debugger/program_loading.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/program_management.ml b/ocaml-binary-annot/debugger/program_management.ml new file mode 100644 index 0000000000..8ebb907d1f --- /dev/null +++ b/ocaml-binary-annot/debugger/program_management.ml @@ -0,0 +1,156 @@ +(***********************************************************************) +(* *) +(* 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 Primitives +open Parameters +open Input_handling +open Question +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; + setsockopt sock SO_REUSEADDR true; + 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 information..."; + 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/ocaml-binary-annot/debugger/program_management.mli b/ocaml-binary-annot/debugger/program_management.mli new file mode 100644 index 0000000000..8e2f28e54e --- /dev/null +++ b/ocaml-binary-annot/debugger/program_management.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/question.ml b/ocaml-binary-annot/debugger/question.ml new file mode 100644 index 0000000000..2eeec3ab0d --- /dev/null +++ b/ocaml-binary-annot/debugger/question.ml @@ -0,0 +1,35 @@ +open Input_handling +open Primitives + +(* 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/ocaml-binary-annot/debugger/question.mli b/ocaml-binary-annot/debugger/question.mli new file mode 100644 index 0000000000..3a92dee6b2 --- /dev/null +++ b/ocaml-binary-annot/debugger/question.mli @@ -0,0 +1,2 @@ +(* Ask user a yes or no question. *) +val yes_or_no : string -> bool diff --git a/ocaml-binary-annot/debugger/show_information.ml b/ocaml-binary-annot/debugger/show_information.ml new file mode 100644 index 0000000000..bd746eb7f8 --- /dev/null +++ b/ocaml-binary-annot/debugger/show_information.ml @@ -0,0 +1,100 @@ +(***********************************************************************) +(* *) +(* 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 Debugcom +open Checkpoints +open Events +open Symbols +open Frames +open Source +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 ev = get_current_event () in + fprintf ppf " - module %s@." ev.ev_module; + (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 ev 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 = + let pos = Events.get_pos event in + let cnum = + try + let buffer = get_buffer pos event.ev_module in + snd (start_and_cnum buffer pos) + with _ -> pos.Lexing.pos_cnum in + fprintf ppf "#%i Pc : %i %s char %i@." + framenum event.ev_pos event.ev_module + 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 selected diff --git a/ocaml-binary-annot/debugger/show_information.mli b/ocaml-binary-annot/debugger/show_information.mli new file mode 100644 index 0000000000..3069f93321 --- /dev/null +++ b/ocaml-binary-annot/debugger/show_information.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/show_source.ml b/ocaml-binary-annot/debugger/show_source.ml new file mode 100644 index 0000000000..2826c9e686 --- /dev/null +++ b/ocaml-binary-annot/debugger/show_source.ml @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* 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 Instruct +open Parameters +open Primitives +open Printf +open Source + +(* 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 ev selected = + let mdle = ev.ev_module in + let before = (ev.ev_kind = Event_before) in + if !emacs && selected then + begin try + let buffer = get_buffer (Events.get_pos ev) mdle in + let source = source_of_module ev.ev_loc.Location.loc_start mdle in + printf "\026\026M%s:%i:%i" source + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)) + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)); + printf "%s\n" (if before then ":before" else ":after") + with + Out_of_range -> (* point_of_coord *) + prerr_endline "Position out of range." + | Not_found -> (* Events.get_pos || get_buffer *) + prerr_endline ("No source file for " ^ mdle ^ "."); + show_no_point () + end + else + begin try + let pos = Events.get_pos ev in + let buffer = get_buffer pos mdle in + let start, point = start_and_cnum buffer pos in + ignore(print_line buffer pos.Lexing.pos_lnum start point before) + with + Out_of_range -> (* point_of_coord *) + prerr_endline "Position out of range." + | Not_found -> (* Events.get_pos || get_buffer *) + prerr_endline ("No source file for " ^ mdle ^ ".") + end + +(* Display part of the source. *) +let show_listing pos mdle start stop point before = + try + let buffer = get_buffer pos 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/ocaml-binary-annot/debugger/show_source.mli b/ocaml-binary-annot/debugger/show_source.mli new file mode 100644 index 0000000000..5ba418af58 --- /dev/null +++ b/ocaml-binary-annot/debugger/show_source.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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 : Instruct.debug_event -> bool -> unit;; + +(* Tell Emacs we are nowhere in the source. *) +val show_no_point : unit -> unit;; + +(* Display part of the source. *) +val show_listing : Lexing.position -> string -> int -> int -> int -> bool -> unit;; diff --git a/ocaml-binary-annot/debugger/source.ml b/ocaml-binary-annot/debugger/source.ml new file mode 100644 index 0000000000..f0d3d48fb9 --- /dev/null +++ b/ocaml-binary-annot/debugger/source.ml @@ -0,0 +1,192 @@ +(***********************************************************************) +(* *) +(* 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 + +let source_extensions = [".ml"] + +(*** Conversion function. ***) + +let source_of_module pos mdle = + let is_submodule m m' = + let len' = String.length m' in + try + (String.sub m 0 len') = m' && (String.get m len') = '.' + with + Invalid_argument _ -> false in + let path = + Hashtbl.fold + (fun mdl dirs acc -> + if is_submodule mdle mdl then + dirs + else + acc) + Debugger_config.load_path_for + !Config.load_path in + let fname = pos.Lexing.pos_fname in + if fname = "" then + let innermost_module = + try + let dot_index = String.rindex mdle '.' in + String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index)) + with Not_found -> mdle in + let rec loop = + function + | [] -> raise Not_found + | ext :: exts -> + try find_in_path_uncap path (innermost_module ^ ext) + with Not_found -> loop exts + in loop source_extensions + else if Filename.is_implicit fname then + find_in_path path fname + else + fname + +(*** 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 pos mdle = + try List.assoc mdle !buffer_list with + Not_found -> + let inchan = open_in_bin (source_of_module pos 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) + +let start_and_cnum buffer pos = + let line_number = pos.Lexing.pos_lnum in + let start = point_of_coord buffer line_number 1 in + start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) diff --git a/ocaml-binary-annot/debugger/source.mli b/ocaml-binary-annot/debugger/source.mli new file mode 100644 index 0000000000..273cb517b3 --- /dev/null +++ b/ocaml-binary-annot/debugger/source.mli @@ -0,0 +1,61 @@ +(***********************************************************************) +(* *) +(* 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: Lexing.position -> string -> string + +(*** buffer cache ***) + +type buffer + +val buffer_max_count : int ref + +val flush_buffer_list : unit -> unit + +val get_buffer : Lexing.position -> 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 + +(* Return the offsets of both line start and cnum for the passed position. *) +val start_and_cnum : buffer -> Lexing.position -> (int * int) diff --git a/ocaml-binary-annot/debugger/symbols.ml b/ocaml-binary-annot/debugger/symbols.ml new file mode 100644 index 0000000000..392da976aa --- /dev/null +++ b/ocaml-binary-annot/debugger/symbols.ml @@ -0,0 +1,201 @@ +(***********************************************************************) +(* *) +(* 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 *) +open Program_loading + +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; + begin try + ignore (Bytesections.seek_section ic "CODE") + with Not_found -> + (* The file contains only debugging info, loading mode is forced to "manual" *) + set_launching_function (List.assoc "manual" loading_modes) + end; + 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 (Events.get_pos ev1).Lexing.pos_cnum + (Events.get_pos ev2).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 = + List.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 (Events.get_pos ev.(hi)).Lexing.pos_cnum < char + then raise Not_found + else hi + end else begin + let pivot = (lo + hi) / 2 in + let e = ev.(pivot) in + if char <= (Events.get_pos e).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 - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum + <= (Events.get_pos ev.(pos)).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 + + +(* Previous `pc'. *) +(* Save time if `update_current_event' is called *) +(* several times at the same point. *) +let old_pc = ref (None : int option) + +(* Recompute the current event *) +let update_current_event () = + match Checkpoints.current_pc () with + None -> + Events.current_event := None; + old_pc := None + | (Some pc) as opt_pc when opt_pc <> !old_pc -> + Events.current_event := + begin try + Some (event_at_pc pc) + with Not_found -> + None + end; + old_pc := opt_pc + | _ -> + () diff --git a/ocaml-binary-annot/debugger/symbols.mli b/ocaml-binary-annot/debugger/symbols.mli new file mode 100644 index 0000000000..57ac8007b1 --- /dev/null +++ b/ocaml-binary-annot/debugger/symbols.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* *) +(* 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 + +(* Recompute the current event *) +val update_current_event : unit -> unit diff --git a/ocaml-binary-annot/debugger/time_travel.ml b/ocaml-binary-annot/debugger/time_travel.ml new file mode 100644 index 0000000000..a4a4c83fa0 --- /dev/null +++ b/ocaml-binary-annot/debugger/time_travel.ml @@ -0,0 +1,648 @@ +(***********************************************************************) +(* *) +(* 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 +open Question + +exception Current_checkpoint_lost +exception Current_checkpoint_lost_start_at of int64 * int64 + +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); + Symbols.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 = + List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) + in + Printf.eprintf "Lost connection with process %d" pid; + let kont = + 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; + fun () -> raise Current_checkpoint_lost + | C_running duration -> + Printf.eprintf "between time %Ld and time %Ld" + !current_checkpoint.c_time + (!current_checkpoint.c_time ++ duration); + fun () -> raise (Current_checkpoint_lost_start_at + (!current_checkpoint.c_time, duration)) + end + else ignore in + 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; + kont () + +(* 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} = 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 () = + Symbols.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 () = + Symbols.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 + Symbols.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 () = + Symbols.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 () = + Symbols.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 + Symbols.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/ocaml-binary-annot/debugger/time_travel.mli b/ocaml-binary-annot/debugger/time_travel.mli new file mode 100644 index 0000000000..453e4df052 --- /dev/null +++ b/ocaml-binary-annot/debugger/time_travel.mli @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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 +exception Current_checkpoint_lost_start_at of int64 * int64 + +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/ocaml-binary-annot/debugger/trap_barrier.ml b/ocaml-binary-annot/debugger/trap_barrier.ml new file mode 100644 index 0000000000..dba9c929f7 --- /dev/null +++ b/ocaml-binary-annot/debugger/trap_barrier.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/trap_barrier.mli b/ocaml-binary-annot/debugger/trap_barrier.mli new file mode 100644 index 0000000000..28bba5a3eb --- /dev/null +++ b/ocaml-binary-annot/debugger/trap_barrier.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* 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/ocaml-binary-annot/debugger/unix_tools.ml b/ocaml-binary-annot/debugger/unix_tools.ml new file mode 100644 index 0000000000..9926e05d5a --- /dev/null +++ b/ocaml-binary-annot/debugger/unix_tools.ml @@ -0,0 +1,143 @@ +(***********************************************************************) +(* *) +(* 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.index 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 -> + match Sys.os_type with + "Win32" -> failwith "Unix sockets not supported" + | _ -> (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.index 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.index 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/ocaml-binary-annot/debugger/unix_tools.mli b/ocaml-binary-annot/debugger/unix_tools.mli new file mode 100644 index 0000000000..b5e4ee6ca4 --- /dev/null +++ b/ocaml-binary-annot/debugger/unix_tools.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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 |