OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [caf/] [mpi.c] - Blame information for rev 733

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.