libgfortran/caf/mpi.c

   1 /* MPI implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011
   3    Free Software Foundation, Inc.
   4    Contributed by Tobias Burnus <burnus@net-b.de>
   5
   6 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
   7
   8 Libcaf is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 Libcaf is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libcaf.h"
  28 #include <stdio.h>
  29 #include <stdlib.h>
  30 #include <string.h>     /* For memcpy.  */
  31 #include <mpi.h>
  32
  33
  34 /* Define GFC_CAF_CHECK to enable run-time checking.  */
  35 /* #define GFC_CAF_CHECK  1  */
  36
  37
  38 static void error_stop (int error) __attribute__ ((noreturn));
  39
  40 /* Global variables.  */
  41 static int caf_mpi_initialized;
  42 static int caf_this_image;
  43 static int caf_num_images;
  44 static int caf_is_finalized;
  45
  46 caf_static_t *caf_static_list = NULL;
  47
  48
  49 /* Initialize coarray program.  This routine assumes that no other
  50    MPI initialization happened before; otherwise MPI_Initialized
  51    had to be used.  As the MPI library might modify the command-line
  52    arguments, the routine should be called before the run-time
  53    libaray is initialized.  */
  54
  55 void
  56 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
  57 {
  58   if (caf_num_images == 0)
  59     {
  60       /* caf_mpi_initialized is only true if the main program is
  61        not written in Fortran.  */
  62       MPI_Initialized (&caf_mpi_initialized);
  63       if (!caf_mpi_initialized)
  64         MPI_Init (argc, argv);
  65
  66       MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
  67       MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
  68       caf_this_image++;
  69     }
  70
  71   if (this_image)
  72     *this_image = caf_this_image;
  73   if (num_images)
  74     *num_images = caf_num_images;
  75 }
  76
  77
  78 /* Finalize coarray program.   */
  79
  80 void
  81 _gfortran_caf_finalize (void)
  82 {
  83   while (caf_static_list != NULL)
  84     {
  85       free(caf_static_list->token[caf_this_image-1]);
  86       caf_static_list = caf_static_list->prev;
  87     }
  88
  89   if (!caf_mpi_initialized)
  90     MPI_Finalize ();
  91
  92   caf_is_finalized = 1;
  93 }
  94
  95
  96 void *
  97 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
  98                         int *stat, char *errmsg, int errmsg_len)
  99 {
 100   void *local;
 101   int err;
 102
 103   if (unlikely (caf_is_finalized))
 104     goto error;
 105
 106   /* Start MPI if not already started.  */
 107   if (caf_num_images == 0)
 108     _gfortran_caf_init (NULL, NULL, NULL, NULL);
 109
 110   /* Token contains only a list of pointers.  */
 111   local = malloc (size);
 112   token = malloc (sizeof (void*) * caf_num_images);
 113
 114   if (unlikely (local == NULL || token == NULL))
 115     goto error;
 116
 117   /* token[img-1] is the address of the token in image "img".  */
 118   err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token,
 119                        sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
 120   if (unlikely (err))
 121     {
 122       free (local);
 123       free (token);
 124       goto error;
 125     }
 126
 127   if (type == CAF_REGTYPE_COARRAY_STATIC)
 128     {
 129       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 130       tmp->prev  = caf_static_list;
 131       tmp->token = token;
 132       caf_static_list = tmp;
 133     }
 134
 135   if (stat)
 136     *stat = 0;
 137
 138   return local;
 139
 140 error:
 141   if (stat)
 142     {
 143       *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
 144       if (errmsg_len > 0)
 145         {
 146           char *msg;
 147           if (caf_is_finalized)
 148             msg = "Failed to allocate coarray - stopped images";
 149           else
 150             msg = "Failed to allocate coarray";
 151           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 152                                                       : (int) strlen (msg);
 153           memcpy (errmsg, msg, len);
 154           if (errmsg_len > len)
 155             memset (&errmsg[len], ' ', errmsg_len-len);
 156         }
 157       return NULL;
 158     }
 159   else
 160     {
 161       if (caf_is_finalized)
 162         fprintf (stderr, "ERROR: Image %d is stopped, failed to allocate "
 163                  "coarray", caf_this_image);
 164       else
 165         fprintf (stderr, "ERROR: Failed to allocate coarray on image %d\n",
 166                  caf_this_image);
 167       error_stop (1);
 168     }
 169 }
 170
 171
 172 int
 173 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
 174 {
 175   return 0;
 176 }
 177
 178
 179 void
 180 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
 181 {
 182   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
 183   int ierr = MPI_Barrier (MPI_COMM_WORLD);
 184
 185   if (stat)
 186     *stat = ierr;
 187
 188   if (ierr)
 189     {
 190       const char msg[] = "SYNC ALL failed";
 191       if (errmsg_len > 0)
 192         {
 193           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 194                                                       : (int) sizeof (msg);
 195           memcpy (errmsg, msg, len);
 196           if (errmsg_len > len)
 197             memset (&errmsg[len], ' ', errmsg_len-len);
 198         }
 199       else
 200         {
 201           fprintf (stderr, "SYNC ALL failed\n");
 202           error_stop (ierr);
 203         }
 204     }
 205 }
 206
 207
 208 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 209    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 210    is not equivalent to SYNC ALL. */
 211 void
 212 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
 213                            int errmsg_len)
 214 {
 215   int ierr;
 216   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 217     {
 218       if (stat)
 219         *stat = 0;
 220       return;
 221     }
 222
 223 #ifdef GFC_CAF_CHECK
 224   {
 225     int i;
 226
 227     for (i = 0; i < count; i++)
 228       if (images[i] < 1 || images[i] > caf_num_images)
 229         {
 230           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 231                    "IMAGES", images[i]);
 232           error_stop (1);
 233         }
 234   }
 235 #endif
 236
 237   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 238      mapped to MPI communicators. Thus, exist early with an error message.  */
 239   if (count > 0)
 240     {
 241       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 242       error_stop (1);
 243     }
 244
 245   /* Handle SYNC IMAGES(*).  */
 246   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
 247   ierr = MPI_Barrier (MPI_COMM_WORLD);
 248   if (stat)
 249     *stat = ierr;
 250
 251   if (ierr)
 252     {
 253       const char msg[] = "SYNC IMAGES failed";
 254       if (errmsg_len > 0)
 255         {
 256           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 257                                                       : (int) sizeof (msg);
 258           memcpy (errmsg, msg, len);
 259           if (errmsg_len > len)
 260             memset (&errmsg[len], ' ', errmsg_len-len);
 261         }
 262       else
 263         {
 264           fprintf (stderr, "SYNC IMAGES failed\n");
 265           error_stop (ierr);
 266         }
 267     }
 268 }
 269
 270
 271 /* ERROR STOP the other images.  */
 272
 273 static void
 274 error_stop (int error)
 275 {
 276   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 277   /* FIXME: Do some more effort than just MPI_ABORT.  */
 278   MPI_Abort (MPI_COMM_WORLD, error);
 279
 280   /* Should be unreachable, but to make sure also call exit.  */
 281   exit (error);
 282 }
 283
 284
 285 /* ERROR STOP function for string arguments.  */
 286
 287 void
 288 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 289 {
 290   fputs ("ERROR STOP ", stderr);
 291   while (len--)
 292     fputc (*(string++), stderr);
 293   fputs ("\n", stderr);
 294
 295   error_stop (1);
 296 }
 297
 298
 299 /* ERROR STOP function for numerical arguments.  */
 300
 301 void
 302 _gfortran_caf_error_stop (int32_t error)
 303 {
 304   fprintf (stderr, "ERROR STOP %d\n", error);
 305   error_stop (error);
 306 }