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 {
 538   /* FIXME: Handle vector subscripts.  */
 539   size_t i, k, size;
 540   int j;
 541   int rank = GFC_DESCRIPTOR_RANK (dest);
 542   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 543   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 544
 545   if (rank == 0)
 546     {
 547       void *sr = (void *) ((char *) TOKEN (token) + offset);
 548       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 549           && dst_kind == src_kind)
 550         {
 551           memmove (GFC_DESCRIPTOR_DATA (dest), sr,
 552                    dst_size > src_size ? src_size : dst_size);
 553           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 554             {
 555               if (dst_kind == 1)
 556                 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
 557                         ' ', dst_size - src_size);
 558               else /* dst_kind == 4.  */
 559                 for (i = src_size/4; i < dst_size/4; i++)
 560                   ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
 561             }
 562         }
 563       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 564         assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 565                                  sr);
 566       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 567         assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 568                                  sr);
 569       else
 570         convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
 571                       dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 572       return;
 573     }
 574
 575   size = 1;
 576   for (j = 0; j < rank; j++)
 577     {
 578       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 579       if (dimextent < 0)
 580         dimextent = 0;
 581       size *= dimextent;
 582     }
 583
 584   if (size == 0)
 585     return;
 586
 587   for (i = 0; i < size; i++)
 588     {
 589       ptrdiff_t array_offset_dst = 0;
 590       ptrdiff_t stride = 1;
 591       ptrdiff_t extent = 1;
 592       for (j = 0; j < rank-1; j++)
 593         {
 594           array_offset_dst += ((i / (extent*stride))
 595                                % (dest->dim[j]._ubound
 596                                   - dest->dim[j].lower_bound + 1))
 597                               * dest->dim[j]._stride;
 598           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 599           stride = dest->dim[j]._stride;
 600         }
 601       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 602       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 603
 604       ptrdiff_t array_offset_sr = 0;
 605       stride = 1;
 606       extent = 1;
 607       for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 608         {
 609           array_offset_sr += ((i / (extent*stride))
 610                                % (src->dim[j]._ubound
 611                                   - src->dim[j].lower_bound + 1))
 612                               * src->dim[j]._stride;
 613           extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 614           stride = src->dim[j]._stride;
 615         }
 616       array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 617       void *sr = (void *)((char *) TOKEN (token) + offset
 618                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 619
 620       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 621           && dst_kind == src_kind)
 622         {
 623           memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 624           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 625             {
 626               if (dst_kind == 1)
 627                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 628               else /* dst_kind == 4.  */
 629                 for (k = src_size/4; k < dst_size/4; k++)
 630                   ((int32_t*) dst)[k] = (int32_t) ' ';
 631             }
 632         }
 633       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 634         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 635       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 636         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 637       else
 638         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 639                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 640     }
 641 }
 642
 643
 644 void
 645 _gfortran_caf_send (caf_token_t token, size_t offset,
 646                     int image_index __attribute__ ((unused)),
 647                     gfc_descriptor_t *dest,
 648                     caf_vector_t *dst_vector __attribute__ ((unused)),
 649                     gfc_descriptor_t *src, int dst_kind, int src_kind)
 650 {
 651   /* FIXME: Handle vector subscripts.  */
 652   size_t i, k, size;
 653   int j;
 654   int rank = GFC_DESCRIPTOR_RANK (dest);
 655   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 656   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 657
 658   if (rank == 0)
 659     {
 660       void *dst = (void *) ((char *) TOKEN (token) + offset);
 661       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 662           && dst_kind == src_kind)
 663         {
 664           memmove (dst, GFC_DESCRIPTOR_DATA (src),
 665                    dst_size > src_size ? src_size : dst_size);
 666           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 667             {
 668               if (dst_kind == 1)
 669                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 670               else /* dst_kind == 4.  */
 671                 for (i = src_size/4; i < dst_size/4; i++)
 672                   ((int32_t*) dst)[i] = (int32_t) ' ';
 673             }
 674         }
 675       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 676         assign_char1_from_char4 (dst_size, src_size, dst,
 677                                  GFC_DESCRIPTOR_DATA (src));
 678       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 679         assign_char4_from_char1 (dst_size, src_size, dst,
 680                                  GFC_DESCRIPTOR_DATA (src));
 681       else
 682         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 683                       GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
 684                       src_kind);
 685       return;
 686     }
 687
 688   size = 1;
 689   for (j = 0; j < rank; j++)
 690     {
 691       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 692       if (dimextent < 0)
 693         dimextent = 0;
 694       size *= dimextent;
 695     }
 696
 697   if (size == 0)
 698     return;
 699
 700   for (i = 0; i < size; i++)
 701     {
 702       ptrdiff_t array_offset_dst = 0;
 703       ptrdiff_t stride = 1;
 704       ptrdiff_t extent = 1;
 705       for (j = 0; j < rank-1; j++)
 706         {
 707           array_offset_dst += ((i / (extent*stride))
 708                                % (dest->dim[j]._ubound
 709                                   - dest->dim[j].lower_bound + 1))
 710                               * dest->dim[j]._stride;
 711           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 712           stride = dest->dim[j]._stride;
 713         }
 714       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 715       void *dst = (void *)((char *) TOKEN (token) + offset
 716                            + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 717       void *sr;
 718       if (GFC_DESCRIPTOR_RANK (src) != 0)
 719         {
 720           ptrdiff_t array_offset_sr = 0;
 721           stride = 1;
 722           extent = 1;
 723           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 724             {
 725               array_offset_sr += ((i / (extent*stride))
 726                                   % (src->dim[j]._ubound
 727                                      - src->dim[j].lower_bound + 1))
 728                                  * src->dim[j]._stride;
 729               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 730               stride = src->dim[j]._stride;
 731             }
 732           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 733           sr = (void *)((char *) src->base_addr
 734                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 735         }
 736       else
 737         sr = src->base_addr;
 738
 739       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 740           && dst_kind == src_kind)
 741         {
 742           memmove (dst, sr,
 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 (k = src_size/4; k < dst_size/4; k++)
 750                   ((int32_t*) dst)[k] = (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, sr);
 755       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 756         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 757       else
 758         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 759                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 760     }
 761 }
 762
 763
 764 void
 765 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 766                        int dst_image_index, gfc_descriptor_t *dest,
 767                        caf_vector_t *dst_vector, caf_token_t src_token,
 768                        size_t src_offset,
 769                        int src_image_index __attribute__ ((unused)),
 770                        gfc_descriptor_t *src,
 771                        caf_vector_t *src_vector __attribute__ ((unused)),
 772                        int dst_kind, int src_kind)
 773 {
 774   /* FIXME: Handle vector subscript of 'src_vector'.  */
 775   /* For a single image, src->base_addr should be the same as src_token + offset
 776      but to play save, we do it properly.  */
 777   void *src_base = GFC_DESCRIPTOR_DATA (src);
 778   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
 779   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
 780                       src, dst_kind, src_kind);
 781   GFC_DESCRIPTOR_DATA (src) = src_base;
 782 }
 783
 784
 785 void
 786 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
 787                              int image_index __attribute__ ((unused)),
 788                              void *value, int *stat,
 789                              int type __attribute__ ((unused)), int kind)
 790 {
 791   assert(kind == 4);
 792
 793   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 794
 795   __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 796
 797   if (stat)
 798     *stat = 0;
 799 }
 800
 801 void
 802 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
 803                           int image_index __attribute__ ((unused)),
 804                           void *value, int *stat,
 805                           int type __attribute__ ((unused)), int kind)
 806 {
 807   assert(kind == 4);
 808
 809   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 810
 811   __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 812
 813   if (stat)
 814     *stat = 0;
 815 }
 816
 817
 818 void
 819 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
 820                           int image_index __attribute__ ((unused)),
 821                           void *old, void *compare, void *new_val, int *stat,
 822                           int type __attribute__ ((unused)), int kind)
 823 {
 824   assert(kind == 4);
 825
 826   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 827
 828   *(uint32_t *) old = *(uint32_t *) compare;
 829   (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
 830                                       *(uint32_t *) new_val, false,
 831                                       __ATOMIC_RELAXED, __ATOMIC_RELAXED);
 832   if (stat)
 833     *stat = 0;
 834 }
 835
 836
 837 void
 838 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
 839                          int image_index __attribute__ ((unused)),
 840                          void *value, void *old, int *stat,
 841                          int type __attribute__ ((unused)), int kind)
 842 {
 843   assert(kind == 4);
 844
 845   uint32_t res;
 846   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 847
 848   switch (op)
 849     {
 850     case GFC_CAF_ATOMIC_ADD:
 851       res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 852       break;
 853     case GFC_CAF_ATOMIC_AND:
 854       res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 855       break;
 856     case GFC_CAF_ATOMIC_OR:
 857       res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 858       break;
 859     case GFC_CAF_ATOMIC_XOR:
 860       res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 861       break;
 862     default:
 863       __builtin_unreachable();
 864     }
 865
 866   if (old)
 867     *(uint32_t *) old = res;
 868
 869   if (stat)
 870     *stat = 0;
 871 }
 872
 873
 874 void
 875 _gfortran_caf_lock (caf_token_t token, size_t index,
 876                     int image_index __attribute__ ((unused)),
 877                     int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
 878 {
 879   const char *msg = "Already locked";
 880   bool *lock = &((bool *) TOKEN (token))[index];
 881
 882   if (!*lock)
 883     {
 884       *lock = true;
 885       if (aquired_lock)
 886         *aquired_lock = (int) true;
 887       if (stat)
 888         *stat = 0;
 889       return;
 890     }
 891
 892   if (aquired_lock)
 893     {
 894       *aquired_lock = (int) false;
 895       if (stat)
 896         *stat = 0;
 897     return;
 898     }
 899
 900
 901   if (stat)
 902     {
 903       *stat = 1;
 904       if (errmsg_len > 0)
 905         {
 906           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 907                                                       : (int) sizeof (msg);
 908           memcpy (errmsg, msg, len);
 909           if (errmsg_len > len)
 910             memset (&errmsg[len], ' ', errmsg_len-len);
 911         }
 912       return;
 913     }
 914   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
 915 }
 916
 917
 918 void
 919 _gfortran_caf_unlock (caf_token_t token, size_t index,
 920                       int image_index __attribute__ ((unused)),
 921                       int *stat, char *errmsg, int errmsg_len)
 922 {
 923   const char *msg = "Variable is not locked";
 924   bool *lock = &((bool *) TOKEN (token))[index];
 925
 926   if (*lock)
 927     {
 928       *lock = false;
 929       if (stat)
 930         *stat = 0;
 931       return;
 932     }
 933
 934   if (stat)
 935     {
 936       *stat = 1;
 937       if (errmsg_len > 0)
 938         {
 939           int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 940                                                       : (int) sizeof (msg);
 941           memcpy (errmsg, msg, len);
 942           if (errmsg_len > len)
 943             memset (&errmsg[len], ' ', errmsg_len-len);
 944         }
 945       return;
 946     }
 947   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
 948 }