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, int *stat)
 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   if (stat)
 585     *stat = 1;
 586   else
 587     abort ();
 588 }
 589
 590
 591 void
 592 _gfortran_caf_get (caf_token_t token, size_t offset,
 593                    int image_index __attribute__ ((unused)),
 594                    gfc_descriptor_t *src,
 595                    caf_vector_t *src_vector __attribute__ ((unused)),
 596                    gfc_descriptor_t *dest, int src_kind, int dst_kind,
 597                    bool may_require_tmp, int *stat)
 598 {
 599   /* FIXME: Handle vector subscripts.  */
 600   size_t i, k, size;
 601   int j;
 602   int rank = GFC_DESCRIPTOR_RANK (dest);
 603   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 604   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 605
 606   if (stat)
 607     *stat = 0;
 608
 609   if (rank == 0)
 610     {
 611       void *sr = (void *) ((char *) TOKEN (token) + offset);
 612       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 613           && dst_kind == src_kind)
 614         {
 615           memmove (GFC_DESCRIPTOR_DATA (dest), sr,
 616                    dst_size > src_size ? src_size : dst_size);
 617           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 618             {
 619               if (dst_kind == 1)
 620                 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
 621                         ' ', dst_size - src_size);
 622               else /* dst_kind == 4.  */
 623                 for (i = src_size/4; i < dst_size/4; i++)
 624                   ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
 625             }
 626         }
 627       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 628         assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 629                                  sr);
 630       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 631         assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 632                                  sr);
 633       else
 634         convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
 635                       dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
 636       return;
 637     }
 638
 639   size = 1;
 640   for (j = 0; j < rank; j++)
 641     {
 642       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 643       if (dimextent < 0)
 644         dimextent = 0;
 645       size *= dimextent;
 646     }
 647
 648   if (size == 0)
 649     return;
 650
 651   if (may_require_tmp)
 652     {
 653       ptrdiff_t array_offset_sr, array_offset_dst;
 654       void *tmp = malloc (size*src_size);
 655
 656       array_offset_dst = 0;
 657       for (i = 0; i < size; i++)
 658         {
 659           ptrdiff_t array_offset_sr = 0;
 660           ptrdiff_t stride = 1;
 661           ptrdiff_t extent = 1;
 662           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 663             {
 664               array_offset_sr += ((i / (extent*stride))
 665                                   % (src->dim[j]._ubound
 666                                     - src->dim[j].lower_bound + 1))
 667                                  * src->dim[j]._stride;
 668               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 669               stride = src->dim[j]._stride;
 670             }
 671           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 672           void *sr = (void *)((char *) TOKEN (token) + offset
 673                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 674           memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 675           array_offset_dst += src_size;
 676         }
 677
 678       array_offset_sr = 0;
 679       for (i = 0; i < size; i++)
 680         {
 681           ptrdiff_t array_offset_dst = 0;
 682           ptrdiff_t stride = 1;
 683           ptrdiff_t extent = 1;
 684           for (j = 0; j < rank-1; j++)
 685             {
 686               array_offset_dst += ((i / (extent*stride))
 687                                    % (dest->dim[j]._ubound
 688                                       - dest->dim[j].lower_bound + 1))
 689                                   * dest->dim[j]._stride;
 690               extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 691               stride = dest->dim[j]._stride;
 692             }
 693           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 694           void *dst = dest->base_addr
 695                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 696           void *sr = tmp + array_offset_sr;
 697
 698           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 699               && dst_kind == src_kind)
 700             {
 701               memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 702               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 703                   && dst_size > src_size)
 704                 {
 705                   if (dst_kind == 1)
 706                     memset ((void*)(char*) dst + src_size, ' ',
 707                             dst_size-src_size);
 708                   else /* dst_kind == 4.  */
 709                     for (k = src_size/4; k < dst_size/4; k++)
 710                       ((int32_t*) dst)[k] = (int32_t) ' ';
 711                 }
 712             }
 713           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 714             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 715           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 716             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 717           else
 718             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 719                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
 720           array_offset_sr += src_size;
 721         }
 722
 723       free (tmp);
 724       return;
 725     }
 726
 727   for (i = 0; i < size; i++)
 728     {
 729       ptrdiff_t array_offset_dst = 0;
 730       ptrdiff_t stride = 1;
 731       ptrdiff_t extent = 1;
 732       for (j = 0; j < rank-1; j++)
 733         {
 734           array_offset_dst += ((i / (extent*stride))
 735                                % (dest->dim[j]._ubound
 736                                   - dest->dim[j].lower_bound + 1))
 737                               * dest->dim[j]._stride;
 738           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 739           stride = dest->dim[j]._stride;
 740         }
 741       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 742       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 743
 744       ptrdiff_t array_offset_sr = 0;
 745       stride = 1;
 746       extent = 1;
 747       for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 748         {
 749           array_offset_sr += ((i / (extent*stride))
 750                                % (src->dim[j]._ubound
 751                                   - src->dim[j].lower_bound + 1))
 752                               * src->dim[j]._stride;
 753           extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 754           stride = src->dim[j]._stride;
 755         }
 756       array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 757       void *sr = (void *)((char *) TOKEN (token) + offset
 758                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 759
 760       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 761           && dst_kind == src_kind)
 762         {
 763           memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 764           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 765             {
 766               if (dst_kind == 1)
 767                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 768               else /* dst_kind == 4.  */
 769                 for (k = src_size/4; k < dst_size/4; k++)
 770                   ((int32_t*) dst)[k] = (int32_t) ' ';
 771             }
 772         }
 773       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 774         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 775       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 776         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 777       else
 778         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 779                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
 780     }
 781 }
 782
 783
 784 void
 785 _gfortran_caf_send (caf_token_t token, size_t offset,
 786                     int image_index __attribute__ ((unused)),
 787                     gfc_descriptor_t *dest,
 788                     caf_vector_t *dst_vector __attribute__ ((unused)),
 789                     gfc_descriptor_t *src, int dst_kind, int src_kind,
 790                     bool may_require_tmp, int *stat)
 791 {
 792   /* FIXME: Handle vector subscripts.  */
 793   size_t i, k, size;
 794   int j;
 795   int rank = GFC_DESCRIPTOR_RANK (dest);
 796   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 797   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 798
 799   if (stat)
 800     *stat = 0;
 801
 802   if (rank == 0)
 803     {
 804       void *dst = (void *) ((char *) TOKEN (token) + offset);
 805       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 806           && dst_kind == src_kind)
 807         {
 808           memmove (dst, GFC_DESCRIPTOR_DATA (src),
 809                    dst_size > src_size ? src_size : dst_size);
 810           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 811             {
 812               if (dst_kind == 1)
 813                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 814               else /* dst_kind == 4.  */
 815                 for (i = src_size/4; i < dst_size/4; i++)
 816                   ((int32_t*) dst)[i] = (int32_t) ' ';
 817             }
 818         }
 819       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 820         assign_char1_from_char4 (dst_size, src_size, dst,
 821                                  GFC_DESCRIPTOR_DATA (src));
 822       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 823         assign_char4_from_char1 (dst_size, src_size, dst,
 824                                  GFC_DESCRIPTOR_DATA (src));
 825       else
 826         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 827                       GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
 828                       src_kind, stat);
 829       return;
 830     }
 831
 832   size = 1;
 833   for (j = 0; j < rank; j++)
 834     {
 835       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 836       if (dimextent < 0)
 837         dimextent = 0;
 838       size *= dimextent;
 839     }
 840
 841   if (size == 0)
 842     return;
 843
 844   if (may_require_tmp)
 845     {
 846       ptrdiff_t array_offset_sr, array_offset_dst;
 847       void *tmp;
 848
 849       if (GFC_DESCRIPTOR_RANK (src) == 0)
 850         {
 851           tmp = malloc (src_size);
 852           memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
 853         }
 854       else
 855         {
 856           tmp = malloc (size*src_size);
 857           array_offset_dst = 0;
 858           for (i = 0; i < size; i++)
 859             {
 860               ptrdiff_t array_offset_sr = 0;
 861               ptrdiff_t stride = 1;
 862               ptrdiff_t extent = 1;
 863               for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 864                 {
 865                   array_offset_sr += ((i / (extent*stride))
 866                                       % (src->dim[j]._ubound
 867                                          - src->dim[j].lower_bound + 1))
 868                                      * src->dim[j]._stride;
 869                   extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 870                   stride = src->dim[j]._stride;
 871                 }
 872               array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 873               void *sr = (void *) ((char *) src->base_addr
 874                                    + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 875               memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 876               array_offset_dst += src_size;
 877             }
 878         }
 879
 880       array_offset_sr = 0;
 881       for (i = 0; i < size; i++)
 882         {
 883           ptrdiff_t array_offset_dst = 0;
 884           ptrdiff_t stride = 1;
 885           ptrdiff_t extent = 1;
 886           for (j = 0; j < rank-1; j++)
 887             {
 888               array_offset_dst += ((i / (extent*stride))
 889                                    % (dest->dim[j]._ubound
 890                                       - dest->dim[j].lower_bound + 1))
 891                                   * dest->dim[j]._stride;
 892           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 893           stride = dest->dim[j]._stride;
 894             }
 895           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 896           void *dst = (void *)((char *) TOKEN (token) + offset
 897                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 898           void *sr = tmp + array_offset_sr;
 899           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 900               && dst_kind == src_kind)
 901             {
 902               memmove (dst, sr,
 903                        dst_size > src_size ? src_size : dst_size);
 904               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 905                   && dst_size > src_size)
 906                 {
 907                   if (dst_kind == 1)
 908                     memset ((void*)(char*) dst + src_size, ' ',
 909                             dst_size-src_size);
 910                   else /* dst_kind == 4.  */
 911                     for (k = src_size/4; k < dst_size/4; k++)
 912                       ((int32_t*) dst)[k] = (int32_t) ' ';
 913                 }
 914             }
 915           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 916             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 917           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 918             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 919           else
 920             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 921                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
 922           if (GFC_DESCRIPTOR_RANK (src))
 923             array_offset_sr += src_size;
 924         }
 925       free (tmp);
 926       return;
 927     }
 928
 929   for (i = 0; i < size; i++)
 930     {
 931       ptrdiff_t array_offset_dst = 0;
 932       ptrdiff_t stride = 1;
 933       ptrdiff_t extent = 1;
 934       for (j = 0; j < rank-1; j++)
 935         {
 936           array_offset_dst += ((i / (extent*stride))
 937                                % (dest->dim[j]._ubound
 938                                   - dest->dim[j].lower_bound + 1))
 939                               * dest->dim[j]._stride;
 940           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 941           stride = dest->dim[j]._stride;
 942         }
 943       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 944       void *dst = (void *)((char *) TOKEN (token) + offset
 945                            + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 946       void *sr;
 947       if (GFC_DESCRIPTOR_RANK (src) != 0)
 948         {
 949           ptrdiff_t array_offset_sr = 0;
 950           stride = 1;
 951           extent = 1;
 952           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 953             {
 954               array_offset_sr += ((i / (extent*stride))
 955                                   % (src->dim[j]._ubound
 956                                      - src->dim[j].lower_bound + 1))
 957                                  * src->dim[j]._stride;
 958               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 959               stride = src->dim[j]._stride;
 960             }
 961           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 962           sr = (void *)((char *) src->base_addr
 963                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 964         }
 965       else
 966         sr = src->base_addr;
 967
 968       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 969           && dst_kind == src_kind)
 970         {
 971           memmove (dst, sr,
 972                    dst_size > src_size ? src_size : dst_size);
 973           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 974             {
 975               if (dst_kind == 1)
 976                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 977               else /* dst_kind == 4.  */
 978                 for (k = src_size/4; k < dst_size/4; k++)
 979                   ((int32_t*) dst)[k] = (int32_t) ' ';
 980             }
 981         }
 982       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 983         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 984       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 985         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 986       else
 987         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 988                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
 989     }
 990 }
 991
 992
 993 void
 994 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 995                        int dst_image_index, gfc_descriptor_t *dest,
 996                        caf_vector_t *dst_vector, caf_token_t src_token,
 997                        size_t src_offset,
 998                        int src_image_index __attribute__ ((unused)),
 999                        gfc_descriptor_t *src,
