1 /* MPI implementation of GNU Fortran Coarray Library
3 Free Software Foundation, Inc.
4 Contributed by Tobias Burnus <burnus@net-b.de>
6 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
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)
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.
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.
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/>. */
30 #include <string.h> /* For memcpy. */
31 #include <stdarg.h> /* For variadic arguments. */
35 /* Define GFC_CAF_CHECK to enable run-time checking. */
36 /* #define GFC_CAF_CHECK 1 */
39 static void error_stop (int error) __attribute__ ((noreturn));
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;
47 caf_static_t *caf_static_list = NULL;
51 caf_runtime_error (int error, const char *message, ...)
54 fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
55 va_start (ap, message);
56 fprintf (stderr, message, ap);
58 fprintf (stderr, "\n");
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);
64 /* Should be unreachable, but to make sure also call exit. */
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. */
76 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
78 if (caf_num_images == 0)
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);
86 MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
87 MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
92 *this_image = caf_this_image;
94 *num_images = caf_num_images;
98 /* Finalize coarray program. */
101 _gfortran_caf_finalize (void)
103 while (caf_static_list != NULL)
105 free(caf_static_list->token[caf_this_image-1]);
106 caf_static_list = caf_static_list->prev;
109 if (!caf_mpi_initialized)
112 caf_is_finalized = 1;
117 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
118 int *stat, char *errmsg, int errmsg_len)
123 if (unlikely (caf_is_finalized))
126 /* Start MPI if not already started. */
127 if (caf_num_images == 0)
128 _gfortran_caf_init (NULL, NULL, NULL, NULL);
130 /* Token contains only a list of pointers. */
131 local = malloc (size);
132 token = malloc (sizeof (void*) * caf_num_images);
134 if (unlikely (local == NULL || token == NULL))
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);
147 if (type == CAF_REGTYPE_COARRAY_STATIC)
149 caf_static_t *tmp = malloc (sizeof (caf_static_t));
150 tmp->prev = caf_static_list;
152 caf_static_list = tmp;
164 if (caf_is_finalized)
165 msg = "Failed to allocate coarray - there are stopped images";
167 msg = "Failed to allocate coarray";
171 *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
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);
182 caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : 1, msg);
190 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
197 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
201 if (unlikely (caf_is_finalized))
202 ierr = STAT_STOPPED_IMAGE;
204 ierr = MPI_Barrier (MPI_COMM_WORLD);
212 if (caf_is_finalized)
213 msg = "SYNC ALL failed - there are stopped images";
215 msg = "SYNC ALL failed";
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);
226 caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
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. */
235 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
239 if (count == 0 || (count == 1 && images[0] == caf_this_image))
250 for (i = 0; i < count; i++)
251 if (images[i] < 1 || images[i] > caf_num_images)
253 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
254 "IMAGES", images[i]);
260 /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
261 mapped to MPI communicators. Thus, exist early with an error message. */
264 fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
268 /* Handle SYNC IMAGES(*). */
269 if (unlikely(caf_is_finalized))
270 ierr = STAT_STOPPED_IMAGE;
272 ierr = MPI_Barrier (MPI_COMM_WORLD);
280 if (caf_is_finalized)
281 msg = "SYNC IMAGES failed - there are stopped images";
283 msg = "SYNC IMAGES failed";
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);
294 caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
299 /* ERROR STOP the other images. */
302 error_stop (int error)
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);
308 /* Should be unreachable, but to make sure also call exit. */
313 /* ERROR STOP function for string arguments. */
316 _gfortran_caf_error_stop_str (const char *string, int32_t len)
318 fputs ("ERROR STOP ", stderr);
320 fputc (*(string++), stderr);
321 fputs ("\n", stderr);
327 /* ERROR STOP function for numerical arguments. */
330 _gfortran_caf_error_stop (int32_t error)
332 fprintf (stderr, "ERROR STOP %d\n", error);