libgfortran/caf/mpi.c

   1 /* MPI implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2023 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, size_t errmsg_len,
 135                         int num_alloc_comps __attribute__ ((unused)))
 136 {
 137   void *local;
 138   int err;
 139
 140   if (unlikely (caf_is_finalized))
 141     goto error;
 142
 143   /* Start MPI if not already started.  */
 144   if (caf_num_images == 0)
 145     _gfortran_caf_init (NULL, NULL);
 146
 147   /* Token contains only a list of pointers.  */
 148   local = malloc (size);
 149   *token = malloc (sizeof (mpi_token_t) * caf_num_images);
 150
 151   if (unlikely (local == NULL || *token == NULL))
 152     goto error;
 153
 154   /* token[img-1] is the address of the token in image "img".  */
 155   err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, TOKEN (*token),
 156                        sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
 157
 158   if (unlikely (err))
 159     {
 160       free (local);
 161       free (*token);
 162       goto error;
 163     }
 164
 165   if (type == CAF_REGTYPE_COARRAY_STATIC)
 166     {
 167       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 168       tmp->prev  = caf_static_list;
 169       tmp->token = *token;
 170       caf_static_list = tmp;
 171     }
 172
 173   if (stat)
 174     *stat = 0;
 175
 176   return local;
 177
 178 error:
 179   {
 180     char *msg;
 181
 182     if (caf_is_finalized)
 183       msg = "Failed to allocate coarray - there are stopped images";
 184     else
 185       msg = "Failed to allocate coarray";
 186
 187     if (stat)
 188       {
 189         *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
 190         if (errmsg_len > 0)
 191           {
 192             size_t len = (strlen (msg) > errmsg_len) ? errmsg_len
 193               : strlen (msg);
 194             memcpy (errmsg, msg, len);
 195             if (errmsg_len > len)
 196               memset (&errmsg[len], ' ', errmsg_len-len);
 197           }
 198       }
 199     else
 200       caf_runtime_error (msg);
 201   }
 202
 203   return NULL;
 204 }
 205
 206
 207 void
 208 _gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, size_t errmsg_len)
 209 {
 210   if (unlikely (caf_is_finalized))
 211     {
 212       const char msg[] = "Failed to deallocate coarray - "
 213                           "there are stopped images";
 214       if (stat)
 215         {
 216           *stat = STAT_STOPPED_IMAGE;
 217
 218           if (errmsg_len > 0)
 219             {
 220               size_t len = (sizeof (msg) - 1 > errmsg_len)
 221                 ? errmsg_len : sizeof (msg) - 1;
 222               memcpy (errmsg, msg, len);
 223               if (errmsg_len > len)
 224                 memset (&errmsg[len], ' ', errmsg_len-len);
 225             }
 226           return;
 227         }
 228       caf_runtime_error (msg);
 229     }
 230
 231   _gfortran_caf_sync_all (NULL, NULL, 0);
 232
 233   if (stat)
 234     *stat = 0;
 235
 236   free (TOKEN (*token)[caf_this_image-1]);
 237   free (*token);
 238 }
 239
 240
 241 void
 242 _gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len)
 243 {
 244   int ierr;
 245
 246   if (unlikely (caf_is_finalized))
 247     ierr = STAT_STOPPED_IMAGE;
 248   else
 249     ierr = MPI_Barrier (MPI_COMM_WORLD);
 250
 251   if (stat)
 252     *stat = ierr;
 253
 254   if (ierr)
 255     {
 256       char *msg;
 257       if (caf_is_finalized)
 258         msg = "SYNC ALL failed - there are stopped images";
 259       else
 260         msg = "SYNC ALL failed";
 261
 262       if (errmsg_len > 0)
 263         {
 264           size_t len = (strlen (msg) > errmsg_len) ? errmsg_len
 265             : strlen (msg);
 266           memcpy (errmsg, msg, len);
 267           if (errmsg_len > len)
 268             memset (&errmsg[len], ' ', errmsg_len-len);
 269         }
 270       else
 271         caf_runtime_error (msg);
 272     }
 273 }
 274
 275
 276 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 277    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 278    is not equivalent to SYNC ALL. */
 279 void
 280 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
 281                            size_t errmsg_len)
 282 {
 283   int ierr;
 284   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 285     {
 286       if (stat)
 287         *stat = 0;
 288       return;
 289     }
 290
 291 #ifdef GFC_CAF_CHECK
 292   {
 293     int i;
 294
 295     for (i = 0; i < count; i++)
 296       if (images[i] < 1 || images[i] > caf_num_images)
 297         {
 298           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 299                    "IMAGES", images[i]);
 300           error_stop (1);
 301         }
 302   }
 303 #endif
 304
 305   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 306      mapped to MPI communicators. Thus, exist early with an error message.  */
 307   if (count > 0)
 308     {
 309       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 310       error_stop (1);
 311     }
 312
 313   /* Handle SYNC IMAGES(*).  */
 314   if (unlikely (caf_is_finalized))
 315     ierr = STAT_STOPPED_IMAGE;
 316   else
 317     ierr = MPI_Barrier (MPI_COMM_WORLD);
 318
 319   if (stat)
 320     *stat = ierr;
 321
 322   if (ierr)
 323     {
 324       char *msg;
 325       if (caf_is_finalized)
 326         msg = "SYNC IMAGES failed - there are stopped images";
 327       else
 328         msg = "SYNC IMAGES failed";
 329
 330       if (errmsg_len > 0)
 331         {
 332           size_t len = (strlen (msg) > errmsg_len) ? errmsg_len
 333             : strlen (msg);
 334           memcpy (errmsg, msg, len);
 335           if (errmsg_len > len)
 336             memset (&errmsg[len], ' ', errmsg_len-len);
 337         }
 338       else
 339         caf_runtime_error (msg);
 340     }
 341 }
 342
 343
 344 /* ERROR STOP the other images.  */
 345
 346 static void
 347 error_stop (int error)
 348 {
 349   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 350   /* FIXME: Do some more effort than just MPI_ABORT.  */
 351   MPI_Abort (MPI_COMM_WORLD, error);
 352
 353   /* Should be unreachable, but to make sure also call exit.  */
 354   exit (error);
 355 }
 356
 357
 358 /* ERROR STOP function for string arguments.  */
 359
 360 void
 361 _gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
 362 {
 363   if (!quiet)
 364     {
 365       fputs ("ERROR STOP ", stderr);
 366       while (len--)
 367         fputc (*(string++), stderr);
 368       fputs ("\n", stderr);
 369     }
 370   error_stop (1);
 371 }
 372
 373
 374 /* ERROR STOP function for numerical arguments.  */
 375
 376 void
 377 _gfortran_caf_error_stop (int error, bool quiet)
 378 {
 379   if (!quiet)
 380     fprintf (stderr, "ERROR STOP %d\n", error);
 381   error_stop (error);
 382 }