OSDN Git Service

2011-03-27 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 <mpi.h>
31
32 /* Define GFC_CAF_CHECK to enable run-time checking.  */
33 /* #define GFC_CAF_CHECK  1  */
34
35
36 static void error_stop (int error) __attribute__ ((noreturn));
37
38 /* Global variables.  */
39 static int caf_this_image;
40 static int caf_num_images;
41 static MPI_Win caf_world_window;
42
43
44 /* Initialize coarray program.  This routine assumes that no other
45    MPI initialization happened before; otherwise MPI_Initialized
46    had to be used.  As the MPI library might modify the command-line
47    arguments, the routine should be called before the run-time
48    libaray is initialized.  */
49
50 void
51 _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
52 {
53   int flag;
54
55   /* The following is only the case if one does not have a Fortran
56      main program. */
57   MPI_Initialized (&flag);
58   if (!flag)
59     MPI_Init (argc, argv);
60
61   MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
62   *this_image = caf_this_image + 1;
63   MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
64   *num_images = caf_num_images;
65
66   /* Obtain window for CRITICAL section locking.  */
67   MPI_Win_create (NULL, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
68                   &caf_world_window);
69 }
70
71
72 /* Finalize coarray program. Note: This is only called before the
73    program ends; thus the MPI_Initialized status of _gfortran_caf_init
74    does not play a role.  */
75
76 void
77 _gfortran_caf_finalize (void)
78 {
79   MPI_Win_free (&caf_world_window);
80   MPI_Finalize ();
81 }
82
83
84 /* SYNC ALL - the return value matches Fortran's STAT argument.  */
85
86 int
87 _gfortran_caf_sync_all (char *errmsg, int errmsg_len)
88 {
89   int ierr;
90   ierr = MPI_Barrier (MPI_COMM_WORLD);
91
92   if (ierr && errmsg_len > 0)
93     {
94       const char msg[] = "SYNC ALL failed";
95       int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
96                                                   : (int) sizeof (msg);
97       memcpy (errmsg, msg, len);
98       if (errmsg_len > len)
99         memset (&errmsg[len], ' ', errmsg_len-len);
100     }
101
102   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
103   return ierr;
104 }
105
106
107 /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
108    SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
109    is not equivalent to SYNC ALL.  The return value matches Fortran's
110    STAT argument.  */
111 int
112 _gfortran_caf_sync_images (int count, int images[], char *errmsg,
113                            int errmsg_len)
114 {
115   int ierr;
116
117   if (count == 0 || (count == 1 && images[0] == caf_this_image))
118     return 0;
119
120 #ifdef GFC_CAF_CHECK
121   {
122     int i;
123
124     for (i = 0; i < count; i++)
125       if (images[i] < 1 || images[i] > caf_num_images)
126         {
127           fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
128                    "IMAGES", images[i]);
129           error_stop (1);
130         }
131   }
132 #endif
133
134   /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
135      mapped to MPI communicators. Thus, exist early with an error message.  */
136   if (count > 0)
137     {
138       fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
139       error_stop (1);
140     }
141
142   /* Handle SYNC IMAGES(*).  */
143   ierr = MPI_Barrier (MPI_COMM_WORLD);
144
145   if (ierr && errmsg_len > 0)
146     {
147       const char msg[] = "SYNC IMAGES failed";
148       int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
149                                                   : (int) sizeof (msg);
150       memcpy (errmsg, msg, len);
151       if (errmsg_len > len)
152         memset (&errmsg[len], ' ', errmsg_len-len);
153     }
154
155   /* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used?  */
156   return ierr;
157 }
158
159
160 /* CRITICAL BLOCK. */
161
162 void
163 _gfortran_caf_critical (void)
164 {
165   MPI_Win_lock (MPI_LOCK_SHARED, 0, 0, caf_world_window);
166 }
167
168
169 void
170 _gfortran_caf_end_critical (void)
171 {
172   MPI_Win_unlock (0, caf_world_window);
173 }
174
175
176 /* ERROR STOP the other images.  */
177
178 static void
179 error_stop (int error)
180 {
181   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
182   /* FIXME: Do some more effort than just MPI_ABORT.  */
183   MPI_Abort (MPI_COMM_WORLD, error);
184
185   /* Should be unreachable, but to make sure also call exit.  */
186   exit (error);
187 }
188
189
190 /* ERROR STOP function for string arguments.  */
191
192 void
193 _gfortran_caf_error_stop_str (const char *string, int32_t len)
194 {
195   fputs ("ERROR STOP ", stderr);
196   while (len--)
197     fputc (*(string++), stderr);
198   fputs ("\n", stderr);
199
200   error_stop (1);
201 }
202
203
204 /* ERROR STOP function for numerical arguments.  */
205
206 void
207 _gfortran_caf_error_stop (int32_t error)
208 {
209   fprintf (stderr, "ERROR STOP %d\n", error);
210   error_stop (error);
211 }