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 <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 static void
  51 caf_runtime_error (int 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   fprintf (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, error);
  63
  64   /* Should be unreachable, but to make sure also call exit.  */
  65   exit (2);
  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       free(caf_static_list->token[caf_this_image-1]);
 106       caf_static_list = caf_static_list->prev;
 107     }
 108
 109   if (!caf_mpi_initialized)
 110     MPI_Finalize ();
 111
 112   caf_is_finalized = 1;
 113 }
 114
 115
 116 void *
 117 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
 118                         int *stat, char *errmsg, int errmsg_len)
 119 {
 120   void *local;
 121   int err;
 122
 123   if (unlikely (caf_is_finalized))
 124     goto error;
 125
 126   /* Start MPI if not already started.  */
 127   if (caf_num_images == 0)
 128     _gfortran_caf_init (NULL, NULL, NULL, NULL);
 129
 130   /* Token contains only a list of pointers.  */
 131   local = malloc (size);
 132   token = malloc (sizeof (void*) * caf_num_images);
 133
 134   if (unlikely (local == NULL || token == NULL))
 135     goto error;
 136
 137   /* token[img-1] is the address of the token in image "img".  */
 138   err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token,
 139                        sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
 140   if (unlikely (err))
 141     {
 142       free (local);
 143       free (token);
 144       goto error;
 145     }
 146
 147   if (type == CAF_REGTYPE_COARRAY_STATIC)
 148     {
 149       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 150       tmp->prev  = caf_static_list;
 151       tmp->token = token;
 152       caf_static_list = tmp;
 153     }
 154
 155   if (stat)
 156     *stat = 0;
 157
 158   return local;
 159
 160 error:
 161   {
 162     char *msg;
 163
 164     if (caf_is_finalized)
 165       msg = "Failed to allocate coarray - there are stopped images";
 166     else
 167       msg = "Failed to allocate coarray";
 168
 169     if (stat)
 170       {
 171         *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
 172         if (errmsg_len > 0)
 173           {
 174             int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 175                                                         : (int) strlen (msg);
 176             memcpy (errmsg, msg, len);
 177             if (errmsg_len > len)
 178               memset (&errmsg[len], ' ', errmsg_len-len);
 179           }
 180       }
 181     else
 182       caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : 1, msg);
 183   }
 184
 185   return NULL;
 186 }
 187
 188
 189 int
 190 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
 191 {
 192   return 0;
 193 }
 194
 195
 196 void
 197 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
 198 {
 199   int ierr;
 200
 201   if (unlikely (caf_is_finalized))
 202     ierr = STAT_STOPPED_IMAGE;
 203   else
 204     ierr = MPI_Barrier (MPI_COMM_WORLD);
 205
 206   if (stat)
 207     *stat = ierr;
 208
 209   if (ierr)
 210     {
 211       char *msg;
 212       if (caf_is_finalized)
 213         msg = "SYNC ALL failed - there are stopped images";
 214       else
 215         msg = "SYNC ALL failed";
 216
 217       if (errmsg_len > 0)
 218         {
 219           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 220                                                       : (int) strlen (msg);
 221           memcpy (errmsg, msg, len);
 222           if (errmsg_len > len)
 223             memset (&errmsg[len], ' ', errmsg_len-len);
 224         }
 225       else
 226         caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
 227     }
 228 }
 229
 230
 231 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 232    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 233    is not equivalent to SYNC ALL. */
 234 void
 235 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
 236                            int errmsg_len)
 237 {
 238   int ierr;
 239   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 240     {
 241       if (stat)
 242         *stat = 0;
 243       return;
 244     }
 245
 246 #ifdef GFC_CAF_CHECK
 247   {
 248     int i;
 249
 250     for (i = 0; i < count; i++)
 251       if (images[i] < 1 || images[i] > caf_num_images)
 252         {
 253           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 254                    "IMAGES", images[i]);
 255           error_stop (1);
 256         }
 257   }
 258 #endif
 259
 260   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 261      mapped to MPI communicators. Thus, exist early with an error message.  */
 262   if (count > 0)
 263     {
 264       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 265       error_stop (1);
 266     }
 267
 268   /* Handle SYNC IMAGES(*).  */
 269   if (unlikely(caf_is_finalized))
 270     ierr = STAT_STOPPED_IMAGE;
 271   else
 272     ierr = MPI_Barrier (MPI_COMM_WORLD);
 273
 274   if (stat)
 275     *stat = ierr;
 276
 277   if (ierr)
 278     {
 279       char *msg;
 280       if (caf_is_finalized)
 281         msg = "SYNC IMAGES failed - there are stopped images";
 282       else
 283         msg = "SYNC IMAGES failed";
 284
 285       if (errmsg_len > 0)
 286         {
 287           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
 288                                                       : (int) strlen (msg);
 289           memcpy (errmsg, msg, len);
 290           if (errmsg_len > len)
 291             memset (&errmsg[len], ' ', errmsg_len-len);
 292         }
 293       else
 294         caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
 295     }
 296 }
 297
 298
 299 /* ERROR STOP the other images.  */
 300
 301 static void
 302 error_stop (int error)
 303 {
 304   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 305   /* FIXME: Do some more effort than just MPI_ABORT.  */
 306   MPI_Abort (MPI_COMM_WORLD, error);
 307
 308   /* Should be unreachable, but to make sure also call exit.  */
 309   exit (error);
 310 }
 311
 312
 313 /* ERROR STOP function for string arguments.  */
 314
 315 void
 316 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 317 {
 318   fputs ("ERROR STOP ", stderr);
 319   while (len--)
 320     fputc (*(string++), stderr);
 321   fputs ("\n", stderr);
 322
 323   error_stop (1);
 324 }
 325
 326
 327 /* ERROR STOP function for numerical arguments.  */
 328
 329 void
 330 _gfortran_caf_error_stop (int32_t error)
 331 {
 332   fprintf (stderr, "ERROR STOP %d\n", error);
 333   error_stop (error);
 334 }