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