1 /* MPI implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011, 2012
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
;
50 /* Keep in sync with single.c. */
52 caf_runtime_error (const char *message
, ...)
55 fprintf (stderr
, "Fortran runtime error on image %d: ", caf_this_image
);
56 va_start (ap
, message
);
57 vfprintf (stderr
, message
, ap
);
59 fprintf (stderr
, "\n");
61 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
62 /* FIXME: Do some more effort than just MPI_ABORT. */
63 MPI_Abort (MPI_COMM_WORLD
, EXIT_FAILURE
);
65 /* Should be unreachable, but to make sure also call exit. */
70 /* Initialize coarray program. This routine assumes that no other
71 MPI initialization happened before; otherwise MPI_Initialized
72 had to be used. As the MPI library might modify the command-line
73 arguments, the routine should be called before the run-time
74 libaray is initialized. */
77 _gfortran_caf_init (int *argc
, char ***argv
, int *this_image
, int *num_images
)
79 if (caf_num_images
== 0)
81 /* caf_mpi_initialized is only true if the main program is
82 not written in Fortran. */
83 MPI_Initialized (&caf_mpi_initialized
);
84 if (!caf_mpi_initialized
)
85 MPI_Init (argc
, argv
);
87 MPI_Comm_size (MPI_COMM_WORLD
, &caf_num_images
);
88 MPI_Comm_rank (MPI_COMM_WORLD
, &caf_this_image
);
93 *this_image
= caf_this_image
;
95 *num_images
= caf_num_images
;
99 /* Finalize coarray program. */
102 _gfortran_caf_finalize (void)
104 while (caf_static_list
!= NULL
)
106 caf_static_t
*tmp
= caf_static_list
->prev
;
108 free (caf_static_list
->token
[caf_this_image
-1]);
109 free (caf_static_list
->token
);
110 free (caf_static_list
);
111 caf_static_list
= tmp
;
114 if (!caf_mpi_initialized
)
117 caf_is_finalized
= 1;
122 _gfortran_caf_register (ptrdiff_t size
, caf_register_t type
, void ***token
,
123 int *stat
, char *errmsg
, int errmsg_len
)
128 if (unlikely (caf_is_finalized
))
131 /* Start MPI if not already started. */
132 if (caf_num_images
== 0)
133 _gfortran_caf_init (NULL
, NULL
, NULL
, NULL
);
135 /* Token contains only a list of pointers. */
136 local
= malloc (size
);
137 *token
= malloc (sizeof (void*) * caf_num_images
);
139 if (unlikely (local
== NULL
|| *token
== NULL
))
142 /* token[img-1] is the address of the token in image "img". */
143 err
= MPI_Allgather (&local
, sizeof (void*), MPI_BYTE
, *token
,
144 sizeof (void*), MPI_BYTE
, MPI_COMM_WORLD
);
153 if (type
== CAF_REGTYPE_COARRAY_STATIC
)
155 caf_static_t
*tmp
= malloc (sizeof (caf_static_t
));
156 tmp
->prev
= caf_static_list
;
158 caf_static_list
= tmp
;
170 if (caf_is_finalized
)
171 msg
= "Failed to allocate coarray - there are stopped images";
173 msg
= "Failed to allocate coarray";
177 *stat
= caf_is_finalized
? STAT_STOPPED_IMAGE
: 1;
180 int len
= ((int) strlen (msg
) > errmsg_len
) ? errmsg_len
181 : (int) strlen (msg
);
182 memcpy (errmsg
, msg
, len
);
183 if (errmsg_len
> len
)
184 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
188 caf_runtime_error (msg
);
196 _gfortran_caf_deregister (void ***token
, int *stat
, char *errmsg
, int errmsg_len
)
198 if (unlikely (caf_is_finalized
))
200 const char msg
[] = "Failed to deallocate coarray - "
201 "there are stopped images";
204 *stat
= STAT_STOPPED_IMAGE
;
208 int len
= ((int) sizeof (msg
) - 1 > errmsg_len
)
209 ? errmsg_len
: (int) sizeof (msg
) - 1;
210 memcpy (errmsg
, msg
, len
);
211 if (errmsg_len
> len
)
212 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
216 caf_runtime_error (msg
);
219 _gfortran_caf_sync_all (NULL
, NULL
, 0);
224 free ((*token
)[caf_this_image
-1]);
230 _gfortran_caf_sync_all (int *stat
, char *errmsg
, int errmsg_len
)
234 if (unlikely (caf_is_finalized
))
235 ierr
= STAT_STOPPED_IMAGE
;
237 ierr
= MPI_Barrier (MPI_COMM_WORLD
);
245 if (caf_is_finalized
)
246 msg
= "SYNC ALL failed - there are stopped images";
248 msg
= "SYNC ALL failed";
252 int len
= ((int) strlen (msg
) > errmsg_len
) ? errmsg_len
253 : (int) strlen (msg
);
254 memcpy (errmsg
, msg
, len
);
255 if (errmsg_len
> len
)
256 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
259 caf_runtime_error (msg
);
264 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
265 SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
266 is not equivalent to SYNC ALL. */
268 _gfortran_caf_sync_images (int count
, int images
[], int *stat
, char *errmsg
,
272 if (count
== 0 || (count
== 1 && images
[0] == caf_this_image
))
283 for (i
= 0; i
< count
; i
++)
284 if (images
[i
] < 1 || images
[i
] > caf_num_images
)
286 fprintf (stderr
, "COARRAY ERROR: Invalid image index %d to SYNC "
287 "IMAGES", images
[i
]);
293 /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
294 mapped to MPI communicators. Thus, exist early with an error message. */
297 fprintf (stderr
, "COARRAY ERROR: SYNC IMAGES not yet implemented");
301 /* Handle SYNC IMAGES(*). */
302 if (unlikely (caf_is_finalized
))
303 ierr
= STAT_STOPPED_IMAGE
;
305 ierr
= MPI_Barrier (MPI_COMM_WORLD
);
313 if (caf_is_finalized
)
314 msg
= "SYNC IMAGES failed - there are stopped images";
316 msg
= "SYNC IMAGES failed";
320 int len
= ((int) strlen (msg
) > errmsg_len
) ? errmsg_len
321 : (int) strlen (msg
);
322 memcpy (errmsg
, msg
, len
);
323 if (errmsg_len
> len
)
324 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
327 caf_runtime_error (msg
);
332 /* ERROR STOP the other images. */
335 error_stop (int error
)
337 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
338 /* FIXME: Do some more effort than just MPI_ABORT. */
339 MPI_Abort (MPI_COMM_WORLD
, error
);
341 /* Should be unreachable, but to make sure also call exit. */
346 /* ERROR STOP function for string arguments. */
349 _gfortran_caf_error_stop_str (const char *string
, int32_t len
)
351 fputs ("ERROR STOP ", stderr
);
353 fputc (*(string
++), stderr
);
354 fputs ("\n", stderr
);
360 /* ERROR STOP function for numerical arguments. */
363 _gfortran_caf_error_stop (int32_t error
)
365 fprintf (stderr
, "ERROR STOP %d\n", error
);