libgfortran/caf/single.c

   1 /* Single-image implementation of GNU Fortran Coarray Library
   2    Copyright (C) 2011-2014 Free Software Foundation, Inc.
   3    Contributed by Tobias Burnus <burnus@net-b.de>
   4
   5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
   6
   7 Libcaf is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3, or (at your option)
  10 any later version.
  11
  12 Libcaf is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libcaf.h"
  27 #include <stdio.h>  /* For fputs and fprintf.  */
  28 #include <stdlib.h> /* For exit and malloc.  */
  29 #include <string.h> /* For memcpy and memset.  */
  30 #include <stdarg.h> /* For variadic arguments.  */
  31 #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)
 105     local = calloc (size, sizeof (bool));
 106   else
 107     local = malloc (size);
 108   *token = malloc (sizeof (single_token_t));
 109
 110   if (unlikely (local == NULL || token == NULL))
 111     {
 112       const char msg[] = "Failed to allocate coarray";
 113       if (stat)
 114         {
 115           *stat = 1;
 116           if (errmsg_len > 0)
 117             {
 118               int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 119                                                           : (int) sizeof (msg);
 120               memcpy (errmsg, msg, len);
 121               if (errmsg_len > len)
 122                 memset (&errmsg[len], ' ', errmsg_len-len);
 123             }
 124           return NULL;
 125         }
 126       else
 127           caf_runtime_error (msg);
 128     }
 129
 130   *token = local;
 131
 132   if (stat)
 133     *stat = 0;
 134
 135   if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
 136       || type == CAF_REGTYPE_CRITICAL)
 137     {
 138       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 139       tmp->prev  = caf_static_list;
 140       tmp->token = *token;
 141       caf_static_list = tmp;
 142     }
 143   return local;
 144 }
 145
 146
 147 void
 148 _gfortran_caf_deregister (caf_token_t *token, int *stat,
 149                           char *errmsg __attribute__ ((unused)),
 150                           int errmsg_len __attribute__ ((unused)))
 151 {
 152   free (TOKEN(*token));
 153
 154   if (stat)
 155     *stat = 0;
 156 }
 157
 158
 159 void
 160 _gfortran_caf_sync_all (int *stat,
 161                         char *errmsg __attribute__ ((unused)),
 162                         int errmsg_len __attribute__ ((unused)))
 163 {
 164   if (stat)
 165     *stat = 0;
 166 }
 167
 168
 169 void
 170 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
 171                            int images[] __attribute__ ((unused)),
 172                            int *stat,
 173                            char *errmsg __attribute__ ((unused)),
 174                            int errmsg_len __attribute__ ((unused)))
 175 {
 176 #ifdef GFC_CAF_CHECK
 177   int i;
 178
 179   for (i = 0; i < count; i++)
 180     if (images[i] != 1)
 181       {
 182         fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 183                  "IMAGES", images[i]);
 184         exit (EXIT_FAILURE);
 185       }
 186 #endif
 187
 188   if (stat)
 189     *stat = 0;
 190 }
 191
 192
 193 void
 194 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 195 {
 196   fputs ("ERROR STOP ", stderr);
 197   while (len--)
 198     fputc (*(string++), stderr);
 199   fputs ("\n", stderr);
 200
 201   exit (1);
 202 }
 203
 204
 205 void
 206 _gfortran_caf_error_stop (int32_t error)
 207 {
 208   fprintf (stderr, "ERROR STOP %d\n", error);
 209   exit (error);
 210 }
 211
 212
 213 void
 214 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
 215                       int result_image __attribute__ ((unused)),
 216                       int *stat, char *errmsg __attribute__ ((unused)),
 217                       int errmsg_len __attribute__ ((unused)))
 218 {
 219   if (stat)
 220     *stat = 0;
 221 }
 222
 223 void
 224 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
 225                       int result_image __attribute__ ((unused)),
 226                       int *stat, char *errmsg __attribute__ ((unused)),
 227                       int src_len __attribute__ ((unused)),
 228                       int errmsg_len __attribute__ ((unused)))
 229 {
 230   if (stat)
 231     *stat = 0;
 232 }
 233
 234 void
 235 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
 236                       int result_image __attribute__ ((unused)),
 237                       int *stat, char *errmsg __attribute__ ((unused)),
 238                       int src_len __attribute__ ((unused)),
 239                       int errmsg_len __attribute__ ((unused)))
 240 {
 241   if (stat)
 242     *stat = 0;
 243 }
 244
 245
 246 static void
 247 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
 248                          unsigned char *src)
 249 {
 250   size_t i, n;
 251   n = dst_size/4 > src_size ? src_size : dst_size/4;
 252   for (i = 0; i < n; ++i)
 253     dst[i] = (int32_t) src[i];
 254   for (; i < dst_size/4; ++i)
 255     dst[i] = (int32_t) ' ';
 256 }
 257
 258
 259 static void
 260 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
 261                          uint32_t *src)
 262 {
 263   size_t i, n;
 264   n = dst_size > src_size/4 ? src_size/4 : dst_size;
 265   for (i = 0; i < n; ++i)
 266     dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
 267   if (dst_size > n)
 268     memset(&dst[n], ' ', dst_size - n);
 269 }
 270
 271
 272 static void
 273 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
 274               int src_kind)
 275 {
 276 #ifdef HAVE_GFC_INTEGER_16
 277   typedef __int128 int128t;
 278 #else
 279   typedef int64_t int128t;
 280 #endif
 281
 282 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
 283   typedef long double real128t;
 284   typedef _Complex long double complex128t;
 285 #elif defined(HAVE_GFC_REAL_16)
 286   typedef _Complex float __attribute__((mode(TC))) __complex128;
 287   typedef __float128 real128t;
 288   typedef __complex128 complex128t;
 289 #elif defined(HAVE_GFC_REAL_10)
 290   typedef long double real128t;
 291   typedef long double complex128t;
 292 #else
 293   typedef double real128t;
 294   typedef _Complex double complex128t;
 295 #endif
 296
 297   int128t int_val = 0;
 298   real128t real_val = 0;
 299   complex128t cmpx_val = 0;
 300
 301   switch (src_type)
 302     {
 303     case BT_INTEGER:
 304       if (src_kind == 1)
 305         int_val = *(int8_t*) src;
 306       else if (src_kind == 2)
 307         int_val = *(int16_t*) src;
 308       else if (src_kind == 4)
 309         int_val = *(int32_t*) src;
 310       else if (src_kind == 8)
 311         int_val = *(int64_t*) src;
 312 #ifdef HAVE_GFC_INTEGER_16
 313       else if (src_kind == 16)
 314         int_val = *(int128t*) src;
 315 #endif
 316       else
 317         goto error;
 318       break;
 319     case BT_REAL:
 320       if (src_kind == 4)
 321         real_val = *(float*) src;
 322       else if (src_kind == 8)
 323         real_val = *(double*) src;
 324 #ifdef HAVE_GFC_REAL_10
 325       else if (src_kind == 10)
 326         real_val = *(long double*) src;
 327 #endif
 328 #ifdef HAVE_GFC_REAL_16
 329       else if (src_kind == 16)
 330         real_val = *(real128t*) src;
 331 #endif
 332       else
 333         goto error;
 334       break;
 335     case BT_COMPLEX:
 336       if (src_kind == 4)
 337         cmpx_val = *(_Complex float*) src;
 338       else if (src_kind == 8)
 339         cmpx_val = *(_Complex double*) src;
 340 #ifdef HAVE_GFC_REAL_10
 341       else if (src_kind == 10)
 342         cmpx_val = *(_Complex long double*) src;
 343 #endif
 344 #ifdef HAVE_GFC_REAL_16
 345       else if (src_kind == 16)
 346         cmpx_val = *(complex128t*) src;
 347 #endif
 348       else
 349         goto error;
 350       break;
 351     default:
 352       goto error;
 353     }
 354
 355   switch (dst_type)
 356     {
 357     case BT_INTEGER:
 358       if (src_type == BT_INTEGER)
 359         {
 360           if (dst_kind == 1)
 361             *(int8_t*) dst = (int8_t) int_val;
 362           else if (dst_kind == 2)
 363             *(int16_t*) dst = (int16_t) int_val;
 364           else if (dst_kind == 4)
 365             *(int32_t*) dst = (int32_t) int_val;
 366           else if (dst_kind == 8)
 367             *(int64_t*) dst = (int64_t) int_val;
 368 #ifdef HAVE_GFC_INTEGER_16
 369           else if (dst_kind == 16)
 370             *(int128t*) dst = (int128t) int_val;
 371 #endif
 372           else
 373             goto error;
 374         }
 375       else if (src_type == BT_REAL)
 376         {
 377           if (dst_kind == 1)
 378             *(int8_t*) dst = (int8_t) real_val;
 379           else if (dst_kind == 2)
 380             *(int16_t*) dst = (int16_t) real_val;
 381           else if (dst_kind == 4)
 382             *(int32_t*) dst = (int32_t) real_val;
 383           else if (dst_kind == 8)
 384             *(int64_t*) dst = (int64_t) real_val;
 385 #ifdef HAVE_GFC_INTEGER_16
 386           else if (dst_kind == 16)
 387             *(int128t*) dst = (int128t) real_val;
 388 #endif
 389           else
 390             goto error;
 391         }
 392       else if (src_type == BT_COMPLEX)
 393         {
 394           if (dst_kind == 1)
 395             *(int8_t*) dst = (int8_t) cmpx_val;
 396           else if (dst_kind == 2)
 397             *(int16_t*) dst = (int16_t) cmpx_val;
 398           else if (dst_kind == 4)
 399             *(int32_t*) dst = (int32_t) cmpx_val;
 400           else if (dst_kind == 8)
 401             *(int64_t*) dst = (int64_t) cmpx_val;
 402 #ifdef HAVE_GFC_INTEGER_16
 403           else if (dst_kind == 16)
 404             *(int128t*) dst = (int128t) cmpx_val;
 405 #endif
 406           else
 407             goto error;
 408         }
 409       else
 410         goto error;
 411       break;
 412     case BT_REAL:
 413       if (src_type == BT_INTEGER)
 414         {
 415           if (dst_kind == 4)
 416             *(float*) dst = (float) int_val;
 417           else if (dst_kind == 8)
 418             *(double*) dst = (double) int_val;
 419 #ifdef HAVE_GFC_REAL_10
 420           else if (dst_kind == 10)
 421             *(long double*) dst = (long double) int_val;
 422 #endif
 423 #ifdef HAVE_GFC_REAL_16
 424           else if (dst_kind == 16)
 425             *(real128t*) dst = (real128t) int_val;
 426 #endif
 427           else
 428             goto error;
 429         }
 430       else if (src_type == BT_REAL)
 431         {
 432           if (dst_kind == 4)
 433             *(float*) dst = (float) real_val;
 434           else if (dst_kind == 8)
 435             *(double*) dst = (double) real_val;
 436 #ifdef HAVE_GFC_REAL_10
 437           else if (dst_kind == 10)
 438             *(long double*) dst = (long double) real_val;
 439 #endif
 440 #ifdef HAVE_GFC_REAL_16
 441           else if (dst_kind == 16)
 442             *(real128t*) dst = (real128t) real_val;
 443 #endif
 444           else
 445             goto error;
 446         }
 447       else if (src_type == BT_COMPLEX)
 448         {
 449           if (dst_kind == 4)
 450             *(float*) dst = (float) cmpx_val;
 451           else if (dst_kind == 8)
 452             *(double*) dst = (double) cmpx_val;
 453 #ifdef HAVE_GFC_REAL_10
 454           else if (dst_kind == 10)
 455             *(long double*) dst = (long double) cmpx_val;
 456 #endif
 457 #ifdef HAVE_GFC_REAL_16
 458           else if (dst_kind == 16)
 459             *(real128t*) dst = (real128t) cmpx_val;
 460 #endif
 461           else
 462             goto error;
 463         }
 464       break;
 465     case BT_COMPLEX:
 466       if (src_type == BT_INTEGER)
 467         {
 468           if (dst_kind == 4)
 469             *(_Complex float*) dst = (_Complex float) int_val;
 470           else if (dst_kind == 8)
 471             *(_Complex double*) dst = (_Complex double) int_val;
 472 #ifdef HAVE_GFC_REAL_10
 473           else if (dst_kind == 10)
 474             *(_Complex long double*) dst = (_Complex long double) int_val;
 475 #endif
 476 #ifdef HAVE_GFC_REAL_16
 477           else if (dst_kind == 16)
 478             *(complex128t*) dst = (complex128t) int_val;
 479 #endif
 480           else
 481             goto error;
 482         }
 483       else if (src_type == BT_REAL)
 484         {
 485           if (dst_kind == 4)
 486             *(_Complex float*) dst = (_Complex float) real_val;
 487           else if (dst_kind == 8)
 488             *(_Complex double*) dst = (_Complex double) real_val;
 489 #ifdef HAVE_GFC_REAL_10
 490           else if (dst_kind == 10)
 491             *(_Complex long double*) dst = (_Complex long double) real_val;
 492 #endif
 493 #ifdef HAVE_GFC_REAL_16
 494           else if (dst_kind == 16)
 495             *(complex128t*) dst = (complex128t) real_val;
 496 #endif
 497           else
 498             goto error;
 499         }
 500       else if (src_type == BT_COMPLEX)
 501         {
 502           if (dst_kind == 4)
 503             *(_Complex float*) dst = (_Complex float) cmpx_val;
 504           else if (dst_kind == 8)
 505             *(_Complex double*) dst = (_Complex double) cmpx_val;
 506 #ifdef HAVE_GFC_REAL_10
 507           else if (dst_kind == 10)
 508             *(_Complex long double*) dst = (_Complex long double) cmpx_val;
 509 #endif
 510 #ifdef HAVE_GFC_REAL_16
 511           else if (dst_kind == 16)
 512             *(complex128t*) dst = (complex128t) cmpx_val;
 513 #endif
 514           else
 515             goto error;
 516         }
 517       else
 518         goto error;
 519       break;
 520     default:
 521       goto error;
 522     }
 523
 524 error:
 525   fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
 526            "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
 527   abort();
 528 }
 529
 530
 531 void
 532 _gfortran_caf_get (caf_token_t token, size_t offset,
 533                    int image_index __attribute__ ((unused)),
 534                    gfc_descriptor_t *src,
 535                    caf_vector_t *src_vector __attribute__ ((unused)),
 536                    gfc_descriptor_t *dest, int src_kind, int dst_kind,
 537                    bool may_require_tmp)
 538 {
 539   /* FIXME: Handle vector subscripts.  */
 540   size_t i, k, size;
 541   int j;
 542   int rank = GFC_DESCRIPTOR_RANK (dest);
 543   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 544   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 545
 546   if (rank == 0)
 547     {
 548       void *sr = (void *) ((char *) TOKEN (token) + offset);
 549       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 550           && dst_kind == src_kind)
 551         {
 552           memmove (GFC_DESCRIPTOR_DATA (dest), sr,
 553                    dst_size > src_size ? src_size : dst_size);
 554           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 555             {
 556               if (dst_kind == 1)
 557                 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
 558                         ' ', dst_size - src_size);
 559               else /* dst_kind == 4.  */
 560                 for (i = src_size/4; i < dst_size/4; i++)
 561                   ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
 562             }
 563         }
 564       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 565         assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 566                                  sr);
 567       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 568         assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 569                                  sr);
 570       else
 571         convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
 572                       dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 573       return;
 574     }
 575
 576   size = 1;
 577   for (j = 0; j < rank; j++)
 578     {
 579       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 580       if (dimextent < 0)
 581         dimextent = 0;
 582       size *= dimextent;
 583     }
 584
 585   if (size == 0)
 586     return;
 587
 588   if (may_require_tmp)
 589     {
 590       ptrdiff_t array_offset_sr, array_offset_dst;
 591       void *tmp = malloc (size*src_size);
 592
 593       array_offset_dst = 0;
 594       for (i = 0; i < size; i++)
 595         {
 596           ptrdiff_t array_offset_sr = 0;
 597           ptrdiff_t stride = 1;
 598           ptrdiff_t extent = 1;
 599           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 600             {
 601               array_offset_sr += ((i / (extent*stride))
 602                                   % (src->dim[j]._ubound
 603                                     - src->dim[j].lower_bound + 1))
 604                                  * src->dim[j]._stride;
 605               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 606               stride = src->dim[j]._stride;
 607             }
 608           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 609           void *sr = (void *)((char *) TOKEN (token) + offset
 610                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 611           memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 612           array_offset_dst += src_size;
 613         }
 614
 615       array_offset_sr = 0;
 616       for (i = 0; i < size; i++)
 617         {
 618           ptrdiff_t array_offset_dst = 0;
 619           ptrdiff_t stride = 1;
 620           ptrdiff_t extent = 1;
 621           for (j = 0; j < rank-1; j++)
 622             {
 623               array_offset_dst += ((i / (extent*stride))
 624                                    % (dest->dim[j]._ubound
 625                                       - dest->dim[j].lower_bound + 1))
 626                                   * dest->dim[j]._stride;
 627               extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 628               stride = dest->dim[j]._stride;
 629             }
 630           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 631           void *dst = dest->base_addr
 632                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 633           void *sr = tmp + array_offset_sr;
 634
 635           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 636               && dst_kind == src_kind)
 637             {
 638               memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 639               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 640                   && dst_size > src_size)
 641                 {
 642                   if (dst_kind == 1)
 643                     memset ((void*)(char*) dst + src_size, ' ',
 644                             dst_size-src_size);
 645                   else /* dst_kind == 4.  */
 646                     for (k = src_size/4; k < dst_size/4; k++)
 647                       ((int32_t*) dst)[k] = (int32_t) ' ';
 648                 }
 649             }
 650           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 651             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 652           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 653             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 654           else
 655             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 656                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 657           array_offset_sr += src_size;
 658         }
 659
 660       free (tmp);
 661       return;
 662     }
 663
 664   for (i = 0; i < size; i++)
 665     {
 666       ptrdiff_t array_offset_dst = 0;
 667       ptrdiff_t stride = 1;
 668       ptrdiff_t extent = 1;
 669       for (j = 0; j < rank-1; j++)
 670         {
 671           array_offset_dst += ((i / (extent*stride))
 672                                % (dest->dim[j]._ubound
 673                                   - dest->dim[j].lower_bound + 1))
 674                               * dest->dim[j]._stride;
 675           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 676           stride = dest->dim[j]._stride;
 677         }
 678       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 679       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 680
 681       ptrdiff_t array_offset_sr = 0;
 682       stride = 1;
 683       extent = 1;
 684       for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 685         {
 686           array_offset_sr += ((i / (extent*stride))
 687                                % (src->dim[j]._ubound
 688                                   - src->dim[j].lower_bound + 1))
 689                               * src->dim[j]._stride;
 690           extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 691           stride = src->dim[j]._stride;
 692         }
 693       array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 694       void *sr = (void *)((char *) TOKEN (token) + offset
 695                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 696
 697       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 698           && dst_kind == src_kind)
 699         {
 700           memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 701           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 702             {
 703               if (dst_kind == 1)
 704                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 705               else /* dst_kind == 4.  */
 706                 for (k = src_size/4; k < dst_size/4; k++)
 707                   ((int32_t*) dst)[k] = (int32_t) ' ';
 708             }
 709         }
 710       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 711         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 712       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 713         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 714       else
 715         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 716                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 717     }
 718 }
 719
 720
 721 void
 722 _gfortran_caf_send (caf_token_t token, size_t offset,
 723                     int image_index __attribute__ ((unused)),
 724                     gfc_descriptor_t *dest,
 725                     caf_vector_t *dst_vector __attribute__ ((unused)),
 726                     gfc_descriptor_t *src, int dst_kind, int src_kind,
 727                     bool may_require_tmp)
 728 {
 729   /* FIXME: Handle vector subscripts.  */
 730   size_t i, k, size;
 731   int j;
 732   int rank = GFC_DESCRIPTOR_RANK (dest);
 733   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 734   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 735
 736   if (rank == 0)
 737     {
 738       void *dst = (void *) ((char *) TOKEN (token) + offset);
 739       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 740           && dst_kind == src_kind)
 741         {
 742           memmove (dst, GFC_DESCRIPTOR_DATA (src),
 743                    dst_size > src_size ? src_size : dst_size);
 744           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 745             {
 746               if (dst_kind == 1)
 747                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 748               else /* dst_kind == 4.  */
 749                 for (i = src_size/4; i < dst_size/4; i++)
 750                   ((int32_t*) dst)[i] = (int32_t) ' ';
 751             }
 752         }
 753       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 754         assign_char1_from_char4 (dst_size, src_size, dst,
 755                                  GFC_DESCRIPTOR_DATA (src));
 756       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 757         assign_char4_from_char1 (dst_size, src_size, dst,
 758                                  GFC_DESCRIPTOR_DATA (src));
 759       else
 760         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 761                       GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
 762                       src_kind);
 763       return;
 764     }
 765
 766   size = 1;
 767   for (j = 0; j < rank; j++)
 768     {
 769       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 770       if (dimextent < 0)
 771         dimextent = 0;
 772       size *= dimextent;
 773     }
 774
 775   if (size == 0)
 776     return;
 777
 778   if (may_require_tmp)
 779     {
 780       ptrdiff_t array_offset_sr, array_offset_dst;
 781       void *tmp;
 782
 783       if (GFC_DESCRIPTOR_RANK (src) == 0)
 784         {
 785           tmp = malloc (src_size);
 786           memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
 787         }
 788       else
 789         {
 790           tmp = malloc (size*src_size);
 791           array_offset_dst = 0;
 792           for (i = 0; i < size; i++)
 793             {
 794               ptrdiff_t array_offset_sr = 0;
 795               ptrdiff_t stride = 1;
 796               ptrdiff_t extent = 1;
 797               for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 798                 {
 799                   array_offset_sr += ((i / (extent*stride))
 800                                       % (src->dim[j]._ubound
 801                                          - src->dim[j].lower_bound + 1))
 802                                      * src->dim[j]._stride;
 803                   extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 804                   stride = src->dim[j]._stride;
 805                 }
 806               array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 807               void *sr = (void *) ((char *) src->base_addr
 808                                    + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 809               memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
 810               array_offset_dst += src_size;
 811             }
 812         }
 813
 814       array_offset_sr = 0;
 815       for (i = 0; i < size; i++)
 816         {
 817           ptrdiff_t array_offset_dst = 0;
 818           ptrdiff_t stride = 1;
 819           ptrdiff_t extent = 1;
 820           for (j = 0; j < rank-1; j++)
 821             {
 822               array_offset_dst += ((i / (extent*stride))
 823                                    % (dest->dim[j]._ubound
 824                                       - dest->dim[j].lower_bound + 1))
 825                                   * dest->dim[j]._stride;
 826           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 827           stride = dest->dim[j]._stride;
 828             }
 829           array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 830           void *dst = (void *)((char *) TOKEN (token) + offset
 831                       + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 832           void *sr = tmp + array_offset_sr;
 833           if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 834               && dst_kind == src_kind)
 835             {
 836               memmove (dst, sr,
 837                        dst_size > src_size ? src_size : dst_size);
 838               if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
 839                   && dst_size > src_size)
 840                 {
 841                   if (dst_kind == 1)
 842                     memset ((void*)(char*) dst + src_size, ' ',
 843                             dst_size-src_size);
 844                   else /* dst_kind == 4.  */
 845                     for (k = src_size/4; k < dst_size/4; k++)
 846                       ((int32_t*) dst)[k] = (int32_t) ' ';
 847                 }
 848             }
 849           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 850             assign_char1_from_char4 (dst_size, src_size, dst, sr);
 851           else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 852             assign_char4_from_char1 (dst_size, src_size, dst, sr);
 853           else
 854             convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 855                           sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 856           if (GFC_DESCRIPTOR_RANK (src))
 857             array_offset_sr += src_size;
 858         }
 859       free (tmp);
 860       return;
 861     }
 862
 863   for (i = 0; i < size; i++)
 864     {
 865       ptrdiff_t array_offset_dst = 0;
 866       ptrdiff_t stride = 1;
 867       ptrdiff_t extent = 1;
 868       for (j = 0; j < rank-1; j++)
 869         {
 870           array_offset_dst += ((i / (extent*stride))
 871                                % (dest->dim[j]._ubound
 872                                   - dest->dim[j].lower_bound + 1))
 873                               * dest->dim[j]._stride;
 874           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 875           stride = dest->dim[j]._stride;
 876         }
 877       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 878       void *dst = (void *)((char *) TOKEN (token) + offset
 879                            + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 880       void *sr;
 881       if (GFC_DESCRIPTOR_RANK (src) != 0)
 882         {
 883           ptrdiff_t array_offset_sr = 0;
 884           stride = 1;
 885           extent = 1;
 886           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 887             {
 888               array_offset_sr += ((i / (extent*stride))
 889                                   % (src->dim[j]._ubound
 890                                      - src->dim[j].lower_bound + 1))
 891                                  * src->dim[j]._stride;
 892               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 893               stride = src->dim[j]._stride;
 894             }
 895           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 896           sr = (void *)((char *) src->base_addr
 897                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 898         }
 899       else
 900         sr = src->base_addr;
 901
 902       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 903           && dst_kind == src_kind)
 904         {
 905           memmove (dst, sr,
 906                    dst_size > src_size ? src_size : dst_size);
 907           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 908             {
 909               if (dst_kind == 1)
 910                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 911               else /* dst_kind == 4.  */
 912                 for (k = src_size/4; k < dst_size/4; k++)
 913                   ((int32_t*) dst)[k] = (int32_t) ' ';
 914             }
 915         }
 916       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 917         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 918       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 919         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 920       else
 921         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 922                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 923     }
 924 }
 925
 926
 927 void
 928 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 929                        int dst_image_index, gfc_descriptor_t *dest,
 930                        caf_vector_t *dst_vector, caf_token_t src_token,
 931                        size_t src_offset,
 932                        int src_image_index __attribute__ ((unused)),
 933                        gfc_descriptor_t *src,
 934                        caf_vector_t *src_vector __attribute__ ((unused)),
 935                        int dst_kind, int src_kind, bool may_require_tmp)
 936 {
 937   /* FIXME: Handle vector subscript of 'src_vector'.  */
 938   /* For a single image, src->base_addr should be the same as src_token + offset
 939      but to play save, we do it properly.  */
 940   void *src_base = GFC_DESCRIPTOR_DATA (src);
 941   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
 942   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
 943                       src, dst_kind, src_kind, may_require_tmp);
 944   GFC_DESCRIPTOR_DATA (src) = src_base;
 945 }
 946
 947
 948 void
 949 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
 950                              int image_index __attribute__ ((unused)),
 951                              void *value, int *stat,
 952                              int type __attribute__ ((unused)), int kind)
 953 {
 954   assert(kind == 4);
 955
 956   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 957
 958   __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 959
 960   if (stat)
 961     *stat = 0;
 962 }
 963
 964 void
 965 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
 966                           int image_index __attribute__ ((unused)),
 967                           void *value, int *stat,
 968                           int type __attribute__ ((unused)), int kind)
 969 {
 970   assert(kind == 4);
 971
 972   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 973
 974   __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 975
 976   if (stat)
 977     *stat = 0;
 978 }
 979
 980
 981 void
 982 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
 983                           int image_index __attribute__ ((unused)),
 984                           void *old, void *compare, void *new_val, int *stat,
 985                           int type __attribute__ ((unused)), int kind)
 986 {
 987   assert(kind == 4);
 988
 989   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 990
 991   *(uint32_t *) old = *(uint32_t *) compare;
 992   (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
 993                                       *(uint32_t *) new_val, false,
 994                                       __ATOMIC_RELAXED, __ATOMIC_RELAXED);
 995   if (stat)
 996     *stat = 0;
 997 }
 998
 999
