libgfortran/caf/single.c

   1 /* Single-image implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2014 Free Software Foundation, Inc.
   3    Contributed by Tobias Burnus <burnus@net-b.de>
   4
   5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
   6
   7 Libcaf is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3, or (at your option)
  10 any later version.
  11
  12 Libcaf is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libcaf.h"
  27 #include <stdio.h>  /* For fputs and fprintf.  */
  28 #include <stdlib.h> /* For exit and malloc.  */
  29 #include <string.h> /* For memcpy and memset.  */
  30 #include <stdarg.h> /* For variadic arguments.  */
  31
  32 /* Define GFC_CAF_CHECK to enable run-time checking.  */
  33 /* #define GFC_CAF_CHECK  1  */
  34
  35 typedef void* single_token_t;
  36 #define TOKEN(X) ((single_token_t) (X))
  37
  38 /* Single-image implementation of the CAF library.
  39    Note: For performance reasons -fcoarry=single should be used
  40    rather than this library.  */
  41
  42 /* Global variables.  */
  43 caf_static_t *caf_static_list = NULL;
  44
  45
  46 /* Keep in sync with mpi.c.  */
  47 static void
  48 caf_runtime_error (const char *message, ...)
  49 {
  50   va_list ap;
  51   fprintf (stderr, "Fortran runtime error: ");
  52   va_start (ap, message);
  53   vfprintf (stderr, message, ap);
  54   va_end (ap);
  55   fprintf (stderr, "\n");
  56
  57   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
  58   exit (EXIT_FAILURE);
  59 }
  60
  61 void
  62 _gfortran_caf_init (int *argc __attribute__ ((unused)),
  63                     char ***argv __attribute__ ((unused)))
  64 {
  65 }
  66
  67
  68 void
  69 _gfortran_caf_finalize (void)
  70 {
  71   while (caf_static_list != NULL)
  72     {
  73       caf_static_t *tmp = caf_static_list->prev;
  74       free (caf_static_list->token);
  75       free (caf_static_list);
  76       caf_static_list = tmp;
  77     }
  78 }
  79
  80
  81 int
  82 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
  83 {
  84   return 1;
  85 }
  86
  87
  88 int
  89 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
  90                           int failed __attribute__ ((unused)))
  91 {
  92   return 1;
  93 }
  94
  95
  96 void *
  97 _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
  98                         int *stat, char *errmsg, int errmsg_len)
  99 {
 100   void *local;
 101
 102   local = malloc (size);
 103   *token = malloc (sizeof (single_token_t));
 104
 105   if (unlikely (local == NULL || token == NULL))
 106     {
 107       const char msg[] = "Failed to allocate coarray";
 108       if (stat)
 109         {
 110           *stat = 1;
 111           if (errmsg_len > 0)
 112             {
 113               int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 114                                                           : (int) sizeof (msg);
 115               memcpy (errmsg, msg, len);
 116               if (errmsg_len > len)
 117                 memset (&errmsg[len], ' ', errmsg_len-len);
 118             }
 119           return NULL;
 120         }
 121       else
 122           caf_runtime_error (msg);
 123     }
 124
 125   *token = local;
 126
 127   if (stat)
 128     *stat = 0;
 129
 130   if (type == CAF_REGTYPE_COARRAY_STATIC)
 131     {
 132       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 133       tmp->prev  = caf_static_list;
 134       tmp->token = *token;
 135       caf_static_list = tmp;
 136     }
 137   return local;
 138 }
 139
 140
 141 void
 142 _gfortran_caf_deregister (caf_token_t *token, int *stat,
 143                           char *errmsg __attribute__ ((unused)),
 144                           int errmsg_len __attribute__ ((unused)))
 145 {
 146   free (TOKEN(*token));
 147
 148   if (stat)
 149     *stat = 0;
 150 }
 151
 152
 153 void
 154 _gfortran_caf_sync_all (int *stat,
 155                         char *errmsg __attribute__ ((unused)),
 156                         int errmsg_len __attribute__ ((unused)))
 157 {
 158   if (stat)
 159     *stat = 0;
 160 }
 161
 162
 163 void
 164 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
 165                            int images[] __attribute__ ((unused)),
 166                            int *stat,
 167                            char *errmsg __attribute__ ((unused)),
 168                            int errmsg_len __attribute__ ((unused)))
 169 {
 170 #ifdef GFC_CAF_CHECK
 171   int i;
 172
 173   for (i = 0; i < count; i++)
 174     if (images[i] != 1)
 175       {
 176         fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 177                  "IMAGES", images[i]);
 178         exit (EXIT_FAILURE);
 179       }
 180 #endif
 181
 182   if (stat)
 183     *stat = 0;
 184 }
 185
 186
 187 void
 188 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 189 {
 190   fputs ("ERROR STOP ", stderr);
 191   while (len--)
 192     fputc (*(string++), stderr);
 193   fputs ("\n", stderr);
 194
 195   exit (1);
 196 }
 197
 198
 199 void
 200 _gfortran_caf_error_stop (int32_t error)
 201 {
 202   fprintf (stderr, "ERROR STOP %d\n", error);
 203   exit (error);
 204 }
 205
 206
 207 void
 208 _gfortran_caf_co_sum (void *a __attribute__ ((unused)),
 209                       caf_vector_t vector[] __attribute__ ((unused)),
 210                       int result_image __attribute__ ((unused)),
 211                       int *stat, char *errmsg __attribute__ ((unused)),
 212                       int errmsg_len __attribute__ ((unused)))
 213 {
 214   if (stat)
 215     stat = 0;
 216 }
 217
 218 void
 219 _gfortran_caf_co_min (void *a __attribute__ ((unused)),
 220                       caf_vector_t vector[] __attribute__ ((unused)),
 221                       int result_image __attribute__ ((unused)),
 222                       int *stat, char *errmsg __attribute__ ((unused)),
 223                       int src_len __attribute__ ((unused)),
 224                       int errmsg_len __attribute__ ((unused)))
 225 {
 226   if (stat)
 227     stat = 0;
 228 }
 229
 230 void
 231 _gfortran_caf_co_max (void *a __attribute__ ((unused)),
 232                       caf_vector_t vector[] __attribute__ ((unused)),
 233                       int result_image __attribute__ ((unused)),
 234                       int *stat, char *errmsg __attribute__ ((unused)),
 235                       int src_len __attribute__ ((unused)),
 236                       int errmsg_len __attribute__ ((unused)))
 237 {
 238   if (stat)
 239     stat = 0;
 240 }