libgfortran/caf/single.c

   1 /* Single-image implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2015 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 #include <assert.h>
  32
  33 /* Define GFC_CAF_CHECK to enable run-time checking.  */
  34 /* #define GFC_CAF_CHECK  1  */
  35
  36 typedef void* single_token_t;
  37 #define TOKEN(X) ((single_token_t) (X))
  38
  39 /* Single-image implementation of the CAF library.
  40    Note: For performance reasons -fcoarry=single should be used
  41    rather than this library.  */
  42
  43 /* Global variables.  */
  44 caf_static_t *caf_static_list = NULL;
  45
  46
  47 /* Keep in sync with mpi.c.  */
  48 static void
  49 caf_runtime_error (const char *message, ...)
  50 {
  51   va_list ap;
  52   fprintf (stderr, "Fortran runtime error: ");
  53   va_start (ap, message);
  54   vfprintf (stderr, message, ap);
  55   va_end (ap);
  56   fprintf (stderr, "\n");
  57
  58   /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
  59   exit (EXIT_FAILURE);
  60 }
  61
  62 void
  63 _gfortran_caf_init (int *argc __attribute__ ((unused)),
  64                     char ***argv __attribute__ ((unused)))
  65 {
  66 }
  67
  68
  69 void
  70 _gfortran_caf_finalize (void)
  71 {
  72   while (caf_static_list != NULL)
  73     {
  74       caf_static_t *tmp = caf_static_list->prev;
  75       free (caf_static_list->token);
  76       free (caf_static_list);
  77       caf_static_list = tmp;
  78     }
  79 }
  80
  81
  82 int
  83 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
  84 {
  85   return 1;
  86 }
  87
  88
  89 int
  90 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
  91                           int failed __attribute__ ((unused)))
  92 {
  93   return 1;
  94 }
  95
  96
  97 void *
  98 _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
  99                         int *stat, char *errmsg, int errmsg_len)
 100 {
 101   void *local;
 102
 103   if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
 104       || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
 105       || type == CAF_REGTYPE_EVENT_ALLOC)
 106     local = calloc (size, sizeof (bool));
 107   else
 108     local = malloc (size);
 109   *token = malloc (sizeof (single_token_t));
 110
 111   if (unlikely (local == NULL || token == NULL))
 112     {
 113       const char msg[] = "Failed to allocate coarray";
 114       if (stat)
 115         {
 116           *stat = 1;
 117           if (errmsg_len > 0)
 118             {
 119               int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 120                                                           : (int) sizeof (msg);
 121               memcpy (errmsg, msg, len);
 122               if (errmsg_len > len)
 123                 memset (&errmsg[len], ' ', errmsg_len-len);
 124             }
 125           return NULL;
 126         }
 127       else
 128           caf_runtime_error (msg);
 129     }
 130
 131   *token = local;
 132
 133   if (stat)
 134     *stat = 0;
 135
 136   if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
 137       || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
 138       || type == CAF_REGTYPE_EVENT_ALLOC)
 139     {
 140       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 141       tmp->prev  = caf_static_list;
 142       tmp->token = *token;
 143       caf_static_list = tmp;
 144     }
 145   return local;
 146 }
 147
 148
 149 void
 150 _gfortran_caf_deregister (caf_token_t *token, int *stat,
 151                           char *errmsg __attribute__ ((unused)),
 152                           int errmsg_len __attribute__ ((unused)))
 153 {
 154   free (TOKEN(*token));
 155
 156   if (stat)
 157     *stat = 0;
 158 }
 159
 160
 161 void
 162 _gfortran_caf_sync_all (int *stat,
 163                         char *errmsg __attribute__ ((unused)),
 164                         int errmsg_len __attribute__ ((unused)))
 165 {
 166   __asm__ __volatile__ ("":::"memory");
 167   if (stat)
 168     *stat = 0;
 169 }
 170
 171
 172 void
 173 _gfortran_caf_sync_memory (int *stat,
 174                            char *errmsg __attribute__ ((unused)),
 175                            int errmsg_len __attribute__ ((unused)))
 176 {
 177   __asm__ __volatile__ ("":::"memory");
 178   if (stat)
 179     *stat = 0;
 180 }
 181
 182
 183 void
 184 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
 185                            int images[] __attribute__ ((unused)),
 186                            int *stat,
 187                            char *errmsg __attribute__ ((unused)),
 188                            int errmsg_len __attribute__ ((unused)))
 189 {
 190 #ifdef GFC_CAF_CHECK
 191   int i;
 192
 193   for (i = 0; i < count; i++)
 194     if (images[i] != 1)
 195       {
 196         fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 197                  "IMAGES", images[i]);
 198         exit (EXIT_FAILURE);
 199       }
 200 #endif
 201
 202   __asm__ __volatile__ ("":::"memory");
 203   if (stat)
 204     *stat = 0;
 205 }
 206
 207
 208 void
 209 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 210 {
 211   fputs ("ERROR STOP ", stderr);
 212   while (len--)
 213     fputc (*(string++), stderr);
 214   fputs ("\n", stderr);
 215
 216   exit (1);
 217 }
 218
 219
 220 void
 221 _gfortran_caf_error_stop (int32_t error)
 222 {
 223   fprintf (stderr, "ERROR STOP %d\n", error);
 224   exit (error);
 225 }
 226
 227
 228 void
 229 _gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
 230                             int source_image __attribute__ ((unused)),
 231                             int *stat, char *errmsg __attribute__ ((unused)),
 232                             int errmsg_len __attribute__ ((unused)))
 233 {
 234   if (stat)
 235     *stat = 0;
 236 }
 237
 238 void
 239 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
 240                       int result_image __attribute__ ((unused)),
 241                       int *stat, char *errmsg __attribute__ ((unused)),
 242                       int errmsg_len __attribute__ ((unused)))
 243 {
 244   if (stat)
 245     *stat = 0;
 246 }
 247
 248 void
 249 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
 250                       int result_image __attribute__ ((unused)),
 251                       int *stat, char *errmsg __attribute__ ((unused)),
 252                       int a_len __attribute__ ((unused)),
 253                       int errmsg_len __attribute__ ((unused)))
 254 {
 255   if (stat)
 256     *stat = 0;
 257 }
 258
 259 void
 260 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
 261                       int result_image __attribute__ ((unused)),
 262                       int *stat, char *errmsg __attribute__ ((unused)),
 263                       int a_len __attribute__ ((unused)),
 264                       int errmsg_len __attribute__ ((unused)))
 265 {
 266   if (stat)
 267     *stat = 0;
 268 }
 269
 270
 271 void
 272 _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
 273                         void * (*opr) (void *, void *)
 274                                __attribute__ ((unused)),
 275                         int opr_flags __attribute__ ((unused)),
 276                         int result_image __attribute__ ((unused)),
 277                         int *stat, char *errmsg __attribute__ ((unused)),
 278                         int a_len __attribute__ ((unused)),
 279                         int errmsg_len __attribute__ ((unused)))
 280  {
 281    if (stat)
 282      *stat = 0;
 283  }
 284
 285
 286 static void
 287 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
 288                          unsigned char *src)
 289 {
 290   size_t i, n;
 291   n = dst_size/4 > src_size ? src_size : dst_size/4;
 292   for (i = 0; i < n; ++i)
 293     dst[i] = (int32_t) src[i];
 294   for (; i < dst_size/4; ++i)
 295     dst[i] = (int32_t) ' ';
 296 }
 297
 298
 299 static void
 300 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
 301                          uint32_t *src)
 302 {
 303   size_t i, n;
 304   n = dst_size > src_size/4 ? src_size/4 : dst_size;
 305   for (i = 0; i < n; ++i)
 306     dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
 307   if (dst_size > n)
 308     memset(&dst[n], ' ', dst_size - n);
 309 }
 310
 311
 312 static void
 313 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
 314               int src_kind)
 315 {
 316 #ifdef HAVE_GFC_INTEGER_16
 317   typedef __int128 int128t;
 318 #else
 319   typedef int64_t int128t;
 320 #endif
 321
 322 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
 323   typedef long double real128t;
 324   typedef _Complex long double complex128t;
 325 #elif defined(HAVE_GFC_REAL_16)
 326   typedef _Complex float __attribute__((mode(TC))) __complex128;
 327   typedef __float128 real128t;
 328   typedef __complex128 complex128t;
 329 #elif defined(HAVE_GFC_REAL_10)
 330   typedef long double real128t;
 331   typedef long double complex128t;
 332 #else
 333   typedef double real128t;
 334   typedef _Complex double complex128t;
 335 #endif
 336
 337   int128t int_val = 0;
 338   real128t real_val = 0;
 339   complex128t cmpx_val = 0;
 340
 341   switch (src_type)
 342     {
 343     case BT_INTEGER:
 344       if (src_kind == 1)
 345         int_val = *(int8_t*) src;
 346       else if (src_kind == 2)
 347         int_val = *(int16_t*) src;
 348       else if (src_kind == 4)
 349         int_val = *(int32_t*) src;
 350       else if (src_kind == 8)
 351         int_val = *(int64_t*) src;
 352 #ifdef HAVE_GFC_INTEGER_16
 353       else if (src_kind == 16)
 354         int_val = *(int128t*) src;
 355 #endif
 356       else
 357         goto error;
 358       break;
 359     case BT_REAL:
 360       if (src_kind == 4)
 361         real_val = *(float*) src;
 362       else if (src_kind == 8)
 363         real_val = *(double*) src;
 364 #ifdef HAVE_GFC_REAL_10
 365       else if (src_kind == 10)
 366         real_val = *(long double*) src;
 367 #endif
 368 #ifdef HAVE_GFC_REAL_16
 369       else if (src_kind == 16)
 370         real_val = *(real128t*) src;
 371 #endif
 372       else
 373         goto error;
 374       break;
 375     case BT_COMPLEX:
 376       if (src_kind == 4)
 377         cmpx_val = *(_Complex float*) src;
 378       else if (src_kind == 8)
 379         cmpx_val = *(_Complex double*) src;
 380 #ifdef HAVE_GFC_REAL_10
 381       else if (src_kind == 10)
 382         cmpx_val = *(_Complex long double*) src;
 383 #endif
 384 #ifdef HAVE_GFC_REAL_16
 385       else if (src_kind == 16)
 386         cmpx_val = *(complex128t*) src;
 387 #endif
 388       else
 389         goto error;
 390       break;
 391     default:
 392       goto error;
 393     }
 394
 395   switch (dst_type)
 396     {
 397     case BT_INTEGER:
 398       if (src_type == BT_INTEGER)
 399         {
 400           if (dst_kind == 1)
 401             *(int8_t*) dst = (int8_t) int_val;
 402           else if (dst_kind == 2)
 403             *(int16_t*) dst = (int16_t) int_val;
 404           else if (dst_kind == 4)
 405             *(int32_t*) dst = (int32_t) int_val;
 406           else if (dst_kind == 8)
 407             *(int64_t*) dst = (int64_t) int_val;
 408 #ifdef HAVE_GFC_INTEGER_16
 409           else if (dst_kind == 16)
 410             *(int128t*) dst = (int128t) int_val;
 411 #endif
 412           else
 413             goto error;
 414         }
 415       else if (src_type == BT_REAL)
 416         {
 417           if (dst_kind == 1)
 418             *(int8_t*) dst = (int8_t) real_val;
 419           else if (dst_kind == 2)
 420             *(int16_t*) dst = (int16_t) real_val;
 421           else if (dst_kind == 4)
 422             *(int32_t*) dst = (int32_t) real_val;
 423           else if (dst_kind == 8)
 424             *(int64_t*) dst = (int64_t) real_val;
 425 #ifdef HAVE_GFC_INTEGER_16
 426           else if (dst_kind == 16)
 427             *(int128t*) dst = (int128t) real_val;
 428 #endif
 429           else
 430             goto error;
 431         }
 432       else if (src_type == BT_COMPLEX)
 433         {
 434           if (dst_kind == 1)
 435             *(int8_t*) dst = (int8_t) cmpx_val;
 436           else if (dst_kind == 2)
 437             *(int16_t*) dst = (int16_t) cmpx_val;
 438           else if (dst_kind == 4)
 439             *(int32_t*) dst = (int32_t) cmpx_val;
 440           else if (dst_kind == 8)
 441             *(int64_t*) dst = (int64_t) cmpx_val;
 442 #ifdef HAVE_GFC_INTEGER_16
 443           else if (dst_kind == 16)
 444             *(int128t*) dst = (int128t) cmpx_val;
 445 #endif
 446           else
 447             goto error;
 448         }
 449       else
 450         goto error;
 451       break;
 452     case BT_REAL:
 453       if (src_type == BT_INTEGER)
 454         {
 455           if (dst_kind == 4)
 456             *(float*) dst = (float) int_val;
 457           else if (dst_kind == 8)
 458             *(double*) dst = (double) int_val;
 459 #ifdef HAVE_GFC_REAL_10
 460           else if (dst_kind == 10)
 461             *(long double*) dst = (long double) int_val;
 462 #endif
 463 #ifdef HAVE_GFC_REAL_16
 464           else if (dst_kind == 16)
 465             *(real128t*) dst = (real128t) int_val;
 466 #endif
 467           else
 468             goto error;
 469         }
 470       else if (src_type == BT_REAL)
 471         {
 472           if (dst_kind == 4)
 473             *(float*) dst = (float) real_val;
 474           else if (dst_kind == 8)
 475             *(double*) dst = (double) real_val;
 476 #ifdef HAVE_GFC_REAL_10
 477           else if (dst_kind == 10)
 478             *(long double*) dst = (long double) real_val;
 479 #endif
 480 #ifdef HAVE_GFC_REAL_16
 481           else if (dst_kind == 16)
 482             *(real128t*) dst = (real128t) real_val;
 483 #endif
 484           else
 485             goto error;
 486         }
 487       else if (src_type == BT_COMPLEX)
 488         {
 489           if (dst_kind == 4)
 490             *(float*) dst = (float) cmpx_val;
 491           else if (dst_kind == 8)
 492             *(double*) dst = (double) cmpx_val;
 493 #ifdef HAVE_GFC_REAL_10
 494           else if (dst_kind == 10)
 495             *(long double*) dst = (long double) cmpx_val;
 496 #endif
 497 #ifdef HAVE_GFC_REAL_16
 498           else if (dst_kind == 16)
 499             *(real128t*) dst = (real128t) cmpx_val;
 500 #endif
 501           else
 502             goto error;
 503         }
 504       break;
 505     case BT_COMPLEX:
 506       if (src_type == BT_INTEGER)
 507         {
 508           if (dst_kind == 4)
 509             *(_Complex float*) dst = (_Complex float) int_val;
 510           else if (dst_kind == 8)
 511             *(_Complex double*) dst = (_Complex double) int_val;
 512 #ifdef HAVE_GFC_REAL_10
 513           else if (dst_kind == 10)
 514             *(_Complex long double*) dst = (_Complex long double) int_val;
 515 #endif
 516 #ifdef HAVE_GFC_REAL_16
 517           else if (dst_kind == 16)
 518             *(complex128t*) dst = (complex128t) int_val;
 519 #endif
 520           else
 521             goto error;
 522         }
 523       else if (src_type == BT_REAL)
 524         {
 525           if (dst_kind == 4)
 526             *(_Complex float*) dst = (_Complex float) real_val;
 527           else if (dst_kind == 8)
 528             *(_Complex double*) dst = (_Complex double) real_val;
 529 #ifdef HAVE_GFC_REAL_10
 530           else if (dst_kind == 10)
 531             *(_Complex long double*) dst = (_Complex long double) real_val;
 532 #endif
 533 #ifdef HAVE_GFC_REAL_16
 534           else if (dst_kind == 16)
 535             *(complex128t*) dst = (complex128t) real_val;
 536 #endif
 537           else
 538             goto error;
 539         }
 540       else if (src_type == BT_COMPLEX)
 541         {
 542           if (dst_kind == 4)
 543             *(_Complex float*) dst = (_Complex float) cmpx_val;
 544           else if (dst_kind == 8)
 545             *(_Complex double*) dst = (_Complex double) cmpx_val;
 546 #ifdef HAVE_GFC_REAL_10
 547           else if (dst_kind == 10)
 548             *(_Complex long double*) dst = (_Complex long double) cmpx_val;
 549 #endif
 550 #ifdef HAVE_GFC_REAL_16
 551           else if (dst_kind == 16)
 552             *(complex128t*) dst = (complex128t) cmpx_val;
 553 #endif
 554           else
 555             goto error;
 556         }
 557       else
 558         goto error;
 559       break;
 560     default:
 561       goto error;
 562     }
 563
 564 error:
 565   fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
 566            "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
 567   abort();
 568 }
 569
 570
 571 void
 572 _gfortran_caf_get (caf_token_t token, size_t offset,
 573                    int image_index __attribute__ ((unused)),
 574                    gfc_descriptor_t *src,
 575                    caf_vector_t *src_vector __attribute__ ((unused)),
 576                    gfc_descriptor_t *dest, int src_kind, int dst_kind,
 577                    bool may_require_tmp)
 578 {
 579   /* FIXME: Handle vector subscripts.  */
 580   size_t i, k, size;
 581   int j;
 582   int rank = GFC_DESCRIPTOR_RANK (dest);
 583   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 584   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 585
 586   if (rank == 0)
 587     {
 588       void *sr = (void *) ((char *) TOKEN (token) + offset);
 589       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 590           && dst_kind == src_kind)
 591         {
 592           memmove (GFC_DESCRIPTOR_DATA (dest), sr,
 593                    dst_size > src_size ? src_size : dst_size);
 594           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 595             {
 596               if (dst_kind == 1)
 597                 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
 598                         ' ', dst_size - src_size);
 599               else /* dst_kind == 4.  */
 600                 for (i = src_size/4; i < dst_size/4; i++)
 601                   ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
 602             }
 603         }
 604       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 605         assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 606                                  sr);
 607       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 608         assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 609                                  sr);
 610       else
 611         convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
 612                       dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 613       return;
 614     }
 615
 616   size = 1;
 617   for (j = 0; j < rank; j++)
 618     {
 619       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 620       if (dimextent < 0)
 621         dimextent = 0;
 622       size *= dimextent;
 623     }
 624
 625   if (size == 0)
 626     return;
 627
 628   if (may_require_tmp)
 629     {
 630       ptrdiff_t array_offset_sr, array_offset_dst;
 631       void *tmp = malloc (size*src_size);
 632
 633       array_offset_dst = 0;
 634       for (i = 0; i < size; i++)
 635         {
 636           ptrdiff_t array_offset_sr = 0;
 637           ptrdiff_t stride = 1;
 638           ptrdiff_t extent = 1;
 639           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 640             {
 641               array_offset_sr += ((i / (extent*stride))
 642                                   % (src->dim[j]._ubound
 643                                     - src->dim[j].lower_bound + 1))
 644                                  * src->dim[j]._stride;
 645               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 646               stride = src->dim[j]._stride;
 647             }
 648           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 649           void *sr = (void *)((char *) TOKEN (token) + offset
 650                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 651           memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 652           array_offset_dst += src_size;
 653         }
 654
 655       array_offset_sr = 0;
 656       for (i = 0; i < size; i++)
 657         {
 658           ptrdiff_t array_offset_dst = 0;
 659           ptrdiff_t stride = 1;
 660           ptrdiff_t extent = 1;
 661           for (j = 0; j < rank-1; j++)
 662             {
 663               array_offset_dst += ((i / (extent*stride))
 664                                    % (dest->dim[j]._ubound
 665                                       - dest->dim[j].lower_bound + 1))
 666                                   * dest->dim[j]._stride;
 667               extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 668               stride = dest->dim[j]._stride;
 669             }
 670           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 671           void *dst = dest->base_addr
 672                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 673           void *sr = tmp + array_offset_sr;
 674
 675           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 676               && dst_kind == src_kind)
 677             {
 678               memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 679               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 680                   && dst_size > src_size)
 681                 {
 682                   if (dst_kind == 1)
 683                     memset ((void*)(char*) dst + src_size, ' ',
 684                             dst_size-src_size);
 685                   else /* dst_kind == 4.  */
 686                     for (k = src_size/4; k < dst_size/4; k++)
 687                       ((int32_t*) dst)[k] = (int32_t) ' ';
 688                 }
 689             }
 690           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 691             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 692           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 693             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 694           else
 695             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 696                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 697           array_offset_sr += src_size;
 698         }
 699
 700       free (tmp);
 701       return;
 702     }
 703
 704   for (i = 0; i < size; i++)
 705     {
 706       ptrdiff_t array_offset_dst = 0;
 707       ptrdiff_t stride = 1;
 708       ptrdiff_t extent = 1;
 709       for (j = 0; j < rank-1; j++)
 710         {
 711           array_offset_dst += ((i / (extent*stride))
 712                                % (dest->dim[j]._ubound
 713                                   - dest->dim[j].lower_bound + 1))
 714                               * dest->dim[j]._stride;
 715           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 716           stride = dest->dim[j]._stride;
 717         }
 718       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 719       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 720
 721       ptrdiff_t array_offset_sr = 0;
 722       stride = 1;
 723       extent = 1;
 724       for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 725         {
 726           array_offset_sr += ((i / (extent*stride))
 727                                % (src->dim[j]._ubound
 728                                   - src->dim[j].lower_bound + 1))
 729                               * src->dim[j]._stride;
 730           extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 731           stride = src->dim[j]._stride;
 732         }
 733       array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 734       void *sr = (void *)((char *) TOKEN (token) + offset
 735                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 736
 737       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 738           && dst_kind == src_kind)
 739         {
 740           memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 741           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 742             {
 743               if (dst_kind == 1)
 744                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 745               else /* dst_kind == 4.  */
 746                 for (k = src_size/4; k < dst_size/4; k++)
 747                   ((int32_t*) dst)[k] = (int32_t) ' ';
 748             }
 749         }
 750       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 751         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 752       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 753         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 754       else
 755         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 756                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 757     }
 758 }
 759
 760
 761 void
 762 _gfortran_caf_send (caf_token_t token, size_t offset,
 763                     int image_index __attribute__ ((unused)),
 764                     gfc_descriptor_t *dest,
 765                     caf_vector_t *dst_vector __attribute__ ((unused)),
 766                     gfc_descriptor_t *src, int dst_kind, int src_kind,
 767                     bool may_require_tmp)
 768 {
 769   /* FIXME: Handle vector subscripts.  */
 770   size_t i, k, size;
 771   int j;
 772   int rank = GFC_DESCRIPTOR_RANK (dest);
 773   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 774   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 775
 776   if (rank == 0)
 777     {
 778       void *dst = (void *) ((char *) TOKEN (token) + offset);
 779       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 780           && dst_kind == src_kind)
 781         {
 782           memmove (dst, GFC_DESCRIPTOR_DATA (src),
 783                    dst_size > src_size ? src_size : dst_size);
 784           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 785             {
 786               if (dst_kind == 1)
 787                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 788               else /* dst_kind == 4.  */
 789                 for (i = src_size/4; i < dst_size/4; i++)
 790                   ((int32_t*) dst)[i] = (int32_t) ' ';
 791             }
 792         }
 793       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 794         assign_char1_from_char4 (dst_size, src_size, dst,
 795                                  GFC_DESCRIPTOR_DATA (src));
 796       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 797         assign_char4_from_char1 (dst_size, src_size, dst,
 798                                  GFC_DESCRIPTOR_DATA (src));
 799       else
 800         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 801                       GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
 802                       src_kind);
 803       return;
 804     }
 805
 806   size = 1;
 807   for (j = 0; j < rank; j++)
 808     {
 809       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 810       if (dimextent < 0)
 811         dimextent = 0;
 812       size *= dimextent;
 813     }
 814
 815   if (size == 0)
 816     return;
 817
 818   if (may_require_tmp)
 819     {
 820       ptrdiff_t array_offset_sr, array_offset_dst;
 821       void *tmp;
 822
 823       if (GFC_DESCRIPTOR_RANK (src) == 0)
 824         {
 825           tmp = malloc (src_size);
 826           memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
 827         }
 828       else
 829         {
 830           tmp = malloc (size*src_size);
 831           array_offset_dst = 0;
 832           for (i = 0; i < size; i++)
 833             {
 834               ptrdiff_t array_offset_sr = 0;
 835               ptrdiff_t stride = 1;
 836               ptrdiff_t extent = 1;
 837               for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 838                 {
 839                   array_offset_sr += ((i / (extent*stride))
 840                                       % (src->dim[j]._ubound
 841                                          - src->dim[j].lower_bound + 1))
 842                                      * src->dim[j]._stride;
 843                   extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 844                   stride = src->dim[j]._stride;
 845                 }
 846               array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 847               void *sr = (void *) ((char *) src->base_addr
 848                                    + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 849               memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 850               array_offset_dst += src_size;
 851             }
 852         }
 853
 854       array_offset_sr = 0;
 855       for (i = 0; i < size; i++)
 856         {
 857           ptrdiff_t array_offset_dst = 0;
 858           ptrdiff_t stride = 1;
 859           ptrdiff_t extent = 1;
 860           for (j = 0; j < rank-1; j++)
 861             {
 862               array_offset_dst += ((i / (extent*stride))
 863                                    % (dest->dim[j]._ubound
 864                                       - dest->dim[j].lower_bound + 1))
 865                                   * dest->dim[j]._stride;
 866           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 867           stride = dest->dim[j]._stride;
 868             }
 869           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 870           void *dst = (void *)((char *) TOKEN (token) + offset
 871                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 872           void *sr = tmp + array_offset_sr;
 873           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 874               && dst_kind == src_kind)
 875             {
 876               memmove (dst, sr,
 877                        dst_size > src_size ? src_size : dst_size);
 878               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 879                   && dst_size > src_size)
 880                 {
 881                   if (dst_kind == 1)
 882                     memset ((void*)(char*) dst + src_size, ' ',
 883                             dst_size-src_size);
 884                   else /* dst_kind == 4.  */
 885                     for (k = src_size/4; k < dst_size/4; k++)
 886                       ((int32_t*) dst)[k] = (int32_t) ' ';
 887                 }
 888             }
 889           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 890             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 891           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 892             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 893           else
 894             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 895                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 896           if (GFC_DESCRIPTOR_RANK (src))
 897             array_offset_sr += src_size;
 898         }
 899       free (tmp);
 900       return;
 901     }
 902
 903   for (i = 0; i < size; i++)
 904     {
 905       ptrdiff_t array_offset_dst = 0;
 906       ptrdiff_t stride = 1;
 907       ptrdiff_t extent = 1;
 908       for (j = 0; j < rank-1; j++)
 909         {
 910           array_offset_dst += ((i / (extent*stride))
 911                                % (dest->dim[j]._ubound
 912                                   - dest->dim[j].lower_bound + 1))
 913                               * dest->dim[j]._stride;
 914           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 915           stride = dest->dim[j]._stride;
 916         }
 917       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 918       void *dst = (void *)((char *) TOKEN (token) + offset
 919                            + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 920       void *sr;
 921       if (GFC_DESCRIPTOR_RANK (src) != 0)
 922         {
 923           ptrdiff_t array_offset_sr = 0;
 924           stride = 1;
 925           extent = 1;
 926           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 927             {
 928               array_offset_sr += ((i / (extent*stride))
 929                                   % (src->dim[j]._ubound
 930                                      - src->dim[j].lower_bound + 1))
 931                                  * src->dim[j]._stride;
 932               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 933               stride = src->dim[j]._stride;
 934             }
 935           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 936           sr = (void *)((char *) src->base_addr
 937                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 938         }
 939       else
 940         sr = src->base_addr;
 941
 942       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 943           && dst_kind == src_kind)
 944         {
 945           memmove (dst, sr,
 946                    dst_size > src_size ? src_size : dst_size);
 947           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 948             {
 949               if (dst_kind == 1)
 950                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 951               else /* dst_kind == 4.  */
 952                 for (k = src_size/4; k < dst_size/4; k++)
 953                   ((int32_t*) dst)[k] = (int32_t) ' ';
 954             }
 955         }
 956       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 957         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 958       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 959         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 960       else
 961         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 962                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 963     }
 964 }
 965
 966
 967 void
 968 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 969                        int dst_image_index, gfc_descriptor_t *dest,
 970                        caf_vector_t *dst_vector, caf_token_t src_token,
 971                        size_t src_offset,
 972                        int src_image_index __attribute__ ((unused)),
 973                        gfc_descriptor_t *src,
 974                        caf_vector_t *src_vector __attribute__ ((unused)),
 975                        int dst_kind, int src_kind, bool may_require_tmp)
 976 {
 977   /* FIXME: Handle vector subscript of 'src_vector'.  */
 978   /* For a single image, src->base_addr should be the same as src_token + offset
 979      but to play save, we do it properly.  */
 980   void *src_base = GFC_DESCRIPTOR_DATA (src);
 981   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
 982   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
 983                       src, dst_kind, src_kind, may_require_tmp);
 984   GFC_DESCRIPTOR_DATA (src) = src_base;
 985 }
 986
 987
 988 void
 989 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
 990                              int image_index __attribute__ ((unused)),
 991                              void *value, int *stat,
 992                              int type __attribute__ ((unused)), int kind)
 993 {
 994   assert(kind == 4);
 995
 996   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 997
 998   __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 999
1000   if (stat)
1001     *stat = 0;
1002 }
1003
1004 void
1005 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
1006                           int image_index __attribute__ ((unused)),
1007                           void *value, int *stat,
1008                           int type __attribute__ ((unused)), int kind)
1009 {
1010   assert(kind == 4);
1011
1012   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1013
1014   __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
1015
1016   if (stat)
1017     *stat = 0;
1018 }
1019
1020
1021 void
1022 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
1023                           int image_index __attribute__ ((unused)),
1024                           void *old, void *compare, void *new_val, int *stat,
1025                           int type __attribute__ ((unused)), int kind)
1026 {
1027   assert(kind == 4);
1028
1029   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1030
1031   *(uint32_t *) old = *(uint32_t *) compare;
1032   (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
1033                                       *(uint32_t *) new_val, false,
1034                                       __ATOMIC_RELAXED, __ATOMIC_RELAXED);
1035   if (stat)
1036     *stat = 0;
1037 }
1038
1039
1040 void
1041 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
1042                          int image_index __attribute__ ((unused)),
1043                          void *value, void *old, int *stat,
1044                          int type __attribute__ ((unused)), int kind)
1045 {
1046   assert(kind == 4);
1047
1048   uint32_t res;
1049   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1050
1051   switch (op)
1052     {
1053     case GFC_CAF_ATOMIC_ADD:
1054       res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1055       break;
1056     case GFC_CAF_ATOMIC_AND:
1057       res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1058       break;
1059     case GFC_CAF_ATOMIC_OR:
1060       res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1061       break;
1062     case GFC_CAF_ATOMIC_XOR:
1063       res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1064       break;
1065     default:
1066       __builtin_unreachable();
1067     }
1068
1069   if (old)
1070     *(uint32_t *) old = res;
1071
1072   if (stat)
1073     *stat = 0;
1074 }
1075
1076 void
1077 _gfortran_caf_event_post (caf_token_t token, size_t index,
1078                           int image_index __attribute__ ((unused)),
1079                           int *stat, char *errmsg __attribute__ ((unused)),
1080                           int errmsg_len __attribute__ ((unused)))
1081 {
1082   uint32_t value = 1;
1083   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1084   __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1085
1086   if(stat)
1087     *stat = 0;
1088 }
1089
1090 void
1091 _gfortran_caf_event_wait (caf_token_t token, size_t index,
1092                           int until_count, int *stat,
1093                           char *errmsg __attribute__ ((unused)),
1094                           int errmsg_len __attribute__ ((unused)))
1095 {
1096   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1097   uint32_t value = (uint32_t)-until_count;
1098    __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1099
1100    if(stat)
1101     *stat = 0;
1102 }
1103
1104 void
1105 _gfortran_caf_event_query (caf_token_t token, size_t index,
1106                            int image_index __attribute__ ((unused)),
1107                            int *count, int *stat)
1108 {
1109   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1110   __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
1111
1112   if(stat)
1113     *stat = 0;
1114 }
1115
1116 void
1117 _gfortran_caf_lock (caf_token_t token, size_t index,
1118                     int image_index __attribute__ ((unused)),
1119                     int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
1120 {
1121   const char *msg = "Already locked";
1122   bool *lock = &((bool *) TOKEN (token))[index];
1123
1124   if (!*lock)
1125     {
1126       *lock = true;
1127       if (aquired_lock)
1128         *aquired_lock = (int) true;
1129       if (stat)
1130         *stat = 0;
1131       return;
1132     }
1133
1134   if (aquired_lock)
1135     {
1136       *aquired_lock = (int) false;
1137       if (stat)
1138         *stat = 0;
1139     return;
1140     }
1141
1142
1143   if (stat)
1144     {
1145       *stat = 1;
1146       if (errmsg_len > 0)
1147         {
1148           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1149                                                       : (int) sizeof (msg);
1150           memcpy (errmsg, msg, len);
1151           if (errmsg_len > len)
1152             memset (&errmsg[len], ' ', errmsg_len-len);
1153         }
1154       return;
1155     }
1156   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1157 }
1158
1159
1160 void
1161 _gfortran_caf_unlock (caf_token_t token, size_t index,
1162                       int image_index __attribute__ ((unused)),
1163                       int *stat, char *errmsg, int errmsg_len)
1164 {
1165   const char *msg = "Variable is not locked";
1166   bool *lock = &((bool *) TOKEN (token))[index];
1167
1168   if (*lock)
1169     {
1170       *lock = false;
1171       if (stat)
1172         *stat = 0;
1173       return;
1174     }
1175
1176   if (stat)
1177     {
1178       *stat = 1;
1179       if (errmsg_len > 0)
1180         {
1181           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1182                                                       : (int) sizeof (msg);
1183           memcpy (errmsg, msg, len);
1184           if (errmsg_len > len)
1185             memset (&errmsg[len], ' ', errmsg_len-len);
1186         }
1187       return;
1188     }
1189   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1190 }