libgfortran/caf/single.c

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