libgfortran/caf/mpi.c

   1 /* MPI implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2016 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 typedef void ** mpi_token_t;
  38 #define TOKEN(X) ((mpi_token_t) (X))
  39
  40 static void error_stop (int error) __attribute__ ((noreturn));
  41
  42 /* Global variables.  */
  43 static int caf_mpi_initialized;
  44 static int caf_this_image;
  45 static int caf_num_images;
  46 static int caf_is_finalized;
  47
  48 caf_static_t *caf_static_list = NULL;
  49
  50
  51 /* Keep in sync with single.c.  */
  52 static void
  53 caf_runtime_error (const char *message, ...)
  54 {
  55   va_list ap;
  56   fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
  57   va_start (ap, message);
  58   vfprintf (stderr, message, ap);
  59   va_end (ap);
  60   fprintf (stderr, "\n");
  61
  62   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
  63   /* FIXME: Do some more effort than just MPI_ABORT.  */
  64   MPI_Abort (MPI_COMM_WORLD, EXIT_FAILURE);
  65
  66   /* Should be unreachable, but to make sure also call exit.  */
  67   exit (EXIT_FAILURE);
  68 }
  69
  70
  71 /* Initialize coarray program.  This routine assumes that no other
  72    MPI initialization happened before; otherwise MPI_Initialized
  73    had to be used.  As the MPI library might modify the command-line
  74    arguments, the routine should be called before the run-time
  75    libaray is initialized.  */
  76
  77 void
  78 _gfortran_caf_init (int *argc, char ***argv)
  79 {
  80   if (caf_num_images == 0)
  81     {
  82       /* caf_mpi_initialized is only true if the main program is
  83        not written in Fortran.  */
  84       MPI_Initialized (&caf_mpi_initialized);
  85       if (!caf_mpi_initialized)
  86         MPI_Init (argc, argv);
  87
  88       MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
  89       MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
  90       caf_this_image++;
  91     }
  92 }
  93
  94
  95 /* Finalize coarray program.   */
  96
  97 void
  98 _gfortran_caf_finalize (void)
  99 {
 100   while (caf_static_list != NULL)
 101     {
 102       caf_static_t *tmp = caf_static_list->prev;
 103
 104       free (TOKEN (caf_static_list->token)[caf_this_image-1]);
 105       free (TOKEN (caf_static_list->token));
 106       free (caf_static_list);
 107       caf_static_list = tmp;
 108     }
 109
 110   if (!caf_mpi_initialized)
 111     MPI_Finalize ();
 112
 113   caf_is_finalized = 1;
 114 }
 115
 116
 117 int
 118 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
 119 {
 120   return caf_this_image;
 121 }
 122
 123
 124 int
 125 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
 126                           int failed __attribute__ ((unused)))
 127 {
 128   return caf_num_images;
 129 }
 130
 131
 132 void *
 133 _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 134                         int *stat, char *errmsg, int errmsg_len)
 135 {
 136   void *local;
 137   int err;
 138
 139   if (unlikely (caf_is_finalized))
 140     goto error;
 141
 142   /* Start MPI if not already started.  */
 143   if (caf_num_images == 0)
 144     _gfortran_caf_init (NULL, NULL);
 145
 146   /* Token contains only a list of pointers.  */
 147   local = malloc (size);
 148   *token = malloc (sizeof (mpi_token_t) * caf_num_images);
 149
 150   if (unlikely (local == NULL || *token == NULL))
 151     goto error;
 152
 153   /* token[img-1] is the address of the token in image "img".  */
 154   err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, TOKEN (*token),
 155                        sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
 156
 157   if (unlikely (err))
 158     {
 159       free (local);
 160       free (*token);
 161       goto error;
 162     }
 163
 164   if (type == CAF_REGTYPE_COARRAY_STATIC)
 165     {
 166       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 167       tmp->prev  = caf_static_list;
 168       tmp->token = *token;
 169       caf_static_list = tmp;
 170     }
 171
 172   if (stat)
 173     *stat = 0;
 174
 175   return local;
 176
 177 error:
 178   {
 179     char *msg;
 180
 181     if (caf_is_finalized)
 182       msg = "Failed to allocate coarray - there are stopped images";
 183     else
 184       msg = "Failed to allocate coarray";
 185
 186     if (stat)
 187       {
 188         *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
 189         if (errmsg_len > 0)
 190           {
 191             int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 192                                                         : (int) strlen (msg);
 193             memcpy (errmsg, msg, len);
 194             if (errmsg_len > len)
 195               memset (&errmsg[len], ' ', errmsg_len-len);
 196           }
 197       }
 198     else
 199       caf_runtime_error (msg);
 200   }
 201
 202   return NULL;
 203 }
 204
 205
 206 void
 207 _gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, int errmsg_len)
 208 {
 209   if (unlikely (caf_is_finalized))
 210     {
 211       const char msg[] = "Failed to deallocate coarray - "
 212                           "there are stopped images";
 213       if (stat)
 214         {
 215           *stat = STAT_STOPPED_IMAGE;
 216
 217           if (errmsg_len > 0)
 218             {
 219               int len = ((int) sizeof (msg) - 1 > errmsg_len)
 220                         ? errmsg_len : (int) sizeof (msg) - 1;
 221               memcpy (errmsg, msg, len);
 222               if (errmsg_len > len)
 223                 memset (&errmsg[len], ' ', errmsg_len-len);
 224             }
 225           return;
 226         }
 227       caf_runtime_error (msg);
 228     }
 229
 230   _gfortran_caf_sync_all (NULL, NULL, 0);
 231
 232   if (stat)
 233     *stat = 0;
 234
 235   free (TOKEN (*token)[caf_this_image-1]);
 236   free (*token);
 237 }
 238
 239
 240 void
 241 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
 242 {
 243   int ierr;
 244
 245   if (unlikely (caf_is_finalized))
 246     ierr = STAT_STOPPED_IMAGE;
 247   else
 248     ierr = MPI_Barrier (MPI_COMM_WORLD);
 249
 250   if (stat)
 251     *stat = ierr;
 252
 253   if (ierr)
 254     {
 255       char *msg;
 256       if (caf_is_finalized)
 257         msg = "SYNC ALL failed - there are stopped images";
 258       else
 259         msg = "SYNC ALL failed";
 260
 261       if (errmsg_len > 0)
 262         {
 263           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 264                                                       : (int) strlen (msg);
 265           memcpy (errmsg, msg, len);
 266           if (errmsg_len > len)
 267             memset (&errmsg[len], ' ', errmsg_len-len);
 268         }
 269       else
 270         caf_runtime_error (msg);
 271     }
 272 }
 273
 274
 275 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 276    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 277    is not equivalent to SYNC ALL. */
 278 void
 279 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
 280                            int errmsg_len)
 281 {
 282   int ierr;
 283   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 284     {
 285       if (stat)
 286         *stat = 0;
 287       return;
 288     }
 289
 290 #ifdef GFC_CAF_CHECK
 291   {
 292     int i;
 293
 294     for (i = 0; i < count; i++)
 295       if (images[i] < 1 || images[i] > caf_num_images)
 296         {
 297           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 298                    "IMAGES", images[i]);
 299           error_stop (1);
 300         }
 301   }
 302 #endif
 303
 304   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 305      mapped to MPI communicators. Thus, exist early with an error message.  */
 306   if (count > 0)
 307     {
 308       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 309       error_stop (1);
 310     }
 311
 312   /* Handle SYNC IMAGES(*).  */
 313   if (unlikely (caf_is_finalized))
 314     ierr = STAT_STOPPED_IMAGE;
 315   else
 316     ierr = MPI_Barrier (MPI_COMM_WORLD);
 317
 318   if (stat)
 319     *stat = ierr;
 320
 321   if (ierr)
 322     {
 323       char *msg;
 324       if (caf_is_finalized)
 325         msg = "SYNC IMAGES failed - there are stopped images";
 326       else
 327         msg = "SYNC IMAGES failed";
 328
 329       if (errmsg_len > 0)
 330         {
 331           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 332                                                       : (int) strlen (msg);
 333           memcpy (errmsg, msg, len);
 334           if (errmsg_len > len)
 335             memset (&errmsg[len], ' ', errmsg_len-len);
 336         }
 337       else
 338         caf_runtime_error (msg);
 339     }
 340 }
 341
 342
 343 /* ERROR STOP the other images.  */
 344
 345 static void
 346 error_stop (int error)
 347 {
 348   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 349   /* FIXME: Do some more effort than just MPI_ABORT.  */
 350   MPI_Abort (MPI_COMM_WORLD, error);
 351
 352   /* Should be unreachable, but to make sure also call exit.  */
 353   exit (error);
 354 }
 355
 356
 357 /* ERROR STOP function for string arguments.  */
 358
 359 void
 360 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 361 {
 362   fputs ("ERROR STOP ", stderr);
 363   while (len--)
 364     fputc (*(string++), stderr);
 365   fputs ("\n", stderr);
 366
 367   error_stop (1);
 368 }
 369
 370
 371 /* ERROR STOP function for numerical arguments.  */
 372
 373 void
 374 _gfortran_caf_error_stop (int32_t error)
 375 {
 376   fprintf (stderr, "ERROR STOP %d\n", error);
 377   error_stop (error);
 378 }