2011-07-07 Tobias Burnus <burnus@net-b.de>

[pf3gnuchains/gcc-fork.git] / libgfortran / caf / mpi.c

diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
index e64670e..4e3a7eb 100644 (file)
--- a/libgfortran/caf/mpi.c
+++ b/libgfortran/caf/mpi.c
@@ -41,6 +41,9 @@ static void error_stop (int error) __attribute__ ((noreturn));
 static int caf_mpi_initialized;
 static int caf_this_image;
 static int caf_num_images;
 static int caf_mpi_initialized;
 static int caf_this_image;
 static int caf_num_images;

+static int caf_is_finalized;
+
+caf_static_t *caf_static_list = NULL;

 
 
 /* Initialize coarray program.  This routine assumes that no other
 
 
 /* Initialize coarray program.  This routine assumes that no other


@@ -52,16 +55,23 @@ static int caf_num_images;
 void
 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
 {
 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);
+  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++;
+    }

 
 

-  MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
-  *this_image = ++caf_this_image;
-  MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
-  *num_images = caf_num_images;
+  if (this_image)
+    *this_image = caf_this_image;
+  if (num_images)
+    *num_images = caf_num_images;

 }
 
 
 }
 
 


@@ -70,18 +80,92 @@ _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
 void
 _gfortran_caf_finalize (void)
 {
 void
 _gfortran_caf_finalize (void)
 {

+  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 ();
   if (!caf_mpi_initialized)
     MPI_Finalize ();

+
+  caf_is_finalized = 1;

 }
 
 
 void *
 }
 
 
 void *

-_gfortran_caf_register (ptrdiff_t size,
-                        caf_register_t type __attribute__ ((unused)),
-                        void **token)
+_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
+                       int *stat, char *errmsg, int errmsg_len)

 {
 {

-  *token = NULL;
-  return malloc (size);
+  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);
+    }

 }
 
 
 }