procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

mpi.c (runtime_error): New function.

Browse source 
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
This commit is contained in:
Tobias Burnus 2011-07-09 16:29:50 +02:00 • committed by Tobias Burnus
parent 677aad9c92
commit 41de45c6a0
2 changed files with 83 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
libgfortran/ChangeLog
View file

@ -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.

120
libgfortran/caf/mpi.c
View file

@ -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);
}
}