Re: [Patch, Fortran] Add runtime_error function to libgfortran/caf/mpi.c

[Tobias Burnus <burnus at net-b dot de>]

Tobias Burnus wrote:
> This patch adds a run-time error function to mpi.c, which gives a 
> proper error message including the image number. Additionally, it 
> allows to clean up the error handling, avoiding the duplicated 
> declaration of strings.
>
> I have not touched the SYNC functions

Well, I did now. The attached patch combines my runtime_error function 
patch with Daniel's sync patch.

OK?


Tobias

2011-07-09  Tobias Burnus  <burnus@net-b.de>
	    Daniel Carrera  <dcarrera@gmail.com>

	* caf/mpi.c (runtime_error): New function.
	(_gfortran_caf_register): Use it.
	(_gfortran_caf_sync_all): Use it, add STAT_STOPPED_IMAGE
	as possible status value.
	(_gfortran_caf_sync_images): Ditto.

diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
index 4e3a7eb..ce42c31 100644
--- a/libgfortran/caf/mpi.c
+++ b/libgfortran/caf/mpi.c
@@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>	/* For memcpy.  */
+#include <stdarg.h>	/* For variadic arguments.  */
 #include <mpi.h>
 
 
@@ -46,6 +47,25 @@ static int caf_is_finalized;
 caf_static_t *caf_static_list = NULL;
 
 
+static void
+runtime_error (int error, const char *message, ...)
+{
+  va_list ap;
+  fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
+  va_start (ap, message);
+  fprintf (stderr, message, ap);
+  va_end (ap);
+  fprintf (stderr, "\n");
+
+  /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
+  /* FIXME: Do some more effort than just MPI_ABORT.  */
+  MPI_Abort (MPI_COMM_WORLD, error);
+
+  /* Should be unreachable, but to make sure also call exit.  */
+  exit (2);
+}
+
+
 /* Initialize coarray program.  This routine assumes that no other
    MPI initialization happened before; otherwise MPI_Initialized
    had to be used.  As the MPI library might modify the command-line
@@ -138,34 +158,31 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
   return local;
 
 error:
-  if (stat)
-    {
-      *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
-      if (errmsg_len > 0)
-	{
-	  char *msg;
-	  if (caf_is_finalized)
-	    msg = "Failed to allocate coarray - stopped images";
-	  else
-	    msg = "Failed to allocate coarray";
-	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
-						      : (int) strlen (msg);
-	  memcpy (errmsg, msg, len);
-	  if (errmsg_len > len)
-	    memset (&errmsg[len], ' ', errmsg_len-len);
-	}
-      return NULL;
-    }
-  else
-    {
-      if (caf_is_finalized)
-	fprintf (stderr, "ERROR: Image %d is stopped, failed to allocate "
-		 "coarray", caf_this_image);
-      else
-	fprintf (stderr, "ERROR: Failed to allocate coarray on image %d\n",
-		 caf_this_image);
-      error_stop (1);
-    }
+  {
+    char *msg;
+
+    if (caf_is_finalized)
+      msg = "Failed to allocate coarray - there are stopped images";
+    else
+      msg = "Failed to allocate coarray";
+
+    if (stat)
+      {
+	*stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
+	if (errmsg_len > 0)
+	  {
+	    int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+							: (int) strlen (msg);
+	    memcpy (errmsg, msg, len);
+	    if (errmsg_len > len)
+	      memset (&errmsg[len], ' ', errmsg_len-len);
+	  }
+      }
+    else
+      runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : 1, msg);
+  }
+
+  return NULL;
 }
 
 
@@ -179,28 +196,34 @@ _gfortran_caf_deregister (void **token __attribute__ ((unused)))
 void
 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
 {
-  /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
-  int ierr = MPI_Barrier (MPI_COMM_WORLD);
+  int ierr;
 
+  if (unlikely (caf_is_finalized))
+    ierr = STAT_STOPPED_IMAGE;
+  else
+    ierr = MPI_Barrier (MPI_COMM_WORLD);
+ 
   if (stat)
     *stat = ierr;
 
   if (ierr)
     {
-      const char msg[] = "SYNC ALL failed";
+      char *msg;
+      if (caf_is_finalized)
+	msg = "SYNC ALL failed - there are stopped images";
+      else
+	msg = "SYNC ALL failed";
+
       if (errmsg_len > 0)
 	{
-	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
-						      : (int) sizeof (msg);
+	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+						      : (int) strlen (msg);
 	  memcpy (errmsg, msg, len);
 	  if (errmsg_len > len)
 	    memset (&errmsg[len], ' ', errmsg_len-len);
 	}
       else
-	{
-	  fprintf (stderr, "SYNC ALL failed\n");
-	  error_stop (ierr);
-	}
+	runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
     }
 }
 
@@ -243,27 +266,32 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
     }
 
   /* Handle SYNC IMAGES(*).  */
-  /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
-  ierr = MPI_Barrier (MPI_COMM_WORLD);
+  if (unlikely(caf_is_finalized))
+    ierr = STAT_STOPPED_IMAGE;
+  else
+    ierr = MPI_Barrier (MPI_COMM_WORLD);
+
   if (stat)
     *stat = ierr;
 
   if (ierr)
     {
-      const char msg[] = "SYNC IMAGES failed";
+      char *msg;
+      if (caf_is_finalized)
+	msg = "SYNC IMAGES failed - there are stopped images";
+      else
+	msg = "SYNC IMAGES failed";
+
       if (errmsg_len > 0)
 	{
-	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
-						      : (int) sizeof (msg);
+	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+						      : (int) strlen (msg);
 	  memcpy (errmsg, msg, len);
 	  if (errmsg_len > len)
 	    memset (&errmsg[len], ' ', errmsg_len-len);
 	}
       else
-	{
-	  fprintf (stderr, "SYNC IMAGES failed\n");
-	  error_stop (ierr);
-	}
+	runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
     }
 }