1000                        caf_vector_t *src_vector __attribute__ ((unused)),
1001                        int dst_kind, int src_kind, bool may_require_tmp)
1002 {
1003   /* FIXME: Handle vector subscript of 'src_vector'.  */
1004   /* For a single image, src->base_addr should be the same as src_token + offset
1005      but to play save, we do it properly.  */
1006   void *src_base = GFC_DESCRIPTOR_DATA (src);
1007   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
1008   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
1009                       src, dst_kind, src_kind, may_require_tmp, NULL);
1010   GFC_DESCRIPTOR_DATA (src) = src_base;
1011 }
1012
1013
1014 void
1015 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
1016                              int image_index __attribute__ ((unused)),
1017                              void *value, int *stat,
1018                              int type __attribute__ ((unused)), int kind)
1019 {
1020   assert(kind == 4);
1021
1022   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1023
1024   __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
1025
1026   if (stat)
1027     *stat = 0;
1028 }
1029
1030 void
1031 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
1032                           int image_index __attribute__ ((unused)),
1033                           void *value, int *stat,
1034                           int type __attribute__ ((unused)), int kind)
1035 {
1036   assert(kind == 4);
1037
1038   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1039
1040   __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
1041
1042   if (stat)
1043     *stat = 0;
1044 }
1045
1046
1047 void
1048 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
1049                           int image_index __attribute__ ((unused)),
1050                           void *old, void *compare, void *new_val, int *stat,
1051                           int type __attribute__ ((unused)), int kind)
1052 {
1053   assert(kind == 4);
1054
1055   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1056
1057   *(uint32_t *) old = *(uint32_t *) compare;
1058   (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
1059                                       *(uint32_t *) new_val, false,
1060                                       __ATOMIC_RELAXED, __ATOMIC_RELAXED);
1061   if (stat)
1062     *stat = 0;
1063 }
1064
1065
1066 void
1067 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
1068                          int image_index __attribute__ ((unused)),
1069                          void *value, void *old, int *stat,
1070                          int type __attribute__ ((unused)), int kind)
1071 {
1072   assert(kind == 4);
1073
1074   uint32_t res;
1075   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1076
1077   switch (op)
1078     {
1079     case GFC_CAF_ATOMIC_ADD:
1080       res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1081       break;
1082     case GFC_CAF_ATOMIC_AND:
1083       res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1084       break;
1085     case GFC_CAF_ATOMIC_OR:
1086       res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1087       break;
1088     case GFC_CAF_ATOMIC_XOR:
1089       res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1090       break;
1091     default:
1092       __builtin_unreachable();
1093     }
1094
1095   if (old)
1096     *(uint32_t *) old = res;
1097
1098   if (stat)
1099     *stat = 0;
1100 }
1101
1102 void
1103 _gfortran_caf_event_post (caf_token_t token, size_t index,
1104                           int image_index __attribute__ ((unused)),
1105                           int *stat, char *errmsg __attribute__ ((unused)),
1106                           int errmsg_len __attribute__ ((unused)))
1107 {
1108   uint32_t value = 1;
1109   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1110   __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1111
1112   if(stat)
1113     *stat = 0;
1114 }
1115
1116 void
1117 _gfortran_caf_event_wait (caf_token_t token, size_t index,
1118                           int until_count, int *stat,
1119                           char *errmsg __attribute__ ((unused)),
1120                           int errmsg_len __attribute__ ((unused)))
1121 {
1122   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1123   uint32_t value = (uint32_t)-until_count;
1124    __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1125
1126    if(stat)
1127     *stat = 0;
1128 }
1129
1130 void
1131 _gfortran_caf_event_query (caf_token_t token, size_t index,
1132                            int image_index __attribute__ ((unused)),
1133                            int *count, int *stat)
1134 {
1135   uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1136   __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
1137
1138   if(stat)
1139     *stat = 0;
1140 }
1141
1142 void
1143 _gfortran_caf_lock (caf_token_t token, size_t index,
1144                     int image_index __attribute__ ((unused)),
1145                     int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
1146 {
1147   const char *msg = "Already locked";
1148   bool *lock = &((bool *) TOKEN (token))[index];
1149
1150   if (!*lock)
1151     {
1152       *lock = true;
1153       if (aquired_lock)
1154         *aquired_lock = (int) true;
1155       if (stat)
1156         *stat = 0;
1157       return;
1158     }
1159
1160   if (aquired_lock)
1161     {
1162       *aquired_lock = (int) false;
1163       if (stat)
1164         *stat = 0;
1165     return;
1166     }
1167
1168
1169   if (stat)
1170     {
1171       *stat = 1;
1172       if (errmsg_len > 0)
1173         {
1174           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1175                                                       : (int) sizeof (msg);
1176           memcpy (errmsg, msg, len);
1177           if (errmsg_len > len)
1178             memset (&errmsg[len], ' ', errmsg_len-len);
1179         }
1180       return;
1181     }
1182   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1183 }
1184
1185
1186 void
1187 _gfortran_caf_unlock (caf_token_t token, size_t index,
1188                       int image_index __attribute__ ((unused)),
1189                       int *stat, char *errmsg, int errmsg_len)
1190 {
1191   const char *msg = "Variable is not locked";
1192   bool *lock = &((bool *) TOKEN (token))[index];
1193
1194   if (*lock)
1195     {
1196       *lock = false;
1197       if (stat)
1198         *stat = 0;
1199       return;
1200     }
1201
1202   if (stat)
1203     {
1204       *stat = 1;
1205       if (errmsg_len > 0)
1206         {
1207           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1208                                                       : (int) sizeof (msg);
1209           memcpy (errmsg, msg, len);
1210           if (errmsg_len > len)
1211             memset (&errmsg[len], ' ', errmsg_len-len);
1212         }
1213       return;
1214     }
1215   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1216 }