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   local = malloc (size);
 104   *token = malloc (sizeof (single_token_t));
 105
 106   if (unlikely (local == NULL || token == NULL))
 107     {
 108       const char msg[] = "Failed to allocate coarray";
 109       if (stat)
 110         {
 111           *stat = 1;
 112           if (errmsg_len > 0)
 113             {
 114               int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
 115                                                           : (int) sizeof (msg);
 116               memcpy (errmsg, msg, len);
 117               if (errmsg_len > len)
 118                 memset (&errmsg[len], ' ', errmsg_len-len);
 119             }
 120           return NULL;
 121         }
 122       else
 123           caf_runtime_error (msg);
 124     }
 125
 126   *token = local;
 127
 128   if (stat)
 129     *stat = 0;
 130
 131   if (type == CAF_REGTYPE_COARRAY_STATIC)
 132     {
 133       caf_static_t *tmp = malloc (sizeof (caf_static_t));
 134       tmp->prev  = caf_static_list;
 135       tmp->token = *token;
 136       caf_static_list = tmp;
 137     }
 138   return local;
 139 }
 140
 141
 142 void
 143 _gfortran_caf_deregister (caf_token_t *token, int *stat,
 144                           char *errmsg __attribute__ ((unused)),
 145                           int errmsg_len __attribute__ ((unused)))
 146 {
 147   free (TOKEN(*token));
 148
 149   if (stat)
 150     *stat = 0;
 151 }
 152
 153
 154 void
 155 _gfortran_caf_sync_all (int *stat,
 156                         char *errmsg __attribute__ ((unused)),
 157                         int errmsg_len __attribute__ ((unused)))
 158 {
 159   if (stat)
 160     *stat = 0;
 161 }
 162
 163
 164 void
 165 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
 166                            int images[] __attribute__ ((unused)),
 167                            int *stat,
 168                            char *errmsg __attribute__ ((unused)),
 169                            int errmsg_len __attribute__ ((unused)))
 170 {
 171 #ifdef GFC_CAF_CHECK
 172   int i;
 173
 174   for (i = 0; i < count; i++)
 175     if (images[i] != 1)
 176       {
 177         fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
 178                  "IMAGES", images[i]);
 179         exit (EXIT_FAILURE);
 180       }
 181 #endif
 182
 183   if (stat)
 184     *stat = 0;
 185 }
 186
 187
 188 void
 189 _gfortran_caf_error_stop_str (const char *string, int32_t len)
 190 {
 191   fputs ("ERROR STOP ", stderr);
 192   while (len--)
 193     fputc (*(string++), stderr);
 194   fputs ("\n", stderr);
 195
 196   exit (1);
 197 }
 198
 199
 200 void
 201 _gfortran_caf_error_stop (int32_t error)
 202 {
 203   fprintf (stderr, "ERROR STOP %d\n", error);
 204   exit (error);
 205 }
 206
 207
 208 void
 209 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
 210                       int result_image __attribute__ ((unused)),
 211                       int *stat, char *errmsg __attribute__ ((unused)),
 212                       int errmsg_len __attribute__ ((unused)))
 213 {
 214   if (stat)
 215     *stat = 0;
 216 }
 217
 218 void
 219 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
 220                       int result_image __attribute__ ((unused)),
 221                       int *stat, char *errmsg __attribute__ ((unused)),
 222                       int src_len __attribute__ ((unused)),
 223                       int errmsg_len __attribute__ ((unused)))
 224 {
 225   if (stat)
 226     *stat = 0;
 227 }
 228
 229 void
 230 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
 231                       int result_image __attribute__ ((unused)),
 232                       int *stat, char *errmsg __attribute__ ((unused)),
 233                       int src_len __attribute__ ((unused)),
 234                       int errmsg_len __attribute__ ((unused)))
 235 {
 236   if (stat)
 237     *stat = 0;
 238 }
 239
 240
 241 static void
 242 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
 243                          unsigned char *src)
 244 {
 245   size_t i, n;
 246   n = dst_size/4 > src_size ? src_size : dst_size/4;
 247   for (i = 0; i < n; ++i)
 248     dst[i] = (int32_t) src[i];
 249   for (; i < dst_size/4; ++i)
 250     dst[i] = (int32_t) ' ';
 251 }
 252
 253
 254 static void
 255 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
 256                          uint32_t *src)
 257 {
 258   size_t i, n;
 259   n = dst_size > src_size/4 ? src_size/4 : dst_size;
 260   for (i = 0; i < n; ++i)
 261     dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
 262   if (dst_size > n)
 263     memset(&dst[n], ' ', dst_size - n);
 264 }
 265
 266
 267 static void
 268 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
 269               int src_kind)
 270 {
 271 #ifdef HAVE_GFC_INTEGER_16
 272   typedef __int128 int128t;
 273 #else
 274   typedef int64_t int128t;
 275 #endif
 276
 277 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
 278   typedef long double real128t;
 279   typedef _Complex long double complex128t;
 280 #elif defined(HAVE_GFC_REAL_16)
 281   typedef _Complex float __attribute__((mode(TC))) __complex128;
 282   typedef __float128 real128t;
 283   typedef __complex128 complex128t;
 284 #elif defined(HAVE_GFC_REAL_10)
 285   typedef long double real128t;
 286   typedef long double complex128t;
 287 #else
 288   typedef double real128t;
 289   typedef _Complex double complex128t;
 290 #endif
 291
 292   int128t int_val = 0;
 293   real128t real_val = 0;
 294   complex128t cmpx_val = 0;
 295
 296   switch (src_type)
 297     {
 298     case BT_INTEGER:
 299       if (src_kind == 1)
 300         int_val = *(int8_t*) src;
 301       else if (src_kind == 2)
 302         int_val = *(int16_t*) src;
 303       else if (src_kind == 4)
 304         int_val = *(int32_t*) src;
 305       else if (src_kind == 8)
 306         int_val = *(int64_t*) src;
 307 #ifdef HAVE_GFC_INTEGER_16
 308       else if (src_kind == 16)
 309         int_val = *(int128t*) src;
 310 #endif
 311       else
 312         goto error;
 313       break;
 314     case BT_REAL:
 315       if (src_kind == 4)
 316         real_val = *(float*) src;
 317       else if (src_kind == 8)
 318         real_val = *(double*) src;
 319 #ifdef HAVE_GFC_REAL_10
 320       else if (src_kind == 10)
 321         real_val = *(long double*) src;
 322 #endif
 323 #ifdef HAVE_GFC_REAL_16
 324       else if (src_kind == 16)
 325         real_val = *(real128t*) src;
 326 #endif
 327       else
 328         goto error;
 329       break;
 330     case BT_COMPLEX:
 331       if (src_kind == 4)
 332         cmpx_val = *(_Complex float*) src;
 333       else if (src_kind == 8)
 334         cmpx_val = *(_Complex double*) src;
 335 #ifdef HAVE_GFC_REAL_10
 336       else if (src_kind == 10)
 337         cmpx_val = *(_Complex long double*) src;
 338 #endif
 339 #ifdef HAVE_GFC_REAL_16
 340       else if (src_kind == 16)
 341         cmpx_val = *(complex128t*) src;
 342 #endif
 343       else
 344         goto error;
 345       break;
 346     default:
 347       goto error;
 348     }
 349
 350   switch (dst_type)
 351     {
 352     case BT_INTEGER:
 353       if (src_type == BT_INTEGER)
 354         {
 355           if (dst_kind == 1)
 356             *(int8_t*) dst = (int8_t) int_val;
 357           else if (dst_kind == 2)
 358             *(int16_t*) dst = (int16_t) int_val;
 359           else if (dst_kind == 4)
 360             *(int32_t*) dst = (int32_t) int_val;
 361           else if (dst_kind == 8)
 362             *(int64_t*) dst = (int64_t) int_val;
 363 #ifdef HAVE_GFC_INTEGER_16
 364           else if (dst_kind == 16)
 365             *(int128t*) dst = (int128t) int_val;
 366 #endif
 367           else
 368             goto error;
 369         }
 370       else if (src_type == BT_REAL)
 371         {
 372           if (dst_kind == 1)
 373             *(int8_t*) dst = (int8_t) real_val;
 374           else if (dst_kind == 2)
 375             *(int16_t*) dst = (int16_t) real_val;
 376           else if (dst_kind == 4)
 377             *(int32_t*) dst = (int32_t) real_val;
 378           else if (dst_kind == 8)
 379             *(int64_t*) dst = (int64_t) real_val;
 380 #ifdef HAVE_GFC_INTEGER_16
 381           else if (dst_kind == 16)
 382             *(int128t*) dst = (int128t) real_val;
 383 #endif
 384           else
 385             goto error;
 386         }
 387       else if (src_type == BT_COMPLEX)
 388         {
 389           if (dst_kind == 1)
 390             *(int8_t*) dst = (int8_t) cmpx_val;
 391           else if (dst_kind == 2)
 392             *(int16_t*) dst = (int16_t) cmpx_val;
 393           else if (dst_kind == 4)
 394             *(int32_t*) dst = (int32_t) cmpx_val;
 395           else if (dst_kind == 8)
 396             *(int64_t*) dst = (int64_t) cmpx_val;
 397 #ifdef HAVE_GFC_INTEGER_16
 398           else if (dst_kind == 16)
 399             *(int128t*) dst = (int128t) cmpx_val;
 400 #endif
 401           else
 402             goto error;
 403         }
 404       else
 405         goto error;
 406       break;
 407     case BT_REAL:
 408       if (src_type == BT_INTEGER)
 409         {
 410           if (dst_kind == 4)
 411             *(float*) dst = (float) int_val;
 412           else if (dst_kind == 8)
 413             *(double*) dst = (double) int_val;
 414 #ifdef HAVE_GFC_REAL_10
 415           else if (dst_kind == 10)
 416             *(long double*) dst = (long double) int_val;
 417 #endif
 418 #ifdef HAVE_GFC_REAL_16
 419           else if (dst_kind == 16)
 420             *(real128t*) dst = (real128t) int_val;
 421 #endif
 422           else
 423             goto error;
 424         }
 425       else if (src_type == BT_REAL)
 426         {
 427           if (dst_kind == 4)
 428             *(float*) dst = (float) real_val;
 429           else if (dst_kind == 8)
 430             *(double*) dst = (double) real_val;
 431 #ifdef HAVE_GFC_REAL_10
 432           else if (dst_kind == 10)
 433             *(long double*) dst = (long double) real_val;
 434 #endif
 435 #ifdef HAVE_GFC_REAL_16
 436           else if (dst_kind == 16)
 437             *(real128t*) dst = (real128t) real_val;
 438 #endif
 439           else
 440             goto error;
 441         }
 442       else if (src_type == BT_COMPLEX)
 443         {
 444           if (dst_kind == 4)
 445             *(float*) dst = (float) cmpx_val;
 446           else if (dst_kind == 8)
 447             *(double*) dst = (double) cmpx_val;
 448 #ifdef HAVE_GFC_REAL_10
 449           else if (dst_kind == 10)
 450             *(long double*) dst = (long double) cmpx_val;
 451 #endif
 452 #ifdef HAVE_GFC_REAL_16
 453           else if (dst_kind == 16)
 454             *(real128t*) dst = (real128t) cmpx_val;
 455 #endif
 456           else
 457             goto error;
 458         }
 459       break;
 460     case BT_COMPLEX:
 461       if (src_type == BT_INTEGER)
 462         {
 463           if (dst_kind == 4)
 464             *(_Complex float*) dst = (_Complex float) int_val;
 465           else if (dst_kind == 8)
 466             *(_Complex double*) dst = (_Complex double) int_val;
 467 #ifdef HAVE_GFC_REAL_10
 468           else if (dst_kind == 10)
 469             *(_Complex long double*) dst = (_Complex long double) int_val;
 470 #endif
 471 #ifdef HAVE_GFC_REAL_16
 472           else if (dst_kind == 16)
 473             *(complex128t*) dst = (complex128t) int_val;
 474 #endif
 475           else
 476             goto error;
 477         }
 478       else if (src_type == BT_REAL)
 479         {
 480           if (dst_kind == 4)
 481             *(_Complex float*) dst = (_Complex float) real_val;
 482           else if (dst_kind == 8)
 483             *(_Complex double*) dst = (_Complex double) real_val;
 484 #ifdef HAVE_GFC_REAL_10
 485           else if (dst_kind == 10)
 486             *(_Complex long double*) dst = (_Complex long double) real_val;
 487 #endif
 488 #ifdef HAVE_GFC_REAL_16
 489           else if (dst_kind == 16)
 490             *(complex128t*) dst = (complex128t) real_val;
 491 #endif
 492           else
 493             goto error;
 494         }
 495       else if (src_type == BT_COMPLEX)
 496         {
 497           if (dst_kind == 4)
 498             *(_Complex float*) dst = (_Complex float) cmpx_val;
 499           else if (dst_kind == 8)
 500             *(_Complex double*) dst = (_Complex double) cmpx_val;
 501 #ifdef HAVE_GFC_REAL_10
 502           else if (dst_kind == 10)
 503             *(_Complex long double*) dst = (_Complex long double) cmpx_val;
 504 #endif
 505 #ifdef HAVE_GFC_REAL_16
 506           else if (dst_kind == 16)
 507             *(complex128t*) dst = (complex128t) cmpx_val;
 508 #endif
 509           else
 510             goto error;
 511         }
 512       else
 513         goto error;
 514       break;
 515     default:
 516       goto error;
 517     }
 518
 519 error:
 520   fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
 521            "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
 522   abort();
 523 }
 524
 525
 526 void
 527 _gfortran_caf_get (caf_token_t token, size_t offset,
 528                    int image_index __attribute__ ((unused)),
 529                    gfc_descriptor_t *src ,
 530                    caf_vector_t *src_vector __attribute__ ((unused)),
 531                    gfc_descriptor_t *dest, int src_kind, int dst_kind)
 532 {
 533   /* FIXME: Handle vector subscripts.  */
 534   size_t i, k, size;
 535   int j;
 536   int rank = GFC_DESCRIPTOR_RANK (dest);
 537   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 538   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 539
 540   if (rank == 0)
 541     {
 542       void *sr = (void *) ((char *) TOKEN (token) + offset);
 543       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 544           && dst_kind == src_kind)
 545         {
 546           memmove (GFC_DESCRIPTOR_DATA (dest), sr,
 547                    dst_size > src_size ? src_size : dst_size);
 548           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 549             {
 550               if (dst_kind == 1)
 551                 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
 552                         ' ', dst_size - src_size);
 553               else /* dst_kind == 4.  */
 554                 for (i = src_size/4; i < dst_size/4; i++)
 555                   ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
 556             }
 557         }
 558       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 559         assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 560                                  sr);
 561       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 562         assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
 563                                  sr);
 564       else
 565         convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
 566                       dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 567       return;
 568     }
 569
 570   size = 1;
 571   for (j = 0; j < rank; j++)
 572     {
 573       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 574       if (dimextent < 0)
 575         dimextent = 0;
 576       size *= dimextent;
 577     }
 578
 579   if (size == 0)
 580     return;
 581
 582   for (i = 0; i < size; i++)
 583     {
 584       ptrdiff_t array_offset_dst = 0;
 585       ptrdiff_t stride = 1;
 586       ptrdiff_t extent = 1;
 587       for (j = 0; j < rank-1; j++)
 588         {
 589           array_offset_dst += ((i / (extent*stride))
 590                                % (dest->dim[j]._ubound
 591                                   - dest->dim[j].lower_bound + 1))
 592                               * dest->dim[j]._stride;
 593           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 594           stride = dest->dim[j]._stride;
 595         }
 596       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 597       void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
 598
 599       ptrdiff_t array_offset_sr = 0;
 600       stride = 1;
 601       extent = 1;
 602       for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 603         {
 604           array_offset_sr += ((i / (extent*stride))
 605                                % (src->dim[j]._ubound
 606                                   - src->dim[j].lower_bound + 1))
 607                               * src->dim[j]._stride;
 608           extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 609           stride = src->dim[j]._stride;
 610         }
 611       array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 612       void *sr = (void *)((char *) TOKEN (token) + offset
 613                           + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 614
 615       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 616           && dst_kind == src_kind)
 617         {
 618           memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
 619           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 620             {
 621               if (dst_kind == 1)
 622                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 623               else /* dst_kind == 4.  */
 624                 for (k = src_size/4; k < dst_size/4; k++)
 625                   ((int32_t*) dst)[k] = (int32_t) ' ';
 626             }
 627         }
 628       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 629         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 630       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 631         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 632       else
 633         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 634                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 635     }
 636 }
 637
 638
 639 void
 640 _gfortran_caf_send (caf_token_t token, size_t offset,
 641                     int image_index __attribute__ ((unused)),
 642                     gfc_descriptor_t *dest,
 643                     caf_vector_t *dst_vector __attribute__ ((unused)),
 644                     gfc_descriptor_t *src, int dst_kind, int src_kind)
 645 {
 646   /* FIXME: Handle vector subscripts.  */
 647   size_t i, k, size;
 648   int j;
 649   int rank = GFC_DESCRIPTOR_RANK (dest);
 650   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
 651   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 652
 653   if (rank == 0)
 654     {
 655       void *dst = (void *) ((char *) TOKEN (token) + offset);
 656       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 657           && dst_kind == src_kind)
 658         {
 659           memmove (dst, GFC_DESCRIPTOR_DATA (src),
 660                    dst_size > src_size ? src_size : dst_size);
 661           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 662             {
 663               if (dst_kind == 1)
 664                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 665               else /* dst_kind == 4.  */
 666                 for (i = src_size/4; i < dst_size/4; i++)
 667                   ((int32_t*) dst)[i] = (int32_t) ' ';
 668             }
 669         }
 670       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 671         assign_char1_from_char4 (dst_size, src_size, dst,
 672                                  GFC_DESCRIPTOR_DATA (src));
 673       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 674         assign_char4_from_char1 (dst_size, src_size, dst,
 675                                  GFC_DESCRIPTOR_DATA (src));
 676       else
 677         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 678                       GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
 679                       src_kind);
 680       return;
 681     }
 682
 683   size = 1;
 684   for (j = 0; j < rank; j++)
 685     {
 686       ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
 687       if (dimextent < 0)
 688         dimextent = 0;
 689       size *= dimextent;
 690     }
 691
 692   if (size == 0)
 693     return;
 694
 695   for (i = 0; i < size; i++)
 696     {
 697       ptrdiff_t array_offset_dst = 0;
 698       ptrdiff_t stride = 1;
 699       ptrdiff_t extent = 1;
 700       for (j = 0; j < rank-1; j++)
 701         {
 702           array_offset_dst += ((i / (extent*stride))
 703                                % (dest->dim[j]._ubound
 704                                   - dest->dim[j].lower_bound + 1))
 705                               * dest->dim[j]._stride;
 706           extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
 707           stride = dest->dim[j]._stride;
 708         }
 709       array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
 710       void *dst = (void *)((char *) TOKEN (token) + offset
 711                            + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
 712       void *sr;
 713       if (GFC_DESCRIPTOR_RANK (src) != 0)
 714         {
 715           ptrdiff_t array_offset_sr = 0;
 716           stride = 1;
 717           extent = 1;
 718           for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
 719             {
 720               array_offset_sr += ((i / (extent*stride))
 721                                   % (src->dim[j]._ubound
 722                                      - src->dim[j].lower_bound + 1))
 723                                  * src->dim[j]._stride;
 724               extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
 725               stride = src->dim[j]._stride;
 726             }
 727           array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
 728           sr = (void *)((char *) src->base_addr
 729                         + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
 730         }
 731       else
 732         sr = src->base_addr;
 733
 734       if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
 735           && dst_kind == src_kind)
 736         {
 737           memmove (dst, sr,
 738                    dst_size > src_size ? src_size : dst_size);
 739           if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
 740             {
 741               if (dst_kind == 1)
 742                 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
 743               else /* dst_kind == 4.  */
 744                 for (k = src_size/4; k < dst_size/4; k++)
 745                   ((int32_t*) dst)[k] = (int32_t) ' ';
 746             }
 747         }
 748       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
 749         assign_char1_from_char4 (dst_size, src_size, dst, sr);
 750       else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
 751         assign_char4_from_char1 (dst_size, src_size, dst, sr);
 752       else
 753         convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
 754                       sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
 755     }
 756 }
 757
 758
 759 void
 760 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 761                        int dst_image_index, gfc_descriptor_t *dest,
 762                        caf_vector_t *dst_vector, caf_token_t src_token,
 763                        size_t src_offset,
 764                        int src_image_index __attribute__ ((unused)),
 765                        gfc_descriptor_t *src,
 766                        caf_vector_t *src_vector __attribute__ ((unused)),
 767                        int dst_len, int src_len)
 768 {
 769   /* FIXME: Handle vector subscript of 'src_vector'.  */
 770   /* For a single image, src->base_addr should be the same as src_token + offset
 771      but to play save, we do it properly.  */
 772   void *src_base = GFC_DESCRIPTOR_DATA (src);
 773   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
 774   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
 775                       src, dst_len, src_len);
 776   GFC_DESCRIPTOR_DATA (src) = src_base;
 777 }
 778
 779
 780 void
 781 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
 782                              int image_index __attribute__ ((unused)),
 783                              void *value, int *stat,
 784                              int type __attribute__ ((unused)), int kind)
 785 {
 786   assert(kind == 4);
 787
 788   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 789
 790   __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 791
 792   if (stat)
 793     *stat = 0;
 794 }
 795
 796 void
 797 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
 798                           int image_index __attribute__ ((unused)),
 799                           void *value, int *stat,
 800                           int type __attribute__ ((unused)), int kind)
 801 {
 802   assert(kind == 4);
 803
 804   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 805
 806   __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
 807
 808   if (stat)
 809     *stat = 0;
 810 }
 811
 812
 813 void
 814 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
 815                           int image_index __attribute__ ((unused)),
 816                           void *old, void *compare, void *new_val, int *stat,
 817                           int type __attribute__ ((unused)), int kind)
 818 {
 819   assert(kind == 4);
 820
 821   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 822
 823   *(uint32_t *) old = *(uint32_t *) compare;
 824   (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
 825                                       *(uint32_t *) new_val, false,
 826                                       __ATOMIC_RELAXED, __ATOMIC_RELAXED);
 827   if (stat)
 828     *stat = 0;
 829 }
 830
 831
 832 void
 833 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
 834                          int image_index __attribute__ ((unused)),
 835                          void *value, void *old, int *stat,
 836                          int type __attribute__ ((unused)), int kind)
 837 {
 838   assert(kind == 4);
 839
 840   uint32_t res;
 841   uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
 842
 843   switch (op)
 844     {
 845     case GFC_CAF_ATOMIC_ADD:
 846       res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 847       break;
 848     case GFC_CAF_ATOMIC_AND:
 849       res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 850       break;
 851     case GFC_CAF_ATOMIC_OR:
 852       res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 853       break;
 854     case GFC_CAF_ATOMIC_XOR:
 855       res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
 856       break;
 857     default:
 858       __builtin_unreachable();
 859     }
 860
 861   if (old)
 862     *(uint32_t *) old = res;
 863
 864   if (stat)
 865     *stat = 0;
 866 }