X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=libgfortran%2Fcaf%2Fmpi.c;h=4e3a7eb359ca9b309fab6e9b3108d00e9c69e900;hp=634e240bf19e314cbd0120326ce39c5335448d4a;hb=be1bfb343306deced0606ff973da15eb69580411;hpb=e60f31f13516fd8e5ade83ff86e057bfa8e1baf1 diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c index 634e240bf19..4e3a7eb359c 100644 --- a/libgfortran/caf/mpi.c +++ b/libgfortran/caf/mpi.c @@ -27,8 +27,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "libcaf.h" #include #include +#include /* For memcpy. */ #include + /* Define GFC_CAF_CHECK to enable run-time checking. */ /* #define GFC_CAF_CHECK 1 */ @@ -36,9 +38,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see static void error_stop (int error) __attribute__ ((noreturn)); /* Global variables. */ +static int caf_mpi_initialized; static int caf_this_image; static int caf_num_images; -static MPI_Win caf_world_window; +static int caf_is_finalized; + +caf_static_t *caf_static_list = NULL; /* Initialize coarray program. This routine assumes that no other @@ -50,72 +55,170 @@ static MPI_Win caf_world_window; void _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images) { - int flag; - - /* The following is only the case if one does not have a Fortran - main program. */ - MPI_Initialized (&flag); - if (!flag) - MPI_Init (argc, argv); - - MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image); - *this_image = caf_this_image + 1; - MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images); - *num_images = caf_num_images; - - /* Obtain window for CRITICAL section locking. */ - MPI_Win_create (NULL, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD, - &caf_world_window); + if (caf_num_images == 0) + { + /* caf_mpi_initialized is only true if the main program is + not written in Fortran. */ + MPI_Initialized (&caf_mpi_initialized); + if (!caf_mpi_initialized) + MPI_Init (argc, argv); + + MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images); + MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image); + caf_this_image++; + } + + if (this_image) + *this_image = caf_this_image; + if (num_images) + *num_images = caf_num_images; } -/* Finalize coarray program. Note: This is only called before the - program ends; thus the MPI_Initialized status of _gfortran_caf_init - does not play a role. */ +/* Finalize coarray program. */ void _gfortran_caf_finalize (void) { - MPI_Win_free (&caf_world_window); - MPI_Finalize (); + while (caf_static_list != NULL) + { + free(caf_static_list->token[caf_this_image-1]); + caf_static_list = caf_static_list->prev; + } + + if (!caf_mpi_initialized) + MPI_Finalize (); + + caf_is_finalized = 1; } -/* SYNC ALL - the return value matches Fortran's STAT argument. */ +void * +_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token, + int *stat, char *errmsg, int errmsg_len) +{ + void *local; + int err; + + if (unlikely (caf_is_finalized)) + goto error; + + /* Start MPI if not already started. */ + if (caf_num_images == 0) + _gfortran_caf_init (NULL, NULL, NULL, NULL); + + /* Token contains only a list of pointers. */ + local = malloc (size); + token = malloc (sizeof (void*) * caf_num_images); + + if (unlikely (local == NULL || token == NULL)) + goto error; + + /* token[img-1] is the address of the token in image "img". */ + err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token, + sizeof (void*), MPI_BYTE, MPI_COMM_WORLD); + if (unlikely (err)) + { + free (local); + free (token); + goto error; + } + + if (type == CAF_REGTYPE_COARRAY_STATIC) + { + caf_static_t *tmp = malloc (sizeof (caf_static_t)); + tmp->prev = caf_static_list; + tmp->token = token; + caf_static_list = tmp; + } + + if (stat) + *stat = 0; + + 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); + } +} + int -_gfortran_caf_sync_all (char *errmsg, int errmsg_len) +_gfortran_caf_deregister (void **token __attribute__ ((unused))) { - int ierr; - ierr = MPI_Barrier (MPI_COMM_WORLD); + return 0; +} - if (ierr && errmsg_len > 0) + +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); + + if (stat) + *stat = ierr; + + if (ierr) { const char msg[] = "SYNC ALL failed"; - int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len - : (int) sizeof (msg); - memcpy (errmsg, msg, len); - if (errmsg_len > len) - memset (&errmsg[len], ' ', errmsg_len-len); + if (errmsg_len > 0) + { + int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len + : (int) sizeof (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); + } } - - /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used? */ - return ierr; } /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*) - is not equivalent to SYNC ALL. The return value matches Fortran's - STAT argument. */ -int -_gfortran_caf_sync_images (int count, int images[], char *errmsg, + is not equivalent to SYNC ALL. */ +void +_gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, int errmsg_len) { int ierr; - if (count == 0 || (count == 1 && images[0] == caf_this_image)) - return 0; + { + if (stat) + *stat = 0; + return; + } #ifdef GFC_CAF_CHECK { @@ -140,36 +243,28 @@ _gfortran_caf_sync_images (int count, int images[], char *errmsg, } /* Handle SYNC IMAGES(*). */ + /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used? */ ierr = MPI_Barrier (MPI_COMM_WORLD); + if (stat) + *stat = ierr; - if (ierr && errmsg_len > 0) + if (ierr) { const char msg[] = "SYNC IMAGES failed"; - int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len - : (int) sizeof (msg); - memcpy (errmsg, msg, len); - if (errmsg_len > len) - memset (&errmsg[len], ' ', errmsg_len-len); + if (errmsg_len > 0) + { + int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len + : (int) sizeof (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); + } } - - /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used? */ - return ierr; -} - - -/* CRITICAL BLOCK. */ - -void -_gfortran_caf_critical (void) -{ - MPI_Win_lock (MPI_LOCK_SHARED, 0, 0, caf_world_window); -} - - -void -_gfortran_caf_end_critical (void) -{ - MPI_Win_unlock (0, caf_world_window); }