Fix sync image race condition.

Sync images works by setting up asynchronous receivers for each image in the sync set.
Next all images check the image status of all other images participating in the sync.
Then each image sends a zero int or the stopped image special code to all other images
in the sync set. At last all images wait for the asynchronous receivers to get their data.

The race here was, that an image could be in the waiting phase while the stopped image
had not set its status correctly yet. The waiting image did not return then, because it
never got the stopped image code from the stopped image. To solve this two changes had
to be made:

1. caf_finalize() now calls sync_image_internal ()
2. After waiting sync_image_internal() checks the status of the image, that send its data,
   again.

sync_image() has be renamed to sync_image_internal(). A flag was added to distinguish
calls to sync_image_internal() from caf_finalize and regular sync image calls. The latter
shall report an error on failure, while the former keeps silent.

This commit fixes the timeout of syncimage_status.f90 mentioned in #298.

Author: vehre

src/mpi/mpi_caf.c

@@ -421,6 +421,11 @@ PREFIX (init) (int *argc, char ***argv)
   /* MPI_Barrier(CAF_COMM_WORLD); */
 }
 
+/* Forward declaration of sync_images.  */
+
+void
+sync_images_internal (int count, int images[], int *stat, char *errmsg,
+                      int errmsg_len, bool internal);
 
 /* Finalize coarray program.   */
 
@@ -431,10 +436,11 @@ _gfortran_caf_finalize (void)
 PREFIX (finalize) (void)
 #endif
 {
+  int empty[0];
   *img_status = STAT_STOPPED_IMAGE; /* GFC_STAT_STOPPED_IMAGE = 6000 */
   MPI_Win_sync(*stat_tok);
 
-  MPI_Barrier(CAF_COMM_WORLD);
+  sync_images_internal (-1, empty, NULL, NULL, 0, true);
 
   while (caf_static_list != NULL)
     {
@@ -2987,6 +2993,13 @@ PREFIX(is_present) (caf_token_t token, int image_index, caf_reference_t *refs)
 void
 PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
                      int errmsg_len)
+{
+  sync_images_internal (count, images, stat, errmsg, errmsg_len, false);
+}
+
+void
+sync_images_internal (int count, int images[], int *stat, char *errmsg,
+                      int errmsg_len, bool internal)
 {
   int ierr = 0, i = 0, remote_stat = 0, j = 0;
   MPI_Status s;
@@ -3049,16 +3062,10 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
 	    CAF_COMM_WORLD, &handlers[i]);
       for(i = 0; i < count; ++i)
 	{
-# ifdef CAF_MPI_LOCK_UNLOCK
-	  MPI_Win_lock (MPI_LOCK_SHARED, images[i] - 1, 0, *stat_tok);
-# endif // CAF_MPI_LOCK_UNLOCK
+	  CAF_Win_lock (MPI_LOCK_SHARED, images[i] - 1, *stat_tok);
 	  ierr = MPI_Get (&remote_stat, 1, MPI_INT,
 			  images[i] - 1, 0, 1, MPI_INT, *stat_tok);
-# ifdef CAF_MPI_LOCK_UNLOCK
-	  MPI_Win_unlock (images[i] - 1, *stat_tok);
-# else // CAF_MPI_LOCK_UNLOCK
-	  MPI_Win_flush (images[i] - 1, *stat_tok);
-# endif // CAF_MPI_LOCK_UNLOCK
+	  CAF_Win_unlock (images[i] - 1, *stat_tok);
 	  if(remote_stat != 0)
 	    {
 	      ierr = STAT_STOPPED_IMAGE;
@@ -3071,12 +3078,15 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
 	}
       if (ierr == 0)
 	{
+	  int zero = 0;
 	  int done_count = 0;
 	  for(i = 0; i < count; ++i)
 	    {
 	      if (arrived[images[i] - 1] != STAT_STOPPED_IMAGE)
-		/* Only send, when no stopped images have been found.  */
-		ierr = MPI_Send (&caf_this_image, 1, MPI_INT, images[i] - 1, 0,
+		/* Only send, when no stopped images have been found.
+		   Do not send our id, because on very large clusters one id
+		   and he STAT_STOPPED_IMAGE code may be the same.  */
+		ierr = MPI_Send (&zero, 1, MPI_INT, images[i] - 1, 0,
 				 CAF_COMM_WORLD);
 	      else
 		ierr = STAT_STOPPED_IMAGE;
@@ -3089,6 +3099,17 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
 		++done_count;
 	      if (i != MPI_UNDEFINED && arrived[i] == STAT_STOPPED_IMAGE)
 		ierr = STAT_STOPPED_IMAGE;
+	      else if (i != MPI_UNDEFINED)
+		{
+		  /* Check that after a late stopped image has set its status
+		     that status is not stopped.  */
+		  CAF_Win_lock (MPI_LOCK_SHARED, images[i] - 1, *stat_tok);
+		  ierr = MPI_Get (&remote_stat, 1, MPI_INT,
+				  images[i] - 1, 0, 1, MPI_INT, *stat_tok);
+		  CAF_Win_unlock (images[i] - 1, *stat_tok);
+		  if (remote_stat != 0)
+		    ierr = STAT_STOPPED_IMAGE;
+		}
 	      else if (ierr != MPI_SUCCESS)
 		break;
 	    }
@@ -3117,7 +3138,7 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
           if (errmsg_len > len)
             memset (&errmsg[len], ' ', errmsg_len-len);
         }
-      else
+      else if (!internal)
         caf_runtime_error (msg);
     }
 }

src/tests/unit/sync/syncimages_status.f90

@@ -10,7 +10,6 @@ program sync_images_stat
   me = this_image()
 
   if (me /= 1 ) then
-     call sleep(1)
      sync images(*,STAT=stat_var)
      if ( stat_var /= STAT_STOPPED_IMAGE) then
         print *, "Error:stat_var /= STAT_STOPPED_IMAGE: ", me