OSDN Git Service

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