#include "libcaf.h"
#include <stdio.h>
#include <stdlib.h>
+#include <string.h> /* For memcpy. */
#include <mpi.h>
+
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
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
void
_gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
{
- /* 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_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;
+ 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++;
+ }
- /* Obtain window for CRITICAL section locking. */
- MPI_Win_create (NULL, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
- &caf_world_window);
+ if (this_image)
+ *this_image = caf_this_image;
+ if (num_images)
+ *num_images = caf_num_images;
}
void
_gfortran_caf_finalize (void)
{
- MPI_Win_free (&caf_world_window);
+ 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
{
}
/* 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);
}
OSDN Git Service
