2007-06-11 Bob Duff <duff@adacore.com>

	    Thomas Quinot  <quinot@adacore.com>

	* g-stsifd-sockets.adb (Create): Work around strange behavior of
	'bind' on windows that causes 'connect' to fail intermittently, by
	retrying the 'bind'.
	(GNAT.Sockets.Thin.Signalling_Fds): New procedure Close.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125612 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 101 insertions, 58 deletions

diff --git a/gcc/ada/g-stsifd-sockets.adb b/gcc/ada/g-stsifd-sockets.adb
index eb480b90328..02c852cad86 100644
--- a/gcc/ada/g-stsifd-sockets.adb
+++ b/gcc/ada/g-stsifd-sockets.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 2001-2006, AdaCore                     --
+--                     Copyright (C) 2001-2007, AdaCore                     --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -37,10 +37,23 @@
 --  Note: this code used to be in GNAT.Sockets, but has been moved to a
 --  platform-specific file. It is now used only for non-UNIX platforms.
 
-separate
-  (GNAT.Sockets.Thin)
+separate (GNAT.Sockets.Thin)
 package body Signalling_Fds is
 
+   -----------
+   -- Close --
+   -----------
+
+   procedure Close (Sig : C.int) is
+      Res : C.int;
+      pragma Unreferenced (Res);
+      --  Res is assigned but never read, because we purposefully ignore
+      --  any error returned by the C_Close system call, as per the spec
+      --  of this procedure.
+   begin
+      Res := C_Close (Sig);
+   end Close;
+
    ------------
    -- Create --
    ------------
@@ -50,83 +63,111 @@ package body Signalling_Fds is
       --  Listening socket, read socket and write socket
 
       Sin : aliased Sockaddr_In;
-      Len : aliased C.int := Sin'Size / 8;
+      Len : aliased C.int;
       --  Address of listening socket
 
       Res : C.int;
       --  Return status of system calls
 
-      Err : Integer;
-      --  Saved errno value
-
    begin
-      Fds (Read_End)  := Failure;
-      Fds (Write_End) := Failure;
+      Fds.all := (Read_End | Write_End => Failure);
 
       --  We open two signalling sockets. One of them is used to send data
       --  to the other, which is included in a C_Select socket set. The
       --  communication is used to force the call to C_Select to complete,
       --  and the waiting task to resume its execution.
 
-      --  Create a listening socket
+      loop
+         --  Retry loop, in case the C_Connect below fails
 
-      L_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
+         --  Create a listening socket
 
-      if L_Sock = Failure then
-         goto Fail;
-      end if;
+         L_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 
-      --  Bind the socket to an available port on localhost
+         if L_Sock = Failure then
+            goto Fail;
+         end if;
 
-      Sin.Sin_Addr.S_B1 := 127;
-      Sin.Sin_Addr.S_B2 := 0;
-      Sin.Sin_Addr.S_B3 := 0;
-      Sin.Sin_Addr.S_B4 := 1;
-      Sin.Sin_Port := 0;
+         --  Bind the socket to an available port on localhost
 
-      Res := C_Bind (L_Sock, Sin'Address, Len);
+         Len := Sin'Size / 8;
+         Set_Length (Sin'Unchecked_Access, Len);
+         Sin.Sin_Family    := Constants.AF_INET;
+         Sin.Sin_Addr.S_B1 := 127;
+         Sin.Sin_Addr.S_B2 := 0;
+         Sin.Sin_Addr.S_B3 := 0;
+         Sin.Sin_Addr.S_B4 := 1;
+         Sin.Sin_Port      := 0;
 
-      if Res = Failure then
-         goto Fail;
-      end if;
+         Res := C_Bind (L_Sock, Sin'Address, Len);
 
-      --  Get assigned port
+         if Res = Failure then
+            goto Fail;
+         end if;
 
-      Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
-      if Res = Failure then
-         goto Fail;
-      end if;
+         --  Get assigned port
 
-      --  Set socket to listen mode, with a backlog of 1 to guarantee that
-      --  exactly one call to connect(2) succeeds.
+         Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
+         if Res = Failure then
+            goto Fail;
+         end if;
 
-      Res := C_Listen (L_Sock, 1);
+         --  Set socket to listen mode, with a backlog of 1 to guarantee that
+         --  exactly one call to connect(2) succeeds.
 
-      if Res = Failure then
-         goto Fail;
-      end if;
+         Res := C_Listen (L_Sock, 1);
 
-      --  Create read end (client) socket
+         if Res = Failure then
+            goto Fail;
+         end if;
 
-      R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
+         --  Create read end (client) socket
 
-      if R_Sock = Failure then
-         goto Fail;
-      end if;
+         R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 
-      --  Connect listening socket
+         if R_Sock = Failure then
+            goto Fail;
+         end if;
 
-      Res := C_Connect (R_Sock, Sin'Address, Len);
+         --  Connect listening socket
 
-      if Res = Failure then
-         goto Fail;
-      end if;
+         Res := C_Connect (R_Sock, Sin'Address, Len);
+
+         exit when Res /= Failure;
+
+         if Socket_Errno /= Constants.EADDRINUSE then
+            goto Fail;
+         end if;
+
+         --  In rare cases, the above C_Bind chooses a port that is still
+         --  marked "in use", even though it has been closed (perhaps by some
+         --  other process that has already exited). This causes the above
+         --  C_Connect to fail with EADDRINUSE. In this case, we close the
+         --  ports, and loop back to try again. This mysterious windows
+         --  behavior is documented. See, for example:
+         --    http://msdn2.microsoft.com/en-us/library/ms737625.aspx
+         --  In an experiment with 2000 calls, 21 required exactly one retry, 7
+         --  required two, and none required three or more. Note that no delay
+         --  is needed between retries; retrying C_Bind will typically produce
+         --  a different port.
+
+         pragma Assert (Res = Failure
+                          and then
+                        Socket_Errno = Constants.EADDRINUSE);
+         pragma Warnings (Off); -- useless assignment to "Res"
+         Res := C_Close (W_Sock);
+         pragma Warnings (On);
+         W_Sock := Failure;
+         Res := C_Close (R_Sock);
+         R_Sock := Failure;
+      end loop;
 
       --  Since the call to connect(2) has suceeded and the backlog limit on
       --  the listening socket is 1, we know that there is now exactly one
       --  pending connection on L_Sock, which is the one from R_Sock.
 
       W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
+
       if W_Sock = Failure then
          goto Fail;
       end if;
@@ -143,27 +184,29 @@ package body Signalling_Fds is
 
       Res := C_Close (L_Sock);
 
-      Fds (Read_End)  := R_Sock;
-      Fds (Write_End) := W_Sock;
+      Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
 
       return Success;
 
    <<Fail>>
-      Err := Socket_Errno;
+      declare
+         Saved_Errno : constant Integer := Socket_Errno;
 
-      if W_Sock /= Failure then
-         Res := C_Close (W_Sock);
-      end if;
+      begin
+         if W_Sock /= Failure then
+            Res := C_Close (W_Sock);
+         end if;
 
-      if R_Sock /= Failure then
-         Res := C_Close (R_Sock);
-      end if;
+         if R_Sock /= Failure then
+            Res := C_Close (R_Sock);
+         end if;
 
-      if L_Sock /= Failure then
-         Res := C_Close (L_Sock);
-      end if;
+         if L_Sock /= Failure then
+            Res := C_Close (L_Sock);
+         end if;
 
-      Set_Socket_Errno (Err);
+         Set_Socket_Errno (Saved_Errno);
+      end;
 
       return Failure;
    end Create;