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 <mpi.h>
  32
  33
  34 /* Define GFC_CAF_CHECK to enable run-time checking.  */
  35 /* #define GFC_CAF_CHECK  1  */
  36
  37
  38 static void error_stop (int error) __attribute__ ((noreturn));
  39
  40 /* Global variables.  */
  41 static int caf_mpi_initialized;
  42 static int caf_this_image;
  43 static int caf_num_images;
  44
  45
  46 /* Initialize coarray program.  This routine assumes that no other
  47    MPI initialization happened before; otherwise MPI_Initialized
  48    had to be used.  As the MPI library might modify the command-line
  49    arguments, the routine should be called before the run-time
  50    libaray is initialized.  */
  51
  52 void
  53 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
  54 {
  55   /* caf_mpi_initialized is only true if the main program is not written in
  56      Fortran.  */
  57   MPI_Initialized (&caf_mpi_initialized);
  58   if (!caf_mpi_initialized)
  59     MPI_Init (argc, argv);
  60
  61   MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
  62   *this_image = ++caf_this_image;
  63   MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
  64   *num_images = caf_num_images;
  65 }
  66
  67
  68 /* Finalize coarray program.   */
  69
  70 void
  71 _gfortran_caf_finalize (void)
  72 {
  73   if (!caf_mpi_initialized)
  74     MPI_Finalize ();
  75 }
  76
  77
  78 void *
  79 _gfortran_caf_register (ptrdiff_t size,
  80                         caf_register_t type __attribute__ ((unused)),
  81                         void **token)
  82 {
  83   *token = NULL;
  84   return malloc (size);
  85 }
  86
  87
  88 int
  89 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
  90 {
  91   return 0;
  92 }
  93
  94
  95 void
  96 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
  97 {
  98   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
  99   int ierr = MPI_Barrier (MPI_COMM_WORLD);
 100
 101   if (stat)
 102     *stat = ierr;
 103
 104   if (ierr)
 105     {
 106       const char msg[] = "SYNC ALL failed";
 107       if (errmsg_len > 0)
 108         {
 109           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 110                                                       : (int) sizeof (msg);
 111           memcpy (errmsg, msg, len);
 112           if (errmsg_len > len)
 113             memset (&errmsg[len], ' ', errmsg_len-len);
 114         }
 115       else
 116         {
 117           fprintf (stderr, "SYNC ALL failed\n");
 118           error_stop (ierr);
 119         }
 120     }
 121 }
 122
 123
 124 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 125    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 126    is not equivalent to SYNC ALL. */
 127 void
 128 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
 129                            int errmsg_len)
 130 {
 131   int ierr;
 132   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 133     {
 134       if (stat)
 135         *stat = 0;
 136       return;
 137     }
 138
 139 #ifdef GFC_CAF_CHECK
 140   {
 141     int i;
 142
 143     for (i = 0; i < count; i++)
 144       if (images[i] < 1 || images[i] > caf_num_images)
 145         {
 146           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 147                    "IMAGES", images[i]);
 148           error_stop (1);
 149         }
 150   }
 151 #endif
 152
 153   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 154      mapped to MPI communicators. Thus, exist early with an error message.  */
 155   if (count > 0)
 156     {
 157       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 158       error_stop (1);
 159     }
 160
 161   /* Handle SYNC IMAGES(*).  */
 162   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
 163   ierr = MPI_Barrier (MPI_COMM_WORLD);
 164   if (stat)
 165     *stat = ierr;
 166
 167   if (ierr)
 168     {
 169       const char msg[] = "SYNC IMAGES failed";
 170       if (errmsg_len > 0)
 171         {
 172           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 173                                                       : (int) sizeof (msg);
 174           memcpy (errmsg, msg, len);
 175           if (errmsg_len > len)
 176             memset (&errmsg[len], ' ', errmsg_len-len);
 177         }
 178       else
 179         {
 180           fprintf (stderr, "SYNC IMAGES failed\n");
 181           error_stop (ierr);
 182         }
 183     }
 184 }
 185
 186
 187 /* ERROR STOP the other images.  */
 188
 189 static void
 190 error_stop (int error)
 191 {
 192   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 193   /* FIXME: Do some more effort than just MPI_ABORT.  */
 194   MPI_Abort (MPI_COMM_WORLD, error);
 195
 196   /* Should be unreachable, but to make sure also call exit.  */
 197   exit (error);
 198 }
 199
 200
 201 /* ERROR STOP function for string arguments.  */
 202
 203 void
 204 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 205 {
 206   fputs ("ERROR STOP ", stderr);
 207   while (len--)
 208     fputc (*(string++), stderr);
 209   fputs ("\n", stderr);
 210
 211   error_stop (1);
 212 }
 213
 214
 215 /* ERROR STOP function for numerical arguments.  */
 216
 217 void
 218 _gfortran_caf_error_stop (int32_t error)
 219 {
 220   fprintf (stderr, "ERROR STOP %d\n", error);
 221   error_stop (error);
 222 }