OSDN Git Service

a8306ddb8a74b808b175bbcfe3e56f8fcc6b1f3f
[pf3gnuchains/gcc-fork.git] / libgfortran / caf / mpi.c
1 /* MPI implementation of GNU Fortran Coarray Library
2    Copyright (C) 2011
3    Free Software Foundation, Inc.
4    Contributed by Tobias Burnus <burnus@net-b.de>
5
6 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
7
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)
11 any later version.
12
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.
17
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.
21
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/>.  */
26
27 #include "libcaf.h"
28 #include <stdio.h>
29 #include <stdlib.h>
30 #include <string.h>     /* For memcpy.  */
31 #include <stdarg.h>     /* For variadic arguments.  */
32 #include <mpi.h>
33
34
35 /* Define GFC_CAF_CHECK to enable run-time checking.  */
36 /* #define GFC_CAF_CHECK  1  */
37
38
39 static void error_stop (int error) __attribute__ ((noreturn));
40
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;
46
47 caf_static_t *caf_static_list = NULL;
48
49
50 static void
51 caf_runtime_error (int 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   fprintf (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, error);
63
64   /* Should be unreachable, but to make sure also call exit.  */
65   exit (2);
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
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
101 _gfortran_caf_finalize (void)
102 {
103   while (caf_static_list != NULL)
104     {
105       free(caf_static_list->token[caf_this_image-1]);
106       caf_static_list = caf_static_list->prev;
107     }
108
109   if (!caf_mpi_initialized)
110     MPI_Finalize ();
111
112   caf_is_finalized = 1;
113 }
114
115
116 void *
117 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
118                         int *stat, char *errmsg, int errmsg_len)
119 {
120   void *local;
121   int err;
122
123   if (unlikely (caf_is_finalized))
124     goto error;
125
126   /* Start MPI if not already started.  */
127   if (caf_num_images == 0)
128     _gfortran_caf_init (NULL, NULL, NULL, NULL);
129
130   /* Token contains only a list of pointers.  */
131   local = malloc (size);
132   token = malloc (sizeof (void*) * caf_num_images);
133
134   if (unlikely (local == NULL || token == NULL))
135     goto error;
136
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);
140   if (unlikely (err))
141     {
142       free (local);
143       free (token);
144       goto error;
145     }
146
147   if (type == CAF_REGTYPE_COARRAY_STATIC)
148     {
149       caf_static_t *tmp = malloc (sizeof (caf_static_t));
150       tmp->prev  = caf_static_list;
151       tmp->token = token;
152       caf_static_list = tmp;
153     }
154
155   if (stat)
156     *stat = 0;
157
158   return local;
159
160 error:
161   {
162     char *msg;
163
164     if (caf_is_finalized)
165       msg = "Failed to allocate coarray - there are stopped images";
166     else
167       msg = "Failed to allocate coarray";
168
169     if (stat)
170       {
171         *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
172         if (errmsg_len > 0)
173           {
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);
179           }
180       }
181     else
182       caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : 1, msg);
183   }
184
185   return NULL;
186 }
187
188
189 int
190 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
191 {
192   return 0;
193 }
194
195
196 void
197 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
198 {
199   int ierr;
200
201   if (unlikely (caf_is_finalized))
202     ierr = STAT_STOPPED_IMAGE;
203   else
204     ierr = MPI_Barrier (MPI_COMM_WORLD);
205  
206   if (stat)
207     *stat = ierr;
208
209   if (ierr)
210     {
211       char *msg;
212       if (caf_is_finalized)
213         msg = "SYNC ALL failed - there are stopped images";
214       else
215         msg = "SYNC ALL failed";
216
217       if (errmsg_len > 0)
218         {
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);
224         }
225       else
226         caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
227     }
228 }
229
230
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. */
234 void
235 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
236                            int errmsg_len)
237 {
238   int ierr;
239   if (count == 0 || (count == 1 && images[0] == caf_this_image))
240     {
241       if (stat)
242         *stat = 0;
243       return;
244     }
245
246 #ifdef GFC_CAF_CHECK
247   {
248     int i;
249
250     for (i = 0; i < count; i++)
251       if (images[i] < 1 || images[i] > caf_num_images)
252         {
253           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
254                    "IMAGES", images[i]);
255           error_stop (1);
256         }
257   }
258 #endif
259
260   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
261      mapped to MPI communicators. Thus, exist early with an error message.  */
262   if (count > 0)
263     {
264       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
265       error_stop (1);
266     }
267
268   /* Handle SYNC IMAGES(*).  */
269   if (unlikely(caf_is_finalized))
270     ierr = STAT_STOPPED_IMAGE;
271   else
272     ierr = MPI_Barrier (MPI_COMM_WORLD);
273
274   if (stat)
275     *stat = ierr;
276
277   if (ierr)
278     {
279       char *msg;
280       if (caf_is_finalized)
281         msg = "SYNC IMAGES failed - there are stopped images";
282       else
283         msg = "SYNC IMAGES failed";
284
285       if (errmsg_len > 0)
286         {
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);
292         }
293       else
294         caf_runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : ierr, msg);
295     }
296 }
297
298
299 /* ERROR STOP the other images.  */
300
301 static void
302 error_stop (int error)
303 {
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);
307
308   /* Should be unreachable, but to make sure also call exit.  */
309   exit (error);
310 }
311
312
313 /* ERROR STOP function for string arguments.  */
314
315 void
316 _gfortran_caf_error_stop_str (const char *string, int32_t len)
317 {
318   fputs ("ERROR STOP ", stderr);
319   while (len--)
320     fputc (*(string++), stderr);
321   fputs ("\n", stderr);
322
323   error_stop (1);
324 }
325
326
327 /* ERROR STOP function for numerical arguments.  */
328
329 void
330 _gfortran_caf_error_stop (int32_t error)
331 {
332   fprintf (stderr, "ERROR STOP %d\n", error);
333   error_stop (error);
334 }