]>
Commit | Line | Data |
---|---|---|
5092eb96 | 1 | /* MPI implementation of GNU Fortran Coarray Library |
a5544970 | 2 | Copyright (C) 2011-2019 Free Software Foundation, Inc. |
5092eb96 TB |
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> | |
cc9ae24c | 29 | #include <string.h> /* For memcpy. */ |
41de45c6 | 30 | #include <stdarg.h> /* For variadic arguments. */ |
5092eb96 TB |
31 | #include <mpi.h> |
32 | ||
cc9ae24c | 33 | |
5092eb96 TB |
34 | /* Define GFC_CAF_CHECK to enable run-time checking. */ |
35 | /* #define GFC_CAF_CHECK 1 */ | |
36 | ||
a8a5f4a9 TB |
37 | typedef void ** mpi_token_t; |
38 | #define TOKEN(X) ((mpi_token_t) (X)) | |
5092eb96 TB |
39 | |
40 | static void error_stop (int error) __attribute__ ((noreturn)); | |
41 | ||
42 | /* Global variables. */ | |
6eb87b33 | 43 | static int caf_mpi_initialized; |
5092eb96 TB |
44 | static int caf_this_image; |
45 | static int caf_num_images; | |
4054bc52 | 46 | static int caf_is_finalized; |
5092eb96 | 47 | |
0a1138af DC |
48 | caf_static_t *caf_static_list = NULL; |
49 | ||
5092eb96 | 50 | |
80196940 | 51 | /* Keep in sync with single.c. */ |
41de45c6 | 52 | static void |
80196940 | 53 | caf_runtime_error (const char *message, ...) |
41de45c6 TB |
54 | { |
55 | va_list ap; | |
56 | fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image); | |
57 | va_start (ap, message); | |
c0f15792 | 58 | vfprintf (stderr, message, ap); |
41de45c6 TB |
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. */ | |
80196940 | 64 | MPI_Abort (MPI_COMM_WORLD, EXIT_FAILURE); |
41de45c6 TB |
65 | |
66 | /* Should be unreachable, but to make sure also call exit. */ | |
80196940 | 67 | exit (EXIT_FAILURE); |
41de45c6 TB |
68 | } |
69 | ||
70 | ||
5092eb96 TB |
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 | |
a8a5f4a9 | 78 | _gfortran_caf_init (int *argc, char ***argv) |
5092eb96 | 79 | { |
0a1138af DC |
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 | } | |
5092eb96 TB |
92 | } |
93 | ||
94 | ||
6eb87b33 | 95 | /* Finalize coarray program. */ |
5092eb96 TB |
96 | |
97 | void | |
98 | _gfortran_caf_finalize (void) | |
99 | { | |
0a1138af DC |
100 | while (caf_static_list != NULL) |
101 | { | |
86187d0f TB |
102 | caf_static_t *tmp = caf_static_list->prev; |
103 | ||
a8a5f4a9 TB |
104 | free (TOKEN (caf_static_list->token)[caf_this_image-1]); |
105 | free (TOKEN (caf_static_list->token)); | |
86187d0f TB |
106 | free (caf_static_list); |
107 | caf_static_list = tmp; | |
0a1138af DC |
108 | } |
109 | ||
6eb87b33 TB |
110 | if (!caf_mpi_initialized) |
111 | MPI_Finalize (); | |
4054bc52 TB |
112 | |
113 | caf_is_finalized = 1; | |
5092eb96 TB |
114 | } |
115 | ||
116 | ||
a8a5f4a9 TB |
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)), | |
a9fe6877 | 126 | int failed __attribute__ ((unused))) |
a8a5f4a9 TB |
127 | { |
128 | return caf_num_images; | |
129 | } | |
130 | ||
131 | ||
cc9ae24c | 132 | void * |
a8a5f4a9 | 133 | _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, |
3f5fabc0 | 134 | int *stat, char *errmsg, size_t errmsg_len, |
3c9f5092 | 135 | int num_alloc_comps __attribute__ ((unused))) |
cc9ae24c | 136 | { |
0a1138af | 137 | void *local; |
4054bc52 TB |
138 | int err; |
139 | ||
140 | if (unlikely (caf_is_finalized)) | |
141 | goto error; | |
0a1138af DC |
142 | |
143 | /* Start MPI if not already started. */ | |
144 | if (caf_num_images == 0) | |
a8a5f4a9 | 145 | _gfortran_caf_init (NULL, NULL); |
0a1138af DC |
146 | |
147 | /* Token contains only a list of pointers. */ | |
148 | local = malloc (size); | |
a8a5f4a9 | 149 | *token = malloc (sizeof (mpi_token_t) * caf_num_images); |
0a1138af | 150 | |
5d81ddd0 | 151 | if (unlikely (local == NULL || *token == NULL)) |
4054bc52 TB |
152 | goto error; |
153 | ||
0a1138af | 154 | /* token[img-1] is the address of the token in image "img". */ |
a8a5f4a9 | 155 | err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, TOKEN (*token), |
4054bc52 | 156 | sizeof (void*), MPI_BYTE, MPI_COMM_WORLD); |
5d81ddd0 | 157 | |
4054bc52 TB |
158 | if (unlikely (err)) |
159 | { | |
160 | free (local); | |
5d81ddd0 | 161 | free (*token); |
4054bc52 TB |
162 | goto error; |
163 | } | |
0a1138af DC |
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; | |
5d81ddd0 | 169 | tmp->token = *token; |
0a1138af DC |
170 | caf_static_list = tmp; |
171 | } | |
4054bc52 TB |
172 | |
173 | if (stat) | |
174 | *stat = 0; | |
175 | ||
0a1138af | 176 | return local; |
4054bc52 TB |
177 | |
178 | error: | |
41de45c6 TB |
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 | { | |
3f5fabc0 JB |
192 | size_t len = (strlen (msg) > errmsg_len) ? errmsg_len |
193 | : strlen (msg); | |
41de45c6 TB |
194 | memcpy (errmsg, msg, len); |
195 | if (errmsg_len > len) | |
196 | memset (&errmsg[len], ' ', errmsg_len-len); | |
197 | } | |
198 | } | |
199 | else | |
80196940 | 200 | caf_runtime_error (msg); |
41de45c6 TB |
201 | } |
202 | ||
203 | return NULL; | |
cc9ae24c TB |
204 | } |
205 | ||
206 | ||
86187d0f | 207 | void |
3f5fabc0 | 208 | _gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, size_t errmsg_len) |
cc9ae24c | 209 | { |
86187d0f TB |
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 | { | |
3f5fabc0 JB |
220 | size_t len = (sizeof (msg) - 1 > errmsg_len) |
221 | ? errmsg_len : sizeof (msg) - 1; | |
86187d0f TB |
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 | ||
a8a5f4a9 | 236 | free (TOKEN (*token)[caf_this_image-1]); |
5d81ddd0 | 237 | free (*token); |
cc9ae24c TB |
238 | } |
239 | ||
240 | ||
f5c01f5b | 241 | void |
3f5fabc0 | 242 | _gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len) |
5092eb96 | 243 | { |
41de45c6 | 244 | int ierr; |
f5c01f5b | 245 | |
41de45c6 TB |
246 | if (unlikely (caf_is_finalized)) |
247 | ierr = STAT_STOPPED_IMAGE; | |
248 | else | |
249 | ierr = MPI_Barrier (MPI_COMM_WORLD); | |
250 | ||
f5c01f5b DC |
251 | if (stat) |
252 | *stat = ierr; | |
5092eb96 | 253 | |
f5c01f5b | 254 | if (ierr) |
5092eb96 | 255 | { |
41de45c6 TB |
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 | ||
f5c01f5b DC |
262 | if (errmsg_len > 0) |
263 | { | |
3f5fabc0 JB |
264 | size_t len = (strlen (msg) > errmsg_len) ? errmsg_len |
265 | : strlen (msg); | |
f5c01f5b DC |
266 | memcpy (errmsg, msg, len); |
267 | if (errmsg_len > len) | |
268 | memset (&errmsg[len], ' ', errmsg_len-len); | |
269 | } | |
270 | else | |
80196940 | 271 | caf_runtime_error (msg); |
5092eb96 | 272 | } |
5092eb96 TB |
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(*) | |
f5c01f5b DC |
278 | is not equivalent to SYNC ALL. */ |
279 | void | |
280 | _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, | |
3f5fabc0 | 281 | size_t errmsg_len) |
5092eb96 TB |
282 | { |
283 | int ierr; | |
5092eb96 | 284 | if (count == 0 || (count == 1 && images[0] == caf_this_image)) |
f5c01f5b DC |
285 | { |
286 | if (stat) | |
287 | *stat = 0; | |
288 | return; | |
289 | } | |
5092eb96 TB |
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(*). */ | |
86187d0f | 314 | if (unlikely (caf_is_finalized)) |
41de45c6 TB |
315 | ierr = STAT_STOPPED_IMAGE; |
316 | else | |
317 | ierr = MPI_Barrier (MPI_COMM_WORLD); | |
318 | ||
f5c01f5b DC |
319 | if (stat) |
320 | *stat = ierr; | |
5092eb96 | 321 | |
f5c01f5b | 322 | if (ierr) |
5092eb96 | 323 | { |
41de45c6 TB |
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 | ||
f5c01f5b DC |
330 | if (errmsg_len > 0) |
331 | { | |
3f5fabc0 JB |
332 | size_t len = (strlen (msg) > errmsg_len) ? errmsg_len |
333 | : strlen (msg); | |
f5c01f5b DC |
334 | memcpy (errmsg, msg, len); |
335 | if (errmsg_len > len) | |
336 | memset (&errmsg[len], ' ', errmsg_len-len); | |
337 | } | |
338 | else | |
80196940 | 339 | caf_runtime_error (msg); |
5092eb96 | 340 | } |
5092eb96 TB |
341 | } |
342 | ||
343 | ||
5092eb96 TB |
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 | |
dffb1e22 | 361 | _gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet) |
5092eb96 | 362 | { |
dffb1e22 JB |
363 | if (!quiet) |
364 | { | |
365 | fputs ("ERROR STOP ", stderr); | |
366 | while (len--) | |
367 | fputc (*(string++), stderr); | |
368 | fputs ("\n", stderr); | |
369 | } | |
5092eb96 TB |
370 | error_stop (1); |
371 | } | |
372 | ||
373 | ||
374 | /* ERROR STOP function for numerical arguments. */ | |
375 | ||
376 | void | |
dffb1e22 | 377 | _gfortran_caf_error_stop (int error, bool quiet) |
5092eb96 | 378 | { |
dffb1e22 JB |
379 | if (!quiet) |
380 | fprintf (stderr, "ERROR STOP %d\n", error); | |
5092eb96 TB |
381 | error_stop (error); |
382 | } |