1000 void
1001 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
1002                          int image_index __attribute__ ((unused)),
1003                          void *value, void *old, int *stat,
1004                          int type __attribute__ ((unused)), int kind)
1005 {
1006   assert(kind == 4);
1007
1008   uint32_t res;
1009   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1010
1011   switch (op)
1012     {
1013     case GFC_CAF_ATOMIC_ADD:
1014       res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1015       break;
1016     case GFC_CAF_ATOMIC_AND:
1017       res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1018       break;
1019     case GFC_CAF_ATOMIC_OR:
1020       res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1021       break;
1022     case GFC_CAF_ATOMIC_XOR:
1023       res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1024       break;
1025     default:
1026       __builtin_unreachable();
1027     }
1028
1029   if (old)
1030     *(uint32_t *) old = res;
1031
1032   if (stat)
1033     *stat = 0;
1034 }
1035
1036
1037 void
1038 _gfortran_caf_lock (caf_token_t token, size_t index,
1039                     int image_index __attribute__ ((unused)),
1040                     int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
1041 {
1042   const char *msg = "Already locked";
1043   bool *lock = &((bool *) TOKEN (token))[index];
1044
1045   if (!*lock)
1046     {
1047       *lock = true;
1048       if (aquired_lock)
1049         *aquired_lock = (int) true;
1050       if (stat)
1051         *stat = 0;
1052       return;
1053     }
1054
1055   if (aquired_lock)
1056     {
1057       *aquired_lock = (int) false;
1058       if (stat)
1059         *stat = 0;
1060     return;
1061     }
1062
1063
1064   if (stat)
1065     {
1066       *stat = 1;
1067       if (errmsg_len > 0)
1068         {
1069           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1070                                                       : (int) sizeof (msg);
1071           memcpy (errmsg, msg, len);
1072           if (errmsg_len > len)
1073             memset (&errmsg[len], ' ', errmsg_len-len);
1074         }
1075       return;
1076     }
1077   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1078 }
1079
1080
1081 void
1082 _gfortran_caf_unlock (caf_token_t token, size_t index,
1083                       int image_index __attribute__ ((unused)),
1084                       int *stat, char *errmsg, int errmsg_len)
1085 {
1086   const char *msg = "Variable is not locked";
1087   bool *lock = &((bool *) TOKEN (token))[index];
1088
1089   if (*lock)
1090     {
1091       *lock = false;
1092       if (stat)
1093         *stat = 0;
1094       return;
1095     }
1096
1097   if (stat)
1098     {
1099       *stat = 1;
1100       if (errmsg_len > 0)
1101         {
1102           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1103                                                       : (int) sizeof (msg);
1104           memcpy (errmsg, msg, len);
1105           if (errmsg_len > len)
1106             memset (&errmsg[len], ' ', errmsg_len-len);
1107         }
1108       return;
1109     }
1110   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1111 }