OSDN Git Service

2011-07-07 Tobias Burnus <burnus@net-b.de>
[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 <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 /* Initialize coarray program.  This routine assumes that no other
50    MPI initialization happened before; otherwise MPI_Initialized
51    had to be used.  As the MPI library might modify the command-line
52    arguments, the routine should be called before the run-time
53    libaray is initialized.  */
54
55 void
56 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
57 {
58   if (caf_num_images == 0)
59     {
60       /* caf_mpi_initialized is only true if the main program is
61        not written in Fortran.  */
62       MPI_Initialized (&caf_mpi_initialized);
63       if (!caf_mpi_initialized)
64         MPI_Init (argc, argv);
65
66       MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
67       MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
68       caf_this_image++;
69     }
70
71   if (this_image)
72     *this_image = caf_this_image;
73   if (num_images)
74     *num_images = caf_num_images;
75 }
76
77
78 /* Finalize coarray program.   */
79
80 void
81 _gfortran_caf_finalize (void)
82 {
83   while (caf_static_list != NULL)
84     {
85       free(caf_static_list->token[caf_this_image-1]);
86       caf_static_list = caf_static_list->prev;
87     }
88
89   if (!caf_mpi_initialized)
90     MPI_Finalize ();
91
92   caf_is_finalized = 1;
93 }
94
95
96 void *
97 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
98                         int *stat, char *errmsg, int errmsg_len)
99 {
100   void *local;
101   int err;
102
103   if (unlikely (caf_is_finalized))
104     goto error;
105
106   /* Start MPI if not already started.  */
107   if (caf_num_images == 0)
108     _gfortran_caf_init (NULL, NULL, NULL, NULL);
109
110   /* Token contains only a list of pointers.  */
111   local = malloc (size);
112   token = malloc (sizeof (void*) * caf_num_images);
113
114   if (unlikely (local == NULL || token == NULL))
115     goto error;
116
117   /* token[img-1] is the address of the token in image "img".  */
118   err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token,
119                        sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
120   if (unlikely (err))
121     {
122       free (local);
123       free (token);
124       goto error;
125     }
126
127   if (type == CAF_REGTYPE_COARRAY_STATIC)
128     {
129       caf_static_t *tmp = malloc (sizeof (caf_static_t));
130       tmp->prev  = caf_static_list;
131       tmp->token = token;
132       caf_static_list = tmp;
133     }
134
135   if (stat)
136     *stat = 0;
137
138   return local;
139
140 error:
141   if (stat)
142     {
143       *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
144       if (errmsg_len > 0)
145         {
146           char *msg;
147           if (caf_is_finalized)
148             msg = "Failed to allocate coarray - stopped images";
149           else
150             msg = "Failed to allocate coarray";
151           int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
152                                                       : (int) strlen (msg);
153           memcpy (errmsg, msg, len);
154           if (errmsg_len > len)
155             memset (&errmsg[len], ' ', errmsg_len-len);
156         }
157       return NULL;
158     }
159   else
160     {
161       if (caf_is_finalized)
162         fprintf (stderr, "ERROR: Image %d is stopped, failed to allocate "
163                  "coarray", caf_this_image);
164       else
165         fprintf (stderr, "ERROR: Failed to allocate coarray on image %d\n",
166                  caf_this_image);
167       error_stop (1);
168     }
169 }
170
171
172 int
173 _gfortran_caf_deregister (void **token __attribute__ ((unused)))
174 {
175   return 0;
176 }
177
178
179 void
180 _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)
181 {
182   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
183   int ierr = MPI_Barrier (MPI_COMM_WORLD);
184
185   if (stat)
186     *stat = ierr;
187
188   if (ierr)
189     {
190       const char msg[] = "SYNC ALL failed";
191       if (errmsg_len > 0)
192         {
193           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
194                                                       : (int) sizeof (msg);
195           memcpy (errmsg, msg, len);
196           if (errmsg_len > len)
197             memset (&errmsg[len], ' ', errmsg_len-len);
198         }
199       else
200         {
201           fprintf (stderr, "SYNC ALL failed\n");
202           error_stop (ierr);
203         }
204     }
205 }
206
207
208 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
209    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
210    is not equivalent to SYNC ALL. */
211 void
212 _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
213                            int errmsg_len)
214 {
215   int ierr;
216   if (count == 0 || (count == 1 && images[0] == caf_this_image))
217     {
218       if (stat)
219         *stat = 0;
220       return;
221     }
222
223 #ifdef GFC_CAF_CHECK
224   {
225     int i;
226
227     for (i = 0; i < count; i++)
228       if (images[i] < 1 || images[i] > caf_num_images)
229         {
230           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
231                    "IMAGES", images[i]);
232           error_stop (1);
233         }
234   }
235 #endif
236
237   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
238      mapped to MPI communicators. Thus, exist early with an error message.  */
239   if (count > 0)
240     {
241       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
242       error_stop (1);
243     }
244
245   /* Handle SYNC IMAGES(*).  */
246   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
247   ierr = MPI_Barrier (MPI_COMM_WORLD);
248   if (stat)
249     *stat = ierr;
250
251   if (ierr)
252     {
253       const char msg[] = "SYNC IMAGES failed";
254       if (errmsg_len > 0)
255         {
256           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
257                                                       : (int) sizeof (msg);
258           memcpy (errmsg, msg, len);
259           if (errmsg_len > len)
260             memset (&errmsg[len], ' ', errmsg_len-len);
261         }
262       else
263         {
264           fprintf (stderr, "SYNC IMAGES failed\n");
265           error_stop (ierr);
266         }
267     }
268 }
269
270
271 /* ERROR STOP the other images.  */
272
273 static void
274 error_stop (int error)
275 {
276   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
277   /* FIXME: Do some more effort than just MPI_ABORT.  */
278   MPI_Abort (MPI_COMM_WORLD, error);
279
280   /* Should be unreachable, but to make sure also call exit.  */
281   exit (error);
282 }
283
284
285 /* ERROR STOP function for string arguments.  */
286
287 void
288 _gfortran_caf_error_stop_str (const char *string, int32_t len)
289 {
290   fputs ("ERROR STOP ", stderr);
291   while (len--)
292     fputc (*(string++), stderr);
293   fputs ("\n", stderr);
294
295   error_stop (1);
296 }
297
298
299 /* ERROR STOP function for numerical arguments.  */
300
301 void
302 _gfortran_caf_error_stop (int32_t error)
303 {
304   fprintf (stderr, "ERROR STOP %d\n", error);
305   error_stop (error);
306 }