libgfortran/caf/single.c

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