mpi.c (runtime_error): New function.

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.

Co-Authored-By: Daniel Carrera <dcarrera@gmail.com>
From-SVN: r176080

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index b7114e9dbae32c24f1e090f120a5ee6b55c5bac7..d278f93b8002a7bf94a191284936341b64a883cb 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,12 @@
+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.
+
 2011-07-07  Tobias Burnus  <burnus@net-b.de>
 
        * libcaf.h (__attribute__, unlikely, likely): New macros.

diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
index 4e3a7eb359ca9b309fab6e9b3108d00e9c69e900..a8306ddb8a74b808b175bbcfe3e56f8fcc6b1f3f 100644 (file)
--- 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
+caf_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
+      caf_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);
-       }
+       caf_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);
-       }
+       caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
     }
 }