OSDN Git Service

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