PR#4541 make debugger compatible with fork()

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

8 files changed, 94 insertions, 19 deletions

diff --git a/asmrun/Makefile b/asmrun/Makefile
index 633ce5254..3e37ab1ea 100644
--- a/asmrun/Makefile
+++ b/asmrun/Makefile
@@ -26,7 +26,7 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \
   misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \
   floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \
   gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \
-  compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o
+  compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o
 
 ASMOBJS=$(ARCH).o
 
@@ -142,12 +142,14 @@ dynlink.c: ../byterun/dynlink.c
 	ln -s ../byterun/dynlink.c dynlink.c
 signals.c: ../byterun/signals.c
 	ln -s ../byterun/signals.c signals.c
+debugger.c: ../byterun/debugger.c
+	ln -s ../byterun/debugger.c debugger.c
 
 LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
   compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
   parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
   weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \
-  dynlink.c signals.c
+  dynlink.c signals.c debugger.c
 
 clean::
 	rm -f $(LINKEDFILES)
diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt
index ca24bc71a..9a067f8f0 100644
--- a/asmrun/Makefile.nt
+++ b/asmrun/Makefile.nt
@@ -30,7 +30,7 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
   compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
   parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
   weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \
-  dynlink.c signals.c
+  dynlink.c signals.c debugger.c
 
 ifeq ($(TOOLCHAIN),mingw)
 ASMOBJS=$(ARCH).o
diff --git a/byterun/debugger.c b/byterun/debugger.c
index 3639c43bb..f9689126a 100644
--- a/byterun/debugger.c
+++ b/byterun/debugger.c
@@ -13,7 +13,7 @@
 
 /* $Id$ */
 
-/* Interface with the debugger */
+/* Interface with the byte-code debugger */
 
 #ifdef _WIN32
 #include <io.h>
@@ -23,20 +23,13 @@
 
 #include "config.h"
 #include "debugger.h"
-#include "fail.h"
-#include "fix_code.h"
-#include "instruct.h"
-#include "intext.h"
-#include "io.h"
 #include "misc.h"
-#include "mlvalues.h"
-#include "stacks.h"
-#include "sys.h"
 
 int caml_debugger_in_use = 0;
 uintnat caml_event_count;
+int caml_debugger_fork_mode = 1; /* parent by default */
 
-#if !defined(HAS_SOCKETS)
+#if !defined(HAS_SOCKETS) || defined(NATIVE_CODE)
 
 void caml_debugger_init(void)
 {
@@ -46,6 +39,10 @@ void caml_debugger(enum event_kind event)
 {
 }
 
+void caml_debugger_cleanup_fork(void)
+{
+}
+
 #else
 
 #ifdef HAS_UNISTD
@@ -67,6 +64,15 @@ void caml_debugger(enum event_kind event)
 #include <process.h>
 #endif
 
+#include "fail.h"
+#include "fix_code.h"
+#include "instruct.h"
+#include "intext.h"
+#include "io.h"
+#include "mlvalues.h"
+#include "stacks.h"
+#include "sys.h"
+
 static int sock_domain;         /* Socket domain for the debugger */
 static union {                  /* Socket address for the debugger */
   struct sockaddr s_gen;
@@ -109,7 +115,7 @@ static void open_connection(void)
 #endif
   if (dbg_socket == -1 ||
       connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){
-    caml_fatal_error_arg2 ("cannot connect to debugger at %s", dbg_addr,
+    caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", dbg_addr,
                            "error: %s\n", strerror (errno));
   }
 #ifdef _WIN32
@@ -412,8 +418,19 @@ void caml_debugger(enum event_kind event)
       caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t));
       caml_flush(dbg_out);
       break;
+    case REQ_SET_FORK_MODE:
+      caml_debugger_fork_mode = caml_getword(dbg_in);
+      break;
     }
   }
 }
 
+void caml_debugger_cleanup_fork(void)
+{
+  /* We could remove all of the breakpoints, but closing the connection
+   * means that they'll just be skipped anyway. */
+  close_connection();
+  caml_debugger_in_use = 0;
+}
+
 #endif
diff --git a/byterun/debugger.h b/byterun/debugger.h
index ce479d271..57a58f1c6 100644
--- a/byterun/debugger.h
+++ b/byterun/debugger.h
@@ -21,8 +21,8 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-extern int caml_debugger_in_use;
-extern int running;
+CAMLextern int caml_debugger_in_use;
+CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */
 extern uintnat caml_event_count;
 
 enum event_kind {
@@ -32,6 +32,7 @@ enum event_kind {
 
 void caml_debugger_init (void);
 void caml_debugger (enum event_kind event);
+void caml_debugger_cleanup_fork (void);
 
 /* Communication protocol */
 
@@ -84,9 +85,11 @@ enum debugger_request {
   REQ_MARSHAL_OBJ = 'M',        /* mlvalue v */
   /* Send a copy of the data structure rooted at v, using the same
      format as [caml_output_value]. */
-  REQ_GET_CLOSURE_CODE = 'C'    /* mlvalue v */
+  REQ_GET_CLOSURE_CODE = 'C',   /* mlvalue v */
   /* Send the code address of the given closure.
      Reply is one uint32. */
+  REQ_SET_FORK_MODE = 'K'       /* uint32 m */
+  /* Set whether to follow the child (m=0) or the parent on fork. */
 };
 
 /* Replies to a REQ_GO request. All replies are followed by three uint32:
diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index 5fdf3da47..babb65bbe 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 5bfbb2bfa..dfe905bac 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 6c7a53446..abf4fd0b2 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
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index 428137dcb..74ec6294d 100644
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -14,6 +14,7 @@
 /* $Id$ */
 
 #include <mlvalues.h>
+#include <debugger.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_fork(value unit)
@@ -21,5 +22,9 @@ CAMLprim value unix_fork(value unit)
   int ret;
   ret = fork();
   if (ret == -1) uerror("fork", Nothing);
+  if (caml_debugger_in_use)
+    if ((caml_debugger_fork_mode && ret == 0) ||
+        (!caml_debugger_fork_mode && ret != 0))
+      caml_debugger_cleanup_fork();
   return Val_int(ret);
 }