diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 41453d1cc6a984c88530e7172ff11e7987fd4b0e..0a90c92402cd00bcf2ea2fc3672b4a39e1830bcb 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -244,6 +244,8 @@ UINT __gnat_current_ccs_encoding; #include "adaint.h" +int __gnat_in_child_after_fork = 0; + #if defined (__APPLE__) && defined (st_mtime) #define st_atim st_atimespec #define st_mtim st_mtimespec @@ -2421,6 +2423,7 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED) if (pid == 0) { /* The child. */ + __gnat_in_child_after_fork = 1; if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) _exit (1); } diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 4f42f6c658dd93f604d23fa70f58fcf47e04b193..85997b9ba6858e22da8897e96ca48ec702b93aec 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -139,7 +139,15 @@ struct file_attributes { * fit the above struct on any system) */ -extern int __gnat_max_path_len; +extern int __gnat_max_path_len; +extern int __gnat_in_child_after_fork; +/* This flag expresses the state when the fork call just returned zero result, + * i.e. when the new born child process is created and the new executable is + * not loaded yet. It is used to e.g. disable tracing memory + * allocation/deallocation in memtrack.adb just after fork returns in the child + * process to avoid both parent and child writing to the same gmem.out file + * simultaneously */ + extern OS_Time __gnat_current_time (void); extern void __gnat_current_time_string (char *); extern void __gnat_to_gm_time (OS_Time *, int *, int *, diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 718886d96bdbede71d8026a0a43340045662fd4f..30c5b8e636839fe93fa82f9a1fc6618582aae3a9 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -39,6 +39,7 @@ #include "system.h" #endif +#include "adaint.h" #include <sys/types.h> #ifdef __MINGW32__ @@ -78,7 +79,6 @@ #include <process.h> #include <signal.h> #include <io.h> -#include "adaint.h" #include "mingw32.h" int @@ -360,7 +360,11 @@ __gnat_pipe (int *fd) int __gnat_expect_fork (void) { - return fork (); + int pid = fork(); + if (pid == 0) { + __gnat_in_child_after_fork = 1; + } + return pid; } void diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb index bd3479697234671774ad087fa2cce326d5e0f785..a5f508d9e0339cd3ed685645261ed3d29cfec45d 100644 --- a/gcc/ada/libgnat/memtrack.adb +++ b/gcc/ada/libgnat/memtrack.adb @@ -102,6 +102,9 @@ package body System.Memory is pragma Import (C, OS_Exit, "__gnat_os_exit"); pragma No_Return (OS_Exit); + In_Child_After_Fork : Integer; + pragma Import (C, In_Child_After_Fork, "__gnat_in_child_after_fork"); + procedure fwrite (Ptr : System.Address; Size : size_t; @@ -149,6 +152,24 @@ package body System.Memory is -- themselves do dynamic allocation. We use First_Call flag to avoid -- infinite recursion + function Allow_Trace return Boolean; + pragma Inline (Allow_Trace); + -- Check if the memory trace is allowed + + ----------------- + -- Allow_Trace -- + ----------------- + + function Allow_Trace return Boolean is + begin + if First_Call then + First_Call := False; + return In_Child_After_Fork = 0; + else + return False; + end if; + end Allow_Trace; + ----------- -- Alloc -- ----------- @@ -176,14 +197,12 @@ package body System.Memory is Result := c_malloc (Actual_Size); - if First_Call then + if Allow_Trace then -- Logs allocation call -- format is: -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> - First_Call := False; - if Needs_Init then Gmem_Initialize; end if; @@ -243,14 +262,12 @@ package body System.Memory is begin Lock_Task.all; - if First_Call then + if Allow_Trace then -- Logs deallocation call -- format is: -- 'D' <mem addr> <len backtrace> <addr1> ... <addrn> - First_Call := False; - if Needs_Init then Gmem_Initialize; end if; @@ -334,9 +351,7 @@ package body System.Memory is Abort_Defer.all; Lock_Task.all; - if First_Call then - First_Call := False; - + if Allow_Trace then -- We first log deallocation call if Needs_Init then