PR#4541 make debugger compatible with fork()

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10287 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 50 insertions, 2 deletions

diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index 5fdf3da472..babb65bbe7 100644
--- a/debugger/command_line.ml
+++ b/debugger/command_line.ml
@@ -807,6 +807,22 @@ let loading_mode_variable ppf =
       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 =
@@ -1106,7 +1122,14 @@ It can be either :\n\
        var_action = integer_variable false 1 "Must be at least 1"
                                      max_printer_steps;
        var_help =
-"maximal number of value nodes printed." }];
+"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 *)
diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
index 5bfbb2bfa8..dfe905bac4 100644
--- a/debugger/debugcom.ml
+++ b/debugger/debugcom.ml
@@ -22,8 +22,25 @@ open Primitives
 
 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
+  conn := io_chan;
+  update_follow_fork_mode ()
 
 (* Modify the program code *)
 
diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli
index 6c7a534462..abf4fd0b2c 100644
--- a/debugger/debugcom.mli
+++ b/debugger/debugcom.mli
@@ -32,6 +32,10 @@ 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
 
@@ -76,6 +80,10 @@ 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