1 /* MPI implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2014 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
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 static int caf_is_finalized;
45
46 caf_static_t *caf_static_list = NULL;
47
48
49 /* Keep in sync with single.c. */
50 static void
caf_runtime_error(const char * message,...)51 caf_runtime_error (const char *message, ...)
52 {
53 va_list ap;
54 fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
55 va_start (ap, message);
56 vfprintf (stderr, message, ap);
57 va_end (ap);
58 fprintf (stderr, "\n");
59
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, EXIT_FAILURE);
63
64 /* Should be unreachable, but to make sure also call exit. */
65 exit (EXIT_FAILURE);
66 }
67
68
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. */
74
75 void
_gfortran_caf_init(int * argc,char *** argv,int * this_image,int * num_images)76 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
77 {
78 if (caf_num_images == 0)
79 {
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);
85
86 MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
87 MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
88 caf_this_image++;
89 }
90
91 if (this_image)
92 *this_image = caf_this_image;
93 if (num_images)
94 *num_images = caf_num_images;
95 }
96
97
98 /* Finalize coarray program. */
99
100 void
_gfortran_caf_finalize(void)101 _gfortran_caf_finalize (void)
102 {
103 while (caf_static_list != NULL)
104 {
105 caf_static_t *tmp = caf_static_list->prev;
106
107 free (caf_static_list->token[caf_this_image-1]);
108 free (caf_static_list->token);
109 free (caf_static_list);
110 caf_static_list = tmp;
111 }
112
113 if (!caf_mpi_initialized)
114 MPI_Finalize ();
115
116 caf_is_finalized = 1;
117 }
118
119
120 void *
_gfortran_caf_register(ptrdiff_t size,caf_register_t type,void *** token,int * stat,char * errmsg,int errmsg_len)121 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
122 int *stat, char *errmsg, int errmsg_len)
123 {
124 void *local;
125 int err;
126
127 if (unlikely (caf_is_finalized))
128 goto error;
129
130 /* Start MPI if not already started. */
131 if (caf_num_images == 0)
132 _gfortran_caf_init (NULL, NULL, NULL, NULL);
133
134 /* Token contains only a list of pointers. */
135 local = malloc (size);
136 *token = malloc (sizeof (void*) * caf_num_images);
137
138 if (unlikely (local == NULL || *token == NULL))
139 goto error;
140
141 /* token[img-1] is the address of the token in image "img". */
142 err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, *token,
143 sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
144
145 if (unlikely (err))
146 {
147 free (local);
148 free (*token);
149 goto error;
150 }
151
152 if (type == CAF_REGTYPE_COARRAY_STATIC)
153 {
154 caf_static_t *tmp = malloc (sizeof (caf_static_t));
155 tmp->prev = caf_static_list;
156 tmp->token = *token;
157 caf_static_list = tmp;
158 }
159
160 if (stat)
161 *stat = 0;
162
163 return local;
164
165 error:
166 {
167 char *msg;
168
169 if (caf_is_finalized)
170 msg = "Failed to allocate coarray - there are stopped images";
171 else
172 msg = "Failed to allocate coarray";
173
174 if (stat)
175 {
176 *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
177 if (errmsg_len > 0)
178 {
179 int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
180 : (int) strlen (msg);
181 memcpy (errmsg, msg, len);
182 if (errmsg_len > len)
183 memset (&errmsg[len], ' ', errmsg_len-len);
184 }
185 }
186 else
187 caf_runtime_error (msg);
188 }
189
190 return NULL;
191 }
192
193
194 void
_gfortran_caf_deregister(void *** token,int * stat,char * errmsg,int errmsg_len)195 _gfortran_caf_deregister (void ***token, int *stat, char *errmsg, int errmsg_len)
196 {
197 if (unlikely (caf_is_finalized))
198 {
199 const char msg[] = "Failed to deallocate coarray - "
200 "there are stopped images";
201 if (stat)
202 {
203 *stat = STAT_STOPPED_IMAGE;
204
205 if (errmsg_len > 0)
206 {
207 int len = ((int) sizeof (msg) - 1 > errmsg_len)
208 ? errmsg_len : (int) sizeof (msg) - 1;
209 memcpy (errmsg, msg, len);
210 if (errmsg_len > len)
211 memset (&errmsg[len], ' ', errmsg_len-len);
212 }
213 return;
214 }
215 caf_runtime_error (msg);
216 }
217
218 _gfortran_caf_sync_all (NULL, NULL, 0);
219
220 if (stat)
221 *stat = 0;
222
223 free ((*token)[caf_this_image-1]);
224 free (*token);
225 }
226
227
228 void
_gfortran_caf_sync_all(int * stat,char * errmsg,int errmsg_len)229 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
230 {
231 int ierr;
232
233 if (unlikely (caf_is_finalized))
234 ierr = STAT_STOPPED_IMAGE;
235 else
236 ierr = MPI_Barrier (MPI_COMM_WORLD);
237
238 if (stat)
239 *stat = ierr;
240
241 if (ierr)
242 {
243 char *msg;
244 if (caf_is_finalized)
245 msg = "SYNC ALL failed - there are stopped images";
246 else
247 msg = "SYNC ALL failed";
248
249 if (errmsg_len > 0)
250 {
251 int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
252 : (int) strlen (msg);
253 memcpy (errmsg, msg, len);
254 if (errmsg_len > len)
255 memset (&errmsg[len], ' ', errmsg_len-len);
256 }
257 else
258 caf_runtime_error (msg);
259 }
260 }
261
262
263 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
264 SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
265 is not equivalent to SYNC ALL. */
266 void
_gfortran_caf_sync_images(int count,int images[],int * stat,char * errmsg,int errmsg_len)267 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
268 int errmsg_len)
269 {
270 int ierr;
271 if (count == 0 || (count == 1 && images[0] == caf_this_image))
272 {
273 if (stat)
274 *stat = 0;
275 return;
276 }
277
278 #ifdef GFC_CAF_CHECK
279 {
280 int i;
281
282 for (i = 0; i < count; i++)
283 if (images[i] < 1 || images[i] > caf_num_images)
284 {
285 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
286 "IMAGES", images[i]);
287 error_stop (1);
288 }
289 }
290 #endif
291
292 /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
293 mapped to MPI communicators. Thus, exist early with an error message. */
294 if (count > 0)
295 {
296 fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
297 error_stop (1);
298 }
299
300 /* Handle SYNC IMAGES(*). */
301 if (unlikely (caf_is_finalized))
302 ierr = STAT_STOPPED_IMAGE;
303 else
304 ierr = MPI_Barrier (MPI_COMM_WORLD);
305
306 if (stat)
307 *stat = ierr;
308
309 if (ierr)
310 {
311 char *msg;
312 if (caf_is_finalized)
313 msg = "SYNC IMAGES failed - there are stopped images";
314 else
315 msg = "SYNC IMAGES failed";
316
317 if (errmsg_len > 0)
318 {
319 int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
320 : (int) strlen (msg);
321 memcpy (errmsg, msg, len);
322 if (errmsg_len > len)
323 memset (&errmsg[len], ' ', errmsg_len-len);
324 }
325 else
326 caf_runtime_error (msg);
327 }
328 }
329
330
331 /* ERROR STOP the other images. */
332
333 static void
error_stop(int error)334 error_stop (int error)
335 {
336 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
337 /* FIXME: Do some more effort than just MPI_ABORT. */
338 MPI_Abort (MPI_COMM_WORLD, error);
339
340 /* Should be unreachable, but to make sure also call exit. */
341 exit (error);
342 }
343
344
345 /* ERROR STOP function for string arguments. */
346
347 void
_gfortran_caf_error_stop_str(const char * string,int32_t len)348 _gfortran_caf_error_stop_str (const char *string, int32_t len)
349 {
350 fputs ("ERROR STOP ", stderr);
351 while (len--)
352 fputc (*(string++), stderr);
353 fputs ("\n", stderr);
354
355 error_stop (1);
356 }
357
358
359 /* ERROR STOP function for numerical arguments. */
360
361 void
_gfortran_caf_error_stop(int32_t error)362 _gfortran_caf_error_stop (int32_t error)
363 {
364 fprintf (stderr, "ERROR STOP %d\n", error);
365 error_stop (error);
366 }
367