diff options
Diffstat (limited to 'debugger')
31 files changed, 241 insertions, 254 deletions
diff --git a/debugger/.depend b/debugger/.depend index afac5c0d5..f71fcbef3 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -34,32 +34,32 @@ symbols.cmi: ../bytecomp/instruct.cmi time_travel.cmi: primitives.cmi trap_barrier.cmi: unix_tools.cmi: ../otherlibs/unix/unix.cmi -breakpoints.cmo: symbols.cmi source.cmi primitives.cmi pos.cmi \ - ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ - breakpoints.cmi -breakpoints.cmx: symbols.cmx source.cmx primitives.cmx pos.cmx \ - ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \ - breakpoints.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 ../otherlibs/unix/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/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 + 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 ../otherlibs/unix/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/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 + 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 \ @@ -74,76 +74,70 @@ 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/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/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 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 \ - debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../typing/btype.cmi \ - eval.cmi -eval.cmx: ../typing/types.cmx ../bytecomp/symtable.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 \ - debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../typing/btype.cmx \ - eval.cmi -events.cmo: primitives.cmi ../parsing/location.cmi ../bytecomp/instruct.cmi \ - checkpoints.cmi events.cmi -events.cmx: primitives.cmx ../parsing/location.cmx ../bytecomp/instruct.cmx \ - checkpoints.cmx events.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 primitives.cmi ../utils/misc.cmi \ - ../bytecomp/instruct.cmi events.cmi debugcom.cmi checkpoints.cmi \ - frames.cmi -frames.cmx: symbols.cmx primitives.cmx ../utils/misc.cmx \ - ../bytecomp/instruct.cmx events.cmx debugcom.cmx checkpoints.cmx \ - frames.cmi -history.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \ - debugger_config.cmi checkpoints.cmi history.cmi -history.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ - debugger_config.cmx checkpoints.cmx history.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: ../otherlibs/unix/unix.cmi primitives.cmi \ input_handling.cmi input_handling.cmx: ../otherlibs/unix/unix.cmx primitives.cmx \ input_handling.cmi int64ops.cmo: int64ops.cmi int64ops.cmx: int64ops.cmi -lexer.cmo: primitives.cmi parser.cmi lexer.cmi -lexer.cmx: primitives.cmx parser.cmx lexer.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 debugger_config.cmi ../typing/ctype.cmi ../utils/config.cmi \ - loadprinter.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 debugger_config.cmx ../typing/ctype.cmx ../utils/config.cmx \ - loadprinter.cmi + dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi main.cmo: unix_tools.cmi ../otherlibs/unix/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 \ + show_information.cmi question.cmi program_management.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 ../otherlibs/unix/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 \ + show_information.cmx question.cmx program_management.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 ../utils/misc.cmi envaux.cmi \ +parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi -parameters.cmx: primitives.cmx ../utils/misc.cmx envaux.cmx \ +parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi -parser.cmo: primitives.cmi parser_aux.cmi ../parsing/longident.cmi \ - int64ops.cmi input_handling.cmi parser.cmi -parser.cmx: primitives.cmx parser_aux.cmi ../parsing/longident.cmx \ - int64ops.cmx input_handling.cmx parser.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 @@ -158,49 +152,47 @@ primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi primitives.cmx: ../otherlibs/unix/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 ../utils/misc.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 ../utils/misc.cmx \ + ../typing/outcometree.cmi ../typing/oprint.cmx \ ../toplevel/genprintval.cmx debugcom.cmx printval.cmi program_loading.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi primitives.cmi \ - parameters.cmi ../utils/misc.cmi input_handling.cmi debugger_config.cmi \ - program_loading.cmi + parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi program_loading.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx primitives.cmx \ - parameters.cmx ../utils/misc.cmx input_handling.cmx debugger_config.cmx \ - program_loading.cmi + parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi program_management.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ - primitives.cmi parameters.cmi ../utils/misc.cmi int64ops.cmi \ - ../bytecomp/instruct.cmi input_handling.cmi history.cmi \ - debugger_config.cmi debugcom.cmi breakpoints.cmi program_management.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 ../otherlibs/unix/unix.cmx \ time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ - primitives.cmx parameters.cmx ../utils/misc.cmx int64ops.cmx \ - ../bytecomp/instruct.cmx input_handling.cmx history.cmx \ - debugger_config.cmx debugcom.cmx breakpoints.cmx program_management.cmi + 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 show_source.cmi printval.cmi primitives.cmi \ +show_information.cmo: symbols.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 show_source.cmx printval.cmx primitives.cmx \ +show_information.cmx: symbols.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 ../utils/misc.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 ../utils/misc.cmx \ +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 ../utils/config.cmi source.cmi -source.cmx: primitives.cmx ../utils/misc.cmx ../utils/config.cmx source.cmi -symbols.cmo: ../bytecomp/symtable.cmi primitives.cmi ../bytecomp/instruct.cmi \ - events.cmi debugger_config.cmi debugcom.cmi checkpoints.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 ../bytecomp/instruct.cmi events.cmi \ + debugger_config.cmi debugcom.cmi checkpoints.cmi \ ../bytecomp/bytesections.cmi symbols.cmi -symbols.cmx: ../bytecomp/symtable.cmx primitives.cmx ../bytecomp/instruct.cmx \ - events.cmx debugger_config.cmx debugcom.cmx checkpoints.cmx \ +symbols.cmx: ../bytecomp/symtable.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 \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index b8fd444f4..9d85aff04 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -20,7 +20,6 @@ open Debugcom open Instruct open Primitives open Printf -open Source (*** Debugging. ***) let debug_breakpoints = ref false @@ -68,7 +67,7 @@ let rec breakpoints_at_pc pc = [] end @ - List.map fst (filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) + List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) (* Is there a breakpoint at `pc' ? *) let breakpoint_at_pc pc = @@ -155,7 +154,7 @@ let remove_position pos = let count = List.assoc pos !positions in decr count; if !count = 0 then begin - positions := assoc_remove !positions pos; + positions := List.remove_assoc pos !positions; new_version () end @@ -181,7 +180,7 @@ let remove_breakpoint number = let pos = ev.ev_pos in Exec.protect (function () -> - breakpoints := assoc_remove !breakpoints number; + breakpoints := List.remove_assoc number !breakpoints; remove_position pos; printf "Removed breakpoint %d at %d : %s" number ev.ev_pos (Pos.get_desc ev); @@ -210,7 +209,7 @@ let exec_with_temporary_breakpoint pc funct = let count = List.assoc pc !positions in decr count; if !count = 0 then begin - positions := assoc_remove !positions pc; + positions := List.remove_assoc pc !positions; reset_instr pc; Symbols.set_event_at_pc pc end diff --git a/debugger/command_line.ml b/debugger/command_line.ml index f37d529b3..27dbd3472 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -87,7 +87,7 @@ let eol = end_of_line Lexer.lexeme let matching_elements list name instr = - filter (function a -> isprefix instr (name a)) !list + List.filter (function a -> isprefix instr (name a)) !list let all_matching_instructions = matching_elements instruction_list (fun i -> i.instr_name) @@ -97,7 +97,7 @@ let all_matching_instructions = let matching_instructions instr = let all = all_matching_instructions instr in - let prio = filter (fun i -> i.instr_prio) all in + let prio = List.filter (fun i -> i.instr_prio) all in if prio = [] then all else prio let matching_variables = @@ -143,6 +143,11 @@ let add_breakpoint_after_pc pc = 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 -> @@ -235,14 +240,24 @@ let instr_dir ppf lexbuf = 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 - List.iter (function x -> add_path (expand_path x)) - (List.rev new_directory); + 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 + 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; @@ -562,7 +577,7 @@ let instr_break ppf lexbuf = raise Toplevel end | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *) - let module_name = convert_module mdle in + let module_name = convert_module (module_of_longident mdle) in new_breakpoint (try let buffer = @@ -585,7 +600,7 @@ let instr_break ppf lexbuf = raise Toplevel) | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) try - new_breakpoint (event_near_pos (convert_module mdle) position) + new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position) with | Not_found -> eprintf "Can't find any event there.@." @@ -697,7 +712,7 @@ let instr_list ppf lexbuf = | Not_found -> ("", -1) in - let mdle = convert_module mo in + let mdle = convert_module (module_of_longident mo) in let pos = Lexing.dummy_pos in let beginning = match beg with @@ -841,7 +856,7 @@ let info_breakpoints ppf lexbuf = let info_events ppf lexbuf = ensure_loaded (); - let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in + 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 diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 13e3f086c..ee707abb2 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -62,6 +62,8 @@ 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.*) diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 44f4fe582..d3185f083 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -25,6 +25,7 @@ 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. ***) diff --git a/debugger/dynlink.ml b/debugger/dynlink.ml index 6f4fe5af7..7d3e347f5 100644 --- a/debugger/dynlink.ml +++ b/debugger/dynlink.ml @@ -34,6 +34,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error @@ -96,9 +97,20 @@ let default_available_units () = (* Initialize the linker tables and everything *) +let inited = ref false + let init () = - default_crcs := Symtable.init_toplevel(); - default_available_units () + if not !inited then begin + default_crcs := Symtable.init_toplevel(); + default_available_units (); + inited := true; + end + +let clear_available_units () = init(); clear_available_units () +let allow_only l = init(); allow_only l +let prohibit l = init(); prohibit l +let add_available_units l = init(); add_available_units l +let default_available_units () = init(); default_available_units () (* Read the CRC of an interface from its .cmi file *) @@ -186,6 +198,7 @@ let load_compunit ic file_name compunit = end let loadfile file_name = + init(); let ic = open_in_bin file_name in try let buffer = String.create (String.length Config.cmo_magic_number) in @@ -213,6 +226,7 @@ let loadfile file_name = close_in ic; raise exc let loadfile_private file_name = + init(); let initial_symtable = Symtable.current_state() and initial_crc = !crc_interfaces in try @@ -250,3 +264,8 @@ let error_message = function "cannot find file " ^ name ^ " in search path" | Cannot_open_dll reason -> "error loading shared library: " ^ reason + | Inconsistent_implementation name -> + "implementation mismatch on " ^ name + +let is_native = false +let adapt_filename f = f diff --git a/debugger/dynlink.mli b/debugger/dynlink.mli index ac5c1a211..caee29171 100644 --- a/debugger/dynlink.mli +++ b/debugger/dynlink.mli @@ -13,19 +13,20 @@ (* $Id$ *) -(** Dynamic loading of bytecode object files. *) +(** Dynamic loading of object files. *) -(** {6 Initialization} *) +val is_native: bool +(** [true] if the program is native, + [false] if the program is bytecode. *) -val init : unit -> unit -(** Initialize the [Dynlink] library. - Must be called before any other function in this module. *) - -(** {6 Dynamic loading of compiled bytecode files} *) +(** {6 Dynamic loading of compiled files} *) val loadfile : string -> unit -(** Load the given bytecode object file ([.cmo] file) or - bytecode library file ([.cma] file), and link it with the running program. +(** In bytecode: load the given bytecode object file ([.cmo] file) or + bytecode library file ([.cma] file), and link it with the running + program. In native code: load the given OCaml plugin file (usually + [.cmxs]), and link it with the running + program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to access value names defined by the unit. Therefore, the unit @@ -37,6 +38,10 @@ val loadfile_private : string -> unit are hidden (cannot be referenced) from other modules dynamically loaded afterwards. *) +val adapt_filename : string -> string +(** In bytecode, the identity function. In native code, replace the last + extension with [.cmxs]. *) + (** {6 Access control} *) val allow_only: string list -> unit @@ -68,7 +73,8 @@ val allow_unsafe_modules : bool -> unit dynamically linked. A compilation unit is ``unsafe'' if it contains declarations of external functions, which can break type safety. By default, dynamic linking of unsafe object files is - not allowed. *) + not allowed. In native code, this function does nothing; object files + with external functions are always allowed to be dynamically linked. *) (** {6 Deprecated, low-level API for access control} *) @@ -77,7 +83,8 @@ val allow_unsafe_modules : bool -> unit since the default initialization of allowed units, along with the [allow_only] and [prohibit] function, provides a better, safer mechanism to control access to program units. The three functions - below are provided for backward compatibility only. *) + below are provided for backward compatibility only and are not + available in native code. *) val add_interfaces : string list -> string list -> unit (** [add_interfaces units path] grants dynamically-linked object @@ -97,6 +104,12 @@ val clear_available_units : unit -> unit (** Empty the list of compilation units accessible to dynamically-linked programs. *) +(** {6 Deprecated, initialization} *) + +val init : unit -> unit +(** @deprecated Initialize the [Dynlink] library. This function is called + automatically when needed. *) + (** {6 Error reporting} *) type linking_error = @@ -113,6 +126,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error (** Errors in dynamic linking are reported by raising the [Error] diff --git a/debugger/envaux.ml b/debugger/envaux.ml index ba8d6dff5..7f74ecbf7 100644 --- a/debugger/envaux.ml +++ b/debugger/envaux.ml @@ -23,7 +23,7 @@ type error = exception Error of error let env_cache = - (Hashtbl.create 59 : (Env.summary, Env.t) Hashtbl.t) + (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) let reset_cache () = Hashtbl.clear env_cache; @@ -34,45 +34,46 @@ let extract_sig env mty = Tmty_signature sg -> sg | _ -> fatal_error "Envaux.extract_sig" -let rec env_from_summary sum = +let rec env_from_summary sum subst = try - Hashtbl.find env_cache sum + 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 desc (env_from_summary s) + Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst) | Env_type(s, id, desc) -> - Env.add_type id desc (env_from_summary s) + Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst) | Env_exception(s, id, desc) -> - Env.add_exception id desc (env_from_summary s) + Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst) | Env_module(s, id, desc) -> - Env.add_module id desc (env_from_summary s) + Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst) | Env_modtype(s, id, desc) -> - Env.add_modtype id desc (env_from_summary s) + Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) | Env_class(s, id, desc) -> - Env.add_class id desc (env_from_summary s) + Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst) | Env_cltype (s, id, desc) -> - Env.add_cltype id desc (env_from_summary s) + Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) | Env_open(s, path) -> - let env = env_from_summary s in + let env = env_from_summary s subst in + let path' = Subst.module_path subst path in let mty = try - Env.find_module path env + Env.find_module path' env with Not_found -> - raise (Error (Module_not_found path)) + raise (Error (Module_not_found path')) in - Env.open_signature path (extract_sig env mty) env + Env.open_signature path' (extract_sig env mty) env in - Hashtbl.add env_cache sum env; + 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 + | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst (* Error report *) diff --git a/debugger/eval.ml b/debugger/eval.ml index d12dfa803..abec4291a 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -13,7 +13,6 @@ (* $Id$ *) -open Debugger_config open Misc open Path open Instruct @@ -42,7 +41,9 @@ let abstract_type = let rec path event = function Pident id -> if Ident.global id then - Debugcom.Remote_value.global (Symtable.get_global_position id) + 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 -> @@ -88,8 +89,8 @@ let rec expression event env = function end | E_result -> begin match event with - Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 -> - (Debugcom.Remote_value.accu(), ty) + 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 @@ -178,15 +179,14 @@ let report_error ppf = function | Tuple_index(ty, len, pos) -> Printtyp.reset_and_mark_loops ty; fprintf ppf - "@[Cannot extract field number %i from a %i-components \ - tuple of type@ %a@]@." + "@[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 array of length %i@]@." pos len + "@[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 list of length %i@]@." pos len + "@[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@ \ diff --git a/debugger/events.ml b/debugger/events.ml index d9229712a..2521c064d 100644 --- a/debugger/events.ml +++ b/debugger/events.ml @@ -16,8 +16,6 @@ (********************************* Events ******************************) open Instruct -open Primitives -open Checkpoints let get_pos ev = match ev.ev_kind with diff --git a/debugger/frames.ml b/debugger/frames.ml index a2e42087e..7260f89d5 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -16,9 +16,7 @@ (***************************** Frames **********************************) open Instruct -open Primitives open Debugcom -open Checkpoints open Events open Symbols diff --git a/debugger/history.ml b/debugger/history.ml index 31a6e7ad2..e8c5ed8ff 100644 --- a/debugger/history.ml +++ b/debugger/history.ml @@ -15,7 +15,6 @@ open Int64ops open Checkpoints -open Misc open Primitives open Debugger_config diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml index dec3f86cc..f25d47426 100644 --- a/debugger/input_handling.ml +++ b/debugger/input_handling.ml @@ -30,7 +30,7 @@ let add_file file controller = (* Remove a file from the list of actives files. *) let remove_file file = - active_files := assoc_remove !active_files file.io_fd + active_files := List.remove_assoc file.io_fd !active_files (* Change the controller for the given file. *) let change_controller file controller = diff --git a/debugger/lexer.mll b/debugger/lexer.mll index 17293f62c..eea8ed028 100644 --- a/debugger/lexer.mll +++ b/debugger/lexer.mll @@ -15,7 +15,6 @@ { -open Primitives open Parser } diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 0b2ef0339..07d7b78ae 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -15,7 +15,6 @@ (* Loading and installation of user-defined printer functions *) open Misc -open Debugger_config open Longident open Path open Types diff --git a/debugger/main.ml b/debugger/main.ml index fda242bc5..9cfcf447f 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -13,8 +13,6 @@ (* $Id$ *) -open Primitives -open Misc open Input_handling open Question open Command_line @@ -47,12 +45,12 @@ let rec protect ppf restart loop = !current_checkpoint.c_pid; pp_print_flush ppf (); stop_user_input (); - loop ppf) + restart ppf) | Toplevel -> protect ppf restart (function ppf -> pp_print_flush ppf (); stop_user_input (); - loop ppf) + restart ppf) | Sys.Break -> protect ppf restart (function ppf -> fprintf ppf "Interrupted.@."; @@ -62,7 +60,7 @@ let rec protect ppf restart loop = try_select_frame 0; show_current_event ppf; end); - loop ppf) + restart ppf) | Current_checkpoint_lost -> protect ppf restart (function ppf -> fprintf ppf "Trying to recover...@."; @@ -70,7 +68,7 @@ let rec protect ppf restart loop = recover (); try_select_frame 0; show_current_event ppf; - loop ppf) + restart ppf) | Current_checkpoint_lost_start_at (time, init_duration) -> protect ppf restart (function ppf -> let b = diff --git a/debugger/parameters.ml b/debugger/parameters.ml index 67078b2fc..9d518e549 100644 --- a/debugger/parameters.ml +++ b/debugger/parameters.ml @@ -17,7 +17,7 @@ open Primitives open Config -open Misc +open Debugger_config let program_loaded = ref false let program_name = ref "" @@ -31,5 +31,9 @@ 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/debugger/parameters.mli b/debugger/parameters.mli index c80d39d12..8f750e68a 100644 --- a/debugger/parameters.mli +++ b/debugger/parameters.mli @@ -21,6 +21,7 @@ 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/debugger/parser.mly b/debugger/parser.mly index 6c7b2ddb2..c94182f6b 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -16,7 +16,6 @@ %{ open Int64ops -open Primitives open Input_handling open Longident open Parser_aux @@ -93,7 +92,7 @@ open Parser_aux %type <Parser_aux.break_arg> break_argument_eol %start list_arguments_eol -%type <string option * int option * int option> list_arguments_eol +%type <Longident.t option * int option * int option> list_arguments_eol %start end_of_line %type <unit> end_of_line @@ -101,6 +100,12 @@ open Parser_aux %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 */ @@ -173,7 +178,15 @@ module_path : ; longident_eol : - longident end_of_line { $1 }; + longident end_of_line { $1 }; + +opt_longident : + UIDENT { Some (Lident $1) } + | module_path DOT UIDENT { Some (Ldot($1, $3)) } + | { None }; + +opt_longident_eol : + opt_longident end_of_line { $1 }; identifier : LIDENT { $1 } @@ -220,16 +233,16 @@ break_argument_eol : end_of_line { BA_none } | integer_eol { BA_pc $1 } | expression end_of_line { BA_function $1 } - | AT opt_identifier INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} - | AT opt_identifier SHARP integer_eol { BA_pos2 ($2, $4) } + | 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_identifier integer opt_integer_eol + opt_longident integer opt_integer_eol { ($1, Some $2, $3) } - | opt_identifier_eol + | opt_longident_eol { ($1, None, None) }; /* End of line */ diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index 7ea63fb8c..434c14dbc 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -28,7 +28,7 @@ type break_arg = BA_none (* break *) | BA_pc of int (* break PC *) | BA_function of expression (* break FUNCTION *) - | BA_pos1 of string option * int * int option + | BA_pos1 of Longident.t option * int * int option (* break @ [MODULE] LINE [POS] *) - | BA_pos2 of string option * int (* break @ [MODULE] # OFFSET *) + | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *) diff --git a/debugger/primitives.ml b/debugger/primitives.ml index 1ad27e8a6..d4ba22e5f 100644 --- a/debugger/primitives.ml +++ b/debugger/primitives.ml @@ -36,26 +36,6 @@ let index a l = | b::l -> if a = b then i else index_rec (i + 1) l in index_rec 0 l -(* Remove an element from an association list *) -let assoc_remove lst elem = - let rec remove = - function - [] -> [] - | ((a, _) as c::t) -> - if a = elem then t - else c::(remove t) - in remove lst - -(* Nth element of a list. *) -let rec list_nth p0 p1 = - match (p0,p1) with - ([], _) -> - invalid_arg "list_nth" - | ((a::_), 0) -> - a - | ((_::l), n) -> - list_nth l (n - 1) - (* Return the `n' first elements of `l' *) (* ### n l -> l' *) let rec list_truncate = @@ -87,44 +67,8 @@ let list_replace x y = else a::(repl l) in repl -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -let filter p = - let rec filter2 = - function - [] -> - [] - | a::l -> - if p a then - a::(filter2 l) - else - filter2 l - in filter2 - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* ### predicate list -> element *) -let find p = - let rec find2 = - function - [] -> - raise Not_found - | a::l -> - if p a then a - else find2 l - in find2 - (*** Operations on strings. ***) -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -let string_pos s c = - let i = ref 0 and l = String.length s in - while !i < l && String.get s !i != c do i := !i + 1 done; - if !i = l then raise Not_found; - !i - (* Remove blanks (spaces and tabs) at beginning and end of a string. *) let is_space = function | ' ' | '\t' -> true | _ -> false diff --git a/debugger/primitives.mli b/debugger/primitives.mli index 40effea55..4333128fb 100644 --- a/debugger/primitives.mli +++ b/debugger/primitives.mli @@ -29,12 +29,6 @@ val except : 'a -> 'a list -> 'a list (* Position of an element in a list. Head of list has position 0. *) val index : 'a -> 'a list -> int -(* Remove on element from an association list. *) -val assoc_remove : ('a * 'b) list -> 'a -> ('a * 'b) list - -(* Nth element of a list. *) -val list_nth : 'a list -> int -> 'a - (* Return the `n' first elements of `l'. *) (* ### n l -> l' *) val list_truncate : int -> 'a list -> 'a list @@ -47,23 +41,8 @@ val list_truncate2 : int -> 'a list -> 'a list * 'a list (* ### x y l -> l' *) val list_replace : 'a -> 'a -> 'a list -> 'a list -(* Filter `list' according to `predicate'. *) -(* ### predicate list -> list' *) -val filter : ('a -> bool) -> 'a list -> 'a list - -(* Find the first element `element' of `list' *) -(* so that `predicate element' holds. *) -(* Raise `Not_found' if no such element. *) -(* ### predicate list -> element *) -val find : ('a -> bool) -> 'a list -> 'a - (*** Operations on strings. ***) -(* Return the position of the first occurence of char `c' in string `s' *) -(* Raise `Not_found' if `s' does not contain `c'. *) -(* ### c s -> pos *) -val string_pos : string -> char -> int - (* Remove blanks (spaces and tabs) at beginning and end of a string. *) val string_trim : string -> string diff --git a/debugger/printval.ml b/debugger/printval.ml index 4fa3055b0..0e37bad6b 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -15,8 +15,6 @@ (* To print values *) -open Misc -open Obj open Format open Parser_aux open Path diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 1a750a2bb..79577ff4b 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -16,7 +16,6 @@ (* Program loading *) open Unix -open Misc open Debugger_config open Parameters open Input_handling diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 35f74d654..cc908b4d6 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -19,13 +19,10 @@ open Int64ops open Unix open Unix_tools open Debugger_config -open Misc -open Instruct open Primitives open Parameters open Input_handling open Question -open Debugcom open Program_loading open Time_travel diff --git a/debugger/show_information.ml b/debugger/show_information.ml index de6817cd2..15176a1f2 100644 --- a/debugger/show_information.ml +++ b/debugger/show_information.ml @@ -15,7 +15,6 @@ open Instruct open Format -open Primitives open Debugcom open Checkpoints open Events diff --git a/debugger/show_source.ml b/debugger/show_source.ml index b60a1f9e4..3b7a133fe 100644 --- a/debugger/show_source.ml +++ b/debugger/show_source.ml @@ -15,7 +15,6 @@ open Debugger_config open Instruct -open Misc open Parameters open Primitives open Printf diff --git a/debugger/source.ml b/debugger/source.ml index f1519b438..8975134ff 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -23,17 +23,37 @@ 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 !Config.load_path (mdle ^ ext) + 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 !Config.load_path fname + find_in_path path fname else fname diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 8ed7545c6..235e2af34 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -92,7 +92,7 @@ let read_symbols bytecode_file = modules := md :: !modules; Hashtbl.add all_events_by_module md sorted_evl; let real_evl = - Primitives.filter + List.filter (function {ev_kind = Event_pseudo} -> false | _ -> true) diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index 4e8e13822..a4a4c83fa 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -384,7 +384,7 @@ let kill_all_checkpoints () = (* --- Assume that the checkpoint is valid. *) let forget_process fd pid = let checkpoint = - find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) + List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) in Printf.eprintf "Lost connection with process %d" pid; let kont = diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index 5328a2aad..9926e05d5 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -22,7 +22,7 @@ open Primitives (*** Convert a socket name into a socket address. ***) let convert_address address = try - let n = string_pos address ':' in + 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 @@ -90,7 +90,7 @@ let search_in_path name = let rec expand_path ch = let rec subst_variable ch = try - let pos = string_pos ch '$' in + let pos = String.index ch '$' in if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then (String.sub ch 0 (pos + 1)) ^ (subst_variable @@ -121,7 +121,7 @@ let rec expand_path ch = in if ch.[0] = '~' then try - match string_pos ch '/' with + match String.index ch '/' with 1 -> (let tail = String.sub ch 2 (String.length ch - 2) in |