OSDN Git Service

2011-07-07 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / libgfortran / caf / mpi.c
index 634e240..4e3a7eb 100644 (file)
@@ -27,8 +27,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #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  */
 
@@ -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);
 }