1 /* MPI implementation of GNU Fortran Coarray Library 2 Copyright (C) 2011-2019 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 } 383