From 41de45c6a0d599a3913afffb9c3288663094a55a Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 9 Jul 2011 16:29:50 +0200 Subject: [PATCH] mpi.c (runtime_error): New function. 2011-07-09 Tobias Burnus Daniel Carrera * 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 From-SVN: r176080 --- libgfortran/ChangeLog | 9 ++++ libgfortran/caf/mpi.c | 120 ++++++++++++++++++++++++++---------------- 2 files changed, 83 insertions(+), 46 deletions(-) diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index b7114e9dbae..d278f93b800 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2011-07-09 Tobias Burnus + Daniel Carrera + + * 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 * libcaf.h (__attribute__, unlikely, likely): New macros. diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c index 4e3a7eb359c..a8306ddb8a7 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 #include #include /* For memcpy. */ +#include /* For variadic arguments. */ #include @@ -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); } } -- 2.30.2