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 <bur...@net-b.de>
Daniel Carrera <dcarr...@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);
}
}
