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 /* SYNC ALL - the return value matches Fortran's STAT argument.  */
  96
  97 int
  98 _gfortran_caf_sync_all (char *errmsg, int errmsg_len)
  99 {
 100   int ierr;
 101   ierr = MPI_Barrier (MPI_COMM_WORLD);
 102
 103   if (ierr && errmsg_len > 0)
 104     {
 105       const char msg[] = "SYNC ALL failed";
 106       int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 107                                                   : (int) sizeof (msg);
 108       memcpy (errmsg, msg, len);
 109       if (errmsg_len > len)
 110         memset (&errmsg[len], ' ', errmsg_len-len);
 111     }
 112
 113   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
 114   return ierr;
 115 }
 116
 117
 118 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
 119    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
 120    is not equivalent to SYNC ALL.  The return value matches Fortran's
 121    STAT argument.  */
 122 int
 123 _gfortran_caf_sync_images (int count, int images[], char *errmsg,
 124                            int errmsg_len)
 125 {
 126   int ierr;
 127
 128   if (count == 0 || (count == 1 && images[0] == caf_this_image))
 129     return 0;
 130
 131 #ifdef GFC_CAF_CHECK
 132   {
 133     int i;
 134
 135     for (i = 0; i < count; i++)
 136       if (images[i] < 1 || images[i] > caf_num_images)
 137         {
 138           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 139                    "IMAGES", images[i]);
 140           error_stop (1);
 141         }
 142   }
 143 #endif
 144
 145   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
 146      mapped to MPI communicators. Thus, exist early with an error message.  */
 147   if (count > 0)
 148     {
 149       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
 150       error_stop (1);
 151     }
 152
 153   /* Handle SYNC IMAGES(*).  */
 154   ierr = MPI_Barrier (MPI_COMM_WORLD);
 155
 156   if (ierr && errmsg_len > 0)
 157     {
 158       const char msg[] = "SYNC IMAGES failed";
 159       int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 160                                                   : (int) sizeof (msg);
 161       memcpy (errmsg, msg, len);
 162       if (errmsg_len > len)
 163         memset (&errmsg[len], ' ', errmsg_len-len);
 164     }
 165
 166   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
 167   return ierr;
 168 }
 169
 170
 171 /* ERROR STOP the other images.  */
 172
 173 static void
 174 error_stop (int error)
 175 {
 176   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
 177   /* FIXME: Do some more effort than just MPI_ABORT.  */
 178   MPI_Abort (MPI_COMM_WORLD, error);
 179
 180   /* Should be unreachable, but to make sure also call exit.  */
 181   exit (error);
 182 }
 183
 184
 185 /* ERROR STOP function for string arguments.  */
 186
 187 void
 188 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 189 {
 190   fputs ("ERROR STOP ", stderr);
 191   while (len--)
 192     fputc (*(string++), stderr);
 193   fputs ("\n", stderr);
 194
 195   error_stop (1);
 196 }
 197
 198
 199 /* ERROR STOP function for numerical arguments.  */
 200
 201 void
 202 _gfortran_caf_error_stop (int32_t error)
 203 {
 204   fprintf (stderr, "ERROR STOP %d\n", error);
 205   error_stop (error);
 206 }