libgfortran/caf/single.c

   1 /* Single-image implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2013 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 /* Single-image implementation of the CAF library.
  36    Note: For performance reasons -fcoarry=single should be used
  37    rather than this library.  */
  38
  39 /* Global variables.  */
  40 caf_static_t *caf_static_list = NULL;
  41
  42
  43 /* Keep in sync with mpi.c.  */
  44 static void
  45 caf_runtime_error (const char *message, ...)
  46 {
  47   va_list ap;
  48   fprintf (stderr, "Fortran runtime error: ");
  49   va_start (ap, message);
  50   vfprintf (stderr, message, ap);
  51   va_end (ap);
  52   fprintf (stderr, "\n");
  53
  54   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
  55   exit (EXIT_FAILURE);
  56 }
  57
  58 void
  59 _gfortran_caf_init (int *argc __attribute__ ((unused)),
  60                     char ***argv __attribute__ ((unused)),
  61                     int *this_image, int *num_images)
  62 {
  63   *this_image = 1;
  64   *num_images = 1;
  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[0]);
  75       free (caf_static_list->token);
  76       free (caf_static_list);
  77       caf_static_list = tmp;
  78     }
  79 }
  80
  81
  82 void *
  83 _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
  84                         int *stat, char *errmsg, int errmsg_len)
  85 {
  86   void *local;
  87
  88   local = malloc (size);
  89   *token = malloc (sizeof (void*) * 1);
  90   (*token)[0] = local;
  91
  92   if (unlikely (local == NULL || token == NULL))
  93     {
  94       const char msg[] = "Failed to allocate coarray";
  95       if (stat)
  96         {
  97           *stat = 1;
  98           if (errmsg_len > 0)
  99             {
 100               int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 101                                                           : (int) sizeof (msg);
 102               memcpy (errmsg, msg, len);
 103               if (errmsg_len > len)
 104                 memset (&errmsg[len], ' ', errmsg_len-len);
 105             }
 106           return NULL;
 107         }
 108       else
 109           caf_runtime_error (msg);
 110     }
 111
 112   if (stat)
 113     *stat = 0;
 114
 115   if (type == CAF_REGTYPE_COARRAY_STATIC)
 116     {
 117       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 118       tmp->prev  = caf_static_list;
 119       tmp->token = *token;
 120       caf_static_list = tmp;
 121     }
 122   return local;
 123 }
 124
 125
 126 void
 127 _gfortran_caf_deregister (void ***token, int *stat,
 128                           char *errmsg __attribute__ ((unused)),
 129                           int errmsg_len __attribute__ ((unused)))
 130 {
 131   free ((*token)[0]);
 132   free (*token);
 133
 134   if (stat)
 135     *stat = 0;
 136 }
 137
 138
 139 void
 140 _gfortran_caf_sync_all (int *stat,
 141                         char *errmsg __attribute__ ((unused)),
 142                         int errmsg_len __attribute__ ((unused)))
 143 {
 144   if (stat)
 145     *stat = 0;
 146 }
 147
 148
 149 void
 150 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
 151                            int images[] __attribute__ ((unused)),
 152                            int *stat,
 153                            char *errmsg __attribute__ ((unused)),
 154                            int errmsg_len __attribute__ ((unused)))
 155 {
 156 #ifdef GFC_CAF_CHECK
 157   int i;
 158
 159   for (i = 0; i < count; i++)
 160     if (images[i] != 1)
 161       {
 162         fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 163                  "IMAGES", images[i]);
 164         exit (EXIT_FAILURE);
 165       }
 166 #endif
 167
 168   if (stat)
 169     *stat = 0;
 170 }
 171
 172
 173 void
 174 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 175 {
 176   fputs ("ERROR STOP ", stderr);
 177   while (len--)
 178     fputc (*(string++), stderr);
 179   fputs ("\n", stderr);
 180
 181   exit (1);
 182 }
 183
 184
 185 void
 186 _gfortran_caf_error_stop (int32_t error)
 187 {
 188   fprintf (stderr, "ERROR STOP %d\n", error);
 189   exit (error);
 190 }