libgfortran/caf/mpi.c

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