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