libgfortran/caf/mpi.c

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