1/* Single-image implementation of GNU Fortran Coarray Library 2 Copyright (C) 2011-2022 Free Software Foundation, Inc. 3 Contributed by Tobias Burnus <burnus@net-b.de> 4 5This file is part of the GNU Fortran Coarray Runtime Library (libcaf). 6 7Libcaf is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 3, or (at your option) 10any later version. 11 12Libcaf is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 <stdint.h> 32#include <assert.h> 33 34/* Define GFC_CAF_CHECK to enable run-time checking. */ 35/* #define GFC_CAF_CHECK 1 */ 36 37struct caf_single_token 38{ 39 /* The pointer to the memory registered. For arrays this is the data member 40 in the descriptor. For components it's the pure data pointer. */ 41 void *memptr; 42 /* The descriptor when this token is associated to an allocatable array. */ 43 gfc_descriptor_t *desc; 44 /* Set when the caf lib has allocated the memory in memptr and is responsible 45 for freeing it on deregister. */ 46 bool owning_memory; 47}; 48typedef struct caf_single_token *caf_single_token_t; 49 50#define TOKEN(X) ((caf_single_token_t) (X)) 51#define MEMTOK(X) ((caf_single_token_t) (X))->memptr 52 53/* Single-image implementation of the CAF library. 54 Note: For performance reasons -fcoarry=single should be used 55 rather than this library. */ 56 57/* Global variables. */ 58caf_static_t *caf_static_list = NULL; 59 60/* Keep in sync with mpi.c. */ 61static void 62caf_runtime_error (const char *message, ...) 63{ 64 va_list ap; 65 fprintf (stderr, "Fortran runtime error: "); 66 va_start (ap, message); 67 vfprintf (stderr, message, ap); 68 va_end (ap); 69 fprintf (stderr, "\n"); 70 71 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */ 72 exit (EXIT_FAILURE); 73} 74 75/* Error handling is similar everytime. */ 76static void 77caf_internal_error (const char *msg, int *stat, char *errmsg, 78 size_t errmsg_len, ...) 79{ 80 va_list args; 81 va_start (args, errmsg_len); 82 if (stat) 83 { 84 *stat = 1; 85 if (errmsg_len > 0) 86 { 87 int len = snprintf (errmsg, errmsg_len, msg, args); 88 if (len >= 0 && errmsg_len > (size_t) len) 89 memset (&errmsg[len], ' ', errmsg_len - len); 90 } 91 va_end (args); 92 return; 93 } 94 else 95 caf_runtime_error (msg, args); 96 va_end (args); 97} 98 99 100void 101_gfortran_caf_init (int *argc __attribute__ ((unused)), 102 char ***argv __attribute__ ((unused))) 103{ 104} 105 106 107void 108_gfortran_caf_finalize (void) 109{ 110 while (caf_static_list != NULL) 111 { 112 caf_static_t *tmp = caf_static_list->prev; 113 free (caf_static_list->token); 114 free (caf_static_list); 115 caf_static_list = tmp; 116 } 117} 118 119 120int 121_gfortran_caf_this_image (int distance __attribute__ ((unused))) 122{ 123 return 1; 124} 125 126 127int 128_gfortran_caf_num_images (int distance __attribute__ ((unused)), 129 int failed __attribute__ ((unused))) 130{ 131 return 1; 132} 133 134 135void 136_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, 137 gfc_descriptor_t *data, int *stat, char *errmsg, 138 size_t errmsg_len) 139{ 140 const char alloc_fail_msg[] = "Failed to allocate coarray"; 141 void *local; 142 caf_single_token_t single_token; 143 144 if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC 145 || type == CAF_REGTYPE_CRITICAL) 146 local = calloc (size, sizeof (bool)); 147 else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC) 148 /* In the event_(wait|post) function the counter for events is a uint32, 149 so better allocate enough memory here. */ 150 local = calloc (size, sizeof (uint32_t)); 151 else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY) 152 local = NULL; 153 else 154 local = malloc (size); 155 156 if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY) 157 *token = malloc (sizeof (struct caf_single_token)); 158 159 if (unlikely (*token == NULL 160 || (local == NULL 161 && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY))) 162 { 163 /* Freeing the memory conditionally seems pointless, but 164 caf_internal_error () may return, when a stat is given and then the 165 memory may be lost. */ 166 if (local) 167 free (local); 168 if (*token) 169 free (*token); 170 caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len); 171 return; 172 } 173 174 single_token = TOKEN (*token); 175 single_token->memptr = local; 176 single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY; 177 single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL; 178 179 180 if (stat) 181 *stat = 0; 182 183 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC 184 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC 185 || type == CAF_REGTYPE_EVENT_ALLOC) 186 { 187 caf_static_t *tmp = malloc (sizeof (caf_static_t)); 188 tmp->prev = caf_static_list; 189 tmp->token = *token; 190 caf_static_list = tmp; 191 } 192 GFC_DESCRIPTOR_DATA (data) = local; 193} 194 195 196void 197_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, 198 char *errmsg __attribute__ ((unused)), 199 size_t errmsg_len __attribute__ ((unused))) 200{ 201 caf_single_token_t single_token = TOKEN (*token); 202 203 if (single_token->owning_memory && single_token->memptr) 204 free (single_token->memptr); 205 206 if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) 207 { 208 free (TOKEN (*token)); 209 *token = NULL; 210 } 211 else 212 { 213 single_token->memptr = NULL; 214 single_token->owning_memory = false; 215 } 216 217 if (stat) 218 *stat = 0; 219} 220 221 222void 223_gfortran_caf_sync_all (int *stat, 224 char *errmsg __attribute__ ((unused)), 225 size_t errmsg_len __attribute__ ((unused))) 226{ 227 __asm__ __volatile__ ("":::"memory"); 228 if (stat) 229 *stat = 0; 230} 231 232 233void 234_gfortran_caf_sync_memory (int *stat, 235 char *errmsg __attribute__ ((unused)), 236 size_t errmsg_len __attribute__ ((unused))) 237{ 238 __asm__ __volatile__ ("":::"memory"); 239 if (stat) 240 *stat = 0; 241} 242 243 244void 245_gfortran_caf_sync_images (int count __attribute__ ((unused)), 246 int images[] __attribute__ ((unused)), 247 int *stat, 248 char *errmsg __attribute__ ((unused)), 249 size_t errmsg_len __attribute__ ((unused))) 250{ 251#ifdef GFC_CAF_CHECK 252 int i; 253 254 for (i = 0; i < count; i++) 255 if (images[i] != 1) 256 { 257 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC " 258 "IMAGES", images[i]); 259 exit (EXIT_FAILURE); 260 } 261#endif 262 263 __asm__ __volatile__ ("":::"memory"); 264 if (stat) 265 *stat = 0; 266} 267 268 269void 270_gfortran_caf_stop_numeric(int stop_code, bool quiet) 271{ 272 if (!quiet) 273 fprintf (stderr, "STOP %d\n", stop_code); 274 exit (0); 275} 276 277 278void 279_gfortran_caf_stop_str(const char *string, size_t len, bool quiet) 280{ 281 if (!quiet) 282 { 283 fputs ("STOP ", stderr); 284 while (len--) 285 fputc (*(string++), stderr); 286 fputs ("\n", stderr); 287 } 288 exit (0); 289} 290 291 292void 293_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet) 294{ 295 if (!quiet) 296 { 297 fputs ("ERROR STOP ", stderr); 298 while (len--) 299 fputc (*(string++), stderr); 300 fputs ("\n", stderr); 301 } 302 exit (1); 303} 304 305 306/* Reported that the program terminated because of a fail image issued. 307 Because this is a single image library, nothing else than aborting the whole 308 program can be done. */ 309 310void _gfortran_caf_fail_image (void) 311{ 312 fputs ("IMAGE FAILED!\n", stderr); 313 exit (0); 314} 315 316 317/* Get the status of image IMAGE. Because being the single image library all 318 other images are reported to be stopped. */ 319 320int _gfortran_caf_image_status (int image, 321 caf_team_t * team __attribute__ ((unused))) 322{ 323 if (image == 1) 324 return 0; 325 else 326 return CAF_STAT_STOPPED_IMAGE; 327} 328 329 330/* Single image library. There cannot be any failed images with only one 331 image. */ 332 333void 334_gfortran_caf_failed_images (gfc_descriptor_t *array, 335 caf_team_t * team __attribute__ ((unused)), 336 int * kind) 337{ 338 int local_kind = kind != NULL ? *kind : 4; 339 340 array->base_addr = NULL; 341 array->dtype.type = BT_INTEGER; 342 array->dtype.elem_len = local_kind; 343 /* Setting lower_bound higher then upper_bound is what the compiler does to 344 indicate an empty array. */ 345 array->dim[0].lower_bound = 0; 346 array->dim[0]._ubound = -1; 347 array->dim[0]._stride = 1; 348 array->offset = 0; 349} 350 351 352/* With only one image available no other images can be stopped. Therefore 353 return an empty array. */ 354 355void 356_gfortran_caf_stopped_images (gfc_descriptor_t *array, 357 caf_team_t * team __attribute__ ((unused)), 358 int * kind) 359{ 360 int local_kind = kind != NULL ? *kind : 4; 361 362 array->base_addr = NULL; 363 array->dtype.type = BT_INTEGER; 364 array->dtype.elem_len = local_kind; 365 /* Setting lower_bound higher then upper_bound is what the compiler does to 366 indicate an empty array. */ 367 array->dim[0].lower_bound = 0; 368 array->dim[0]._ubound = -1; 369 array->dim[0]._stride = 1; 370 array->offset = 0; 371} 372 373 374void 375_gfortran_caf_error_stop (int error, bool quiet) 376{ 377 if (!quiet) 378 fprintf (stderr, "ERROR STOP %d\n", error); 379 exit (error); 380} 381 382 383void 384_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)), 385 int source_image __attribute__ ((unused)), 386 int *stat, char *errmsg __attribute__ ((unused)), 387 size_t errmsg_len __attribute__ ((unused))) 388{ 389 if (stat) 390 *stat = 0; 391} 392 393void 394_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)), 395 int result_image __attribute__ ((unused)), 396 int *stat, char *errmsg __attribute__ ((unused)), 397 size_t errmsg_len __attribute__ ((unused))) 398{ 399 if (stat) 400 *stat = 0; 401} 402 403void 404_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)), 405 int result_image __attribute__ ((unused)), 406 int *stat, char *errmsg __attribute__ ((unused)), 407 int a_len __attribute__ ((unused)), 408 size_t errmsg_len __attribute__ ((unused))) 409{ 410 if (stat) 411 *stat = 0; 412} 413 414void 415_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)), 416 int result_image __attribute__ ((unused)), 417 int *stat, char *errmsg __attribute__ ((unused)), 418 int a_len __attribute__ ((unused)), 419 size_t errmsg_len __attribute__ ((unused))) 420{ 421 if (stat) 422 *stat = 0; 423} 424 425 426void 427_gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)), 428 void * (*opr) (void *, void *) 429 __attribute__ ((unused)), 430 int opr_flags __attribute__ ((unused)), 431 int result_image __attribute__ ((unused)), 432 int *stat, char *errmsg __attribute__ ((unused)), 433 int a_len __attribute__ ((unused)), 434 size_t errmsg_len __attribute__ ((unused))) 435 { 436 if (stat) 437 *stat = 0; 438 } 439 440 441static void 442assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst, 443 unsigned char *src) 444{ 445 size_t i, n; 446 n = dst_size/4 > src_size ? src_size : dst_size/4; 447 for (i = 0; i < n; ++i) 448 dst[i] = (int32_t) src[i]; 449 for (; i < dst_size/4; ++i) 450 dst[i] = (int32_t) ' '; 451} 452 453 454static void 455assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst, 456 uint32_t *src) 457{ 458 size_t i, n; 459 n = dst_size > src_size/4 ? src_size/4 : dst_size; 460 for (i = 0; i < n; ++i) 461 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i]; 462 if (dst_size > n) 463 memset (&dst[n], ' ', dst_size - n); 464} 465 466 467static void 468convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type, 469 int src_kind, int *stat) 470{ 471#ifdef HAVE_GFC_INTEGER_16 472 typedef __int128 int128t; 473#else 474 typedef int64_t int128t; 475#endif 476 477#if defined(GFC_REAL_16_IS_LONG_DOUBLE) 478 typedef long double real128t; 479 typedef _Complex long double complex128t; 480#elif defined(HAVE_GFC_REAL_16) 481 typedef _Complex float __attribute__((mode(TC))) __complex128; 482 typedef __float128 real128t; 483 typedef __complex128 complex128t; 484#elif defined(HAVE_GFC_REAL_10) 485 typedef long double real128t; 486 typedef long double complex128t; 487#else 488 typedef double real128t; 489 typedef _Complex double complex128t; 490#endif 491 492 int128t int_val = 0; 493 real128t real_val = 0; 494 complex128t cmpx_val = 0; 495 496 switch (src_type) 497 { 498 case BT_INTEGER: 499 if (src_kind == 1) 500 int_val = *(int8_t*) src; 501 else if (src_kind == 2) 502 int_val = *(int16_t*) src; 503 else if (src_kind == 4) 504 int_val = *(int32_t*) src; 505 else if (src_kind == 8) 506 int_val = *(int64_t*) src; 507#ifdef HAVE_GFC_INTEGER_16 508 else if (src_kind == 16) 509 int_val = *(int128t*) src; 510#endif 511 else 512 goto error; 513 break; 514 case BT_REAL: 515 if (src_kind == 4) 516 real_val = *(float*) src; 517 else if (src_kind == 8) 518 real_val = *(double*) src; 519#ifdef HAVE_GFC_REAL_10 520 else if (src_kind == 10) 521 real_val = *(long double*) src; 522#endif 523#ifdef HAVE_GFC_REAL_16 524 else if (src_kind == 16) 525 real_val = *(real128t*) src; 526#endif 527 else 528 goto error; 529 break; 530 case BT_COMPLEX: 531 if (src_kind == 4) 532 cmpx_val = *(_Complex float*) src; 533 else if (src_kind == 8) 534 cmpx_val = *(_Complex double*) src; 535#ifdef HAVE_GFC_REAL_10 536 else if (src_kind == 10) 537 cmpx_val = *(_Complex long double*) src; 538#endif 539#ifdef HAVE_GFC_REAL_16 540 else if (src_kind == 16) 541 cmpx_val = *(complex128t*) src; 542#endif 543 else 544 goto error; 545 break; 546 default: 547 goto error; 548 } 549 550 switch (dst_type) 551 { 552 case BT_INTEGER: 553 if (src_type == BT_INTEGER) 554 { 555 if (dst_kind == 1) 556 *(int8_t*) dst = (int8_t) int_val; 557 else if (dst_kind == 2) 558 *(int16_t*) dst = (int16_t) int_val; 559 else if (dst_kind == 4) 560 *(int32_t*) dst = (int32_t) int_val; 561 else if (dst_kind == 8) 562 *(int64_t*) dst = (int64_t) int_val; 563#ifdef HAVE_GFC_INTEGER_16 564 else if (dst_kind == 16) 565 *(int128t*) dst = (int128t) int_val; 566#endif 567 else 568 goto error; 569 } 570 else if (src_type == BT_REAL) 571 { 572 if (dst_kind == 1) 573 *(int8_t*) dst = (int8_t) real_val; 574 else if (dst_kind == 2) 575 *(int16_t*) dst = (int16_t) real_val; 576 else if (dst_kind == 4) 577 *(int32_t*) dst = (int32_t) real_val; 578 else if (dst_kind == 8) 579 *(int64_t*) dst = (int64_t) real_val; 580#ifdef HAVE_GFC_INTEGER_16 581 else if (dst_kind == 16) 582 *(int128t*) dst = (int128t) real_val; 583#endif 584 else 585 goto error; 586 } 587 else if (src_type == BT_COMPLEX) 588 { 589 if (dst_kind == 1) 590 *(int8_t*) dst = (int8_t) cmpx_val; 591 else if (dst_kind == 2) 592 *(int16_t*) dst = (int16_t) cmpx_val; 593 else if (dst_kind == 4) 594 *(int32_t*) dst = (int32_t) cmpx_val; 595 else if (dst_kind == 8) 596 *(int64_t*) dst = (int64_t) cmpx_val; 597#ifdef HAVE_GFC_INTEGER_16 598 else if (dst_kind == 16) 599 *(int128t*) dst = (int128t) cmpx_val; 600#endif 601 else 602 goto error; 603 } 604 else 605 goto error; 606 return; 607 case BT_REAL: 608 if (src_type == BT_INTEGER) 609 { 610 if (dst_kind == 4) 611 *(float*) dst = (float) int_val; 612 else if (dst_kind == 8) 613 *(double*) dst = (double) int_val; 614#ifdef HAVE_GFC_REAL_10 615 else if (dst_kind == 10) 616 *(long double*) dst = (long double) int_val; 617#endif 618#ifdef HAVE_GFC_REAL_16 619 else if (dst_kind == 16) 620 *(real128t*) dst = (real128t) int_val; 621#endif 622 else 623 goto error; 624 } 625 else if (src_type == BT_REAL) 626 { 627 if (dst_kind == 4) 628 *(float*) dst = (float) real_val; 629 else if (dst_kind == 8) 630 *(double*) dst = (double) real_val; 631#ifdef HAVE_GFC_REAL_10 632 else if (dst_kind == 10) 633 *(long double*) dst = (long double) real_val; 634#endif 635#ifdef HAVE_GFC_REAL_16 636 else if (dst_kind == 16) 637 *(real128t*) dst = (real128t) real_val; 638#endif 639 else 640 goto error; 641 } 642 else if (src_type == BT_COMPLEX) 643 { 644 if (dst_kind == 4) 645 *(float*) dst = (float) cmpx_val; 646 else if (dst_kind == 8) 647 *(double*) dst = (double) cmpx_val; 648#ifdef HAVE_GFC_REAL_10 649 else if (dst_kind == 10) 650 *(long double*) dst = (long double) cmpx_val; 651#endif 652#ifdef HAVE_GFC_REAL_16 653 else if (dst_kind == 16) 654 *(real128t*) dst = (real128t) cmpx_val; 655#endif 656 else 657 goto error; 658 } 659 return; 660 case BT_COMPLEX: 661 if (src_type == BT_INTEGER) 662 { 663 if (dst_kind == 4) 664 *(_Complex float*) dst = (_Complex float) int_val; 665 else if (dst_kind == 8) 666 *(_Complex double*) dst = (_Complex double) int_val; 667#ifdef HAVE_GFC_REAL_10 668 else if (dst_kind == 10) 669 *(_Complex long double*) dst = (_Complex long double) int_val; 670#endif 671#ifdef HAVE_GFC_REAL_16 672 else if (dst_kind == 16) 673 *(complex128t*) dst = (complex128t) int_val; 674#endif 675 else 676 goto error; 677 } 678 else if (src_type == BT_REAL) 679 { 680 if (dst_kind == 4) 681 *(_Complex float*) dst = (_Complex float) real_val; 682 else if (dst_kind == 8) 683 *(_Complex double*) dst = (_Complex double) real_val; 684#ifdef HAVE_GFC_REAL_10 685 else if (dst_kind == 10) 686 *(_Complex long double*) dst = (_Complex long double) real_val; 687#endif 688#ifdef HAVE_GFC_REAL_16 689 else if (dst_kind == 16) 690 *(complex128t*) dst = (complex128t) real_val; 691#endif 692 else 693 goto error; 694 } 695 else if (src_type == BT_COMPLEX) 696 { 697 if (dst_kind == 4) 698 *(_Complex float*) dst = (_Complex float) cmpx_val; 699 else if (dst_kind == 8) 700 *(_Complex double*) dst = (_Complex double) cmpx_val; 701#ifdef HAVE_GFC_REAL_10 702 else if (dst_kind == 10) 703 *(_Complex long double*) dst = (_Complex long double) cmpx_val; 704#endif 705#ifdef HAVE_GFC_REAL_16 706 else if (dst_kind == 16) 707 *(complex128t*) dst = (complex128t) cmpx_val; 708#endif 709 else 710 goto error; 711 } 712 else 713 goto error; 714 return; 715 default: 716 goto error; 717 } 718 719error: 720 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind " 721 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind); 722 if (stat) 723 *stat = 1; 724 else 725 abort (); 726} 727 728 729void 730_gfortran_caf_get (caf_token_t token, size_t offset, 731 int image_index __attribute__ ((unused)), 732 gfc_descriptor_t *src, 733 caf_vector_t *src_vector __attribute__ ((unused)), 734 gfc_descriptor_t *dest, int src_kind, int dst_kind, 735 bool may_require_tmp, int *stat) 736{ 737 /* FIXME: Handle vector subscripts. */ 738 size_t i, k, size; 739 int j; 740 int rank = GFC_DESCRIPTOR_RANK (dest); 741 size_t src_size = GFC_DESCRIPTOR_SIZE (src); 742 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); 743 744 if (stat) 745 *stat = 0; 746 747 if (rank == 0) 748 { 749 void *sr = (void *) ((char *) MEMTOK (token) + offset); 750 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 751 && dst_kind == src_kind) 752 { 753 memmove (GFC_DESCRIPTOR_DATA (dest), sr, 754 dst_size > src_size ? src_size : dst_size); 755 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size) 756 { 757 if (dst_kind == 1) 758 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size, 759 ' ', dst_size - src_size); 760 else /* dst_kind == 4. */ 761 for (i = src_size/4; i < dst_size/4; i++) 762 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' '; 763 } 764 } 765 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 766 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest), 767 sr); 768 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 769 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest), 770 sr); 771 else 772 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest), 773 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); 774 return; 775 } 776 777 size = 1; 778 for (j = 0; j < rank; j++) 779 { 780 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1; 781 if (dimextent < 0) 782 dimextent = 0; 783 size *= dimextent; 784 } 785 786 if (size == 0) 787 return; 788 789 if (may_require_tmp) 790 { 791 ptrdiff_t array_offset_sr, array_offset_dst; 792 void *tmp = malloc (size*src_size); 793 794 array_offset_dst = 0; 795 for (i = 0; i < size; i++) 796 { 797 ptrdiff_t array_offset_sr = 0; 798 ptrdiff_t stride = 1; 799 ptrdiff_t extent = 1; 800 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) 801 { 802 array_offset_sr += ((i / (extent*stride)) 803 % (src->dim[j]._ubound 804 - src->dim[j].lower_bound + 1)) 805 * src->dim[j]._stride; 806 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); 807 stride = src->dim[j]._stride; 808 } 809 array_offset_sr += (i / extent) * src->dim[rank-1]._stride; 810 void *sr = (void *)((char *) MEMTOK (token) + offset 811 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); 812 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size); 813 array_offset_dst += src_size; 814 } 815 816 array_offset_sr = 0; 817 for (i = 0; i < size; i++) 818 { 819 ptrdiff_t array_offset_dst = 0; 820 ptrdiff_t stride = 1; 821 ptrdiff_t extent = 1; 822 for (j = 0; j < rank-1; j++) 823 { 824 array_offset_dst += ((i / (extent*stride)) 825 % (dest->dim[j]._ubound 826 - dest->dim[j].lower_bound + 1)) 827 * dest->dim[j]._stride; 828 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); 829 stride = dest->dim[j]._stride; 830 } 831 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; 832 void *dst = dest->base_addr 833 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest); 834 void *sr = tmp + array_offset_sr; 835 836 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 837 && dst_kind == src_kind) 838 { 839 memmove (dst, sr, dst_size > src_size ? src_size : dst_size); 840 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER 841 && dst_size > src_size) 842 { 843 if (dst_kind == 1) 844 memset ((void*)(char*) dst + src_size, ' ', 845 dst_size-src_size); 846 else /* dst_kind == 4. */ 847 for (k = src_size/4; k < dst_size/4; k++) 848 ((int32_t*) dst)[k] = (int32_t) ' '; 849 } 850 } 851 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 852 assign_char1_from_char4 (dst_size, src_size, dst, sr); 853 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 854 assign_char4_from_char1 (dst_size, src_size, dst, sr); 855 else 856 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, 857 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); 858 array_offset_sr += src_size; 859 } 860 861 free (tmp); 862 return; 863 } 864 865 for (i = 0; i < size; i++) 866 { 867 ptrdiff_t array_offset_dst = 0; 868 ptrdiff_t stride = 1; 869 ptrdiff_t extent = 1; 870 for (j = 0; j < rank-1; j++) 871 { 872 array_offset_dst += ((i / (extent*stride)) 873 % (dest->dim[j]._ubound 874 - dest->dim[j].lower_bound + 1)) 875 * dest->dim[j]._stride; 876 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); 877 stride = dest->dim[j]._stride; 878 } 879 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; 880 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest); 881 882 ptrdiff_t array_offset_sr = 0; 883 stride = 1; 884 extent = 1; 885 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) 886 { 887 array_offset_sr += ((i / (extent*stride)) 888 % (src->dim[j]._ubound 889 - src->dim[j].lower_bound + 1)) 890 * src->dim[j]._stride; 891 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); 892 stride = src->dim[j]._stride; 893 } 894 array_offset_sr += (i / extent) * src->dim[rank-1]._stride; 895 void *sr = (void *)((char *) MEMTOK (token) + offset 896 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); 897 898 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 899 && dst_kind == src_kind) 900 { 901 memmove (dst, sr, dst_size > src_size ? src_size : dst_size); 902 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size) 903 { 904 if (dst_kind == 1) 905 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); 906 else /* dst_kind == 4. */ 907 for (k = src_size/4; k < dst_size/4; k++) 908 ((int32_t*) dst)[k] = (int32_t) ' '; 909 } 910 } 911 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 912 assign_char1_from_char4 (dst_size, src_size, dst, sr); 913 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 914 assign_char4_from_char1 (dst_size, src_size, dst, sr); 915 else 916 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, 917 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); 918 } 919} 920 921 922void 923_gfortran_caf_send (caf_token_t token, size_t offset, 924 int image_index __attribute__ ((unused)), 925 gfc_descriptor_t *dest, 926 caf_vector_t *dst_vector __attribute__ ((unused)), 927 gfc_descriptor_t *src, int dst_kind, int src_kind, 928 bool may_require_tmp, int *stat) 929{ 930 /* FIXME: Handle vector subscripts. */ 931 size_t i, k, size; 932 int j; 933 int rank = GFC_DESCRIPTOR_RANK (dest); 934 size_t src_size = GFC_DESCRIPTOR_SIZE (src); 935 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); 936 937 if (stat) 938 *stat = 0; 939 940 if (rank == 0) 941 { 942 void *dst = (void *) ((char *) MEMTOK (token) + offset); 943 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 944 && dst_kind == src_kind) 945 { 946 memmove (dst, GFC_DESCRIPTOR_DATA (src), 947 dst_size > src_size ? src_size : dst_size); 948 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size) 949 { 950 if (dst_kind == 1) 951 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); 952 else /* dst_kind == 4. */ 953 for (i = src_size/4; i < dst_size/4; i++) 954 ((int32_t*) dst)[i] = (int32_t) ' '; 955 } 956 } 957 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 958 assign_char1_from_char4 (dst_size, src_size, dst, 959 GFC_DESCRIPTOR_DATA (src)); 960 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 961 assign_char4_from_char1 (dst_size, src_size, dst, 962 GFC_DESCRIPTOR_DATA (src)); 963 else 964 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, 965 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src), 966 src_kind, stat); 967 return; 968 } 969 970 size = 1; 971 for (j = 0; j < rank; j++) 972 { 973 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1; 974 if (dimextent < 0) 975 dimextent = 0; 976 size *= dimextent; 977 } 978 979 if (size == 0) 980 return; 981 982 if (may_require_tmp) 983 { 984 ptrdiff_t array_offset_sr, array_offset_dst; 985 void *tmp; 986 987 if (GFC_DESCRIPTOR_RANK (src) == 0) 988 { 989 tmp = malloc (src_size); 990 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size); 991 } 992 else 993 { 994 tmp = malloc (size*src_size); 995 array_offset_dst = 0; 996 for (i = 0; i < size; i++) 997 { 998 ptrdiff_t array_offset_sr = 0; 999 ptrdiff_t stride = 1; 1000 ptrdiff_t extent = 1; 1001 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) 1002 { 1003 array_offset_sr += ((i / (extent*stride)) 1004 % (src->dim[j]._ubound 1005 - src->dim[j].lower_bound + 1)) 1006 * src->dim[j]._stride; 1007 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); 1008 stride = src->dim[j]._stride; 1009 } 1010 array_offset_sr += (i / extent) * src->dim[rank-1]._stride; 1011 void *sr = (void *) ((char *) src->base_addr 1012 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); 1013 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size); 1014 array_offset_dst += src_size; 1015 } 1016 } 1017 1018 array_offset_sr = 0; 1019 for (i = 0; i < size; i++) 1020 { 1021 ptrdiff_t array_offset_dst = 0; 1022 ptrdiff_t stride = 1; 1023 ptrdiff_t extent = 1; 1024 for (j = 0; j < rank-1; j++) 1025 { 1026 array_offset_dst += ((i / (extent*stride)) 1027 % (dest->dim[j]._ubound 1028 - dest->dim[j].lower_bound + 1)) 1029 * dest->dim[j]._stride; 1030 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); 1031 stride = dest->dim[j]._stride; 1032 } 1033 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; 1034 void *dst = (void *)((char *) MEMTOK (token) + offset 1035 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest)); 1036 void *sr = tmp + array_offset_sr; 1037 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 1038 && dst_kind == src_kind) 1039 { 1040 memmove (dst, sr, 1041 dst_size > src_size ? src_size : dst_size); 1042 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER 1043 && dst_size > src_size) 1044 { 1045 if (dst_kind == 1) 1046 memset ((void*)(char*) dst + src_size, ' ', 1047 dst_size-src_size); 1048 else /* dst_kind == 4. */ 1049 for (k = src_size/4; k < dst_size/4; k++) 1050 ((int32_t*) dst)[k] = (int32_t) ' '; 1051 } 1052 } 1053 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 1054 assign_char1_from_char4 (dst_size, src_size, dst, sr); 1055 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 1056 assign_char4_from_char1 (dst_size, src_size, dst, sr); 1057 else 1058 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, 1059 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); 1060 if (GFC_DESCRIPTOR_RANK (src)) 1061 array_offset_sr += src_size; 1062 } 1063 free (tmp); 1064 return; 1065 } 1066 1067 for (i = 0; i < size; i++) 1068 { 1069 ptrdiff_t array_offset_dst = 0; 1070 ptrdiff_t stride = 1; 1071 ptrdiff_t extent = 1; 1072 for (j = 0; j < rank-1; j++) 1073 { 1074 array_offset_dst += ((i / (extent*stride)) 1075 % (dest->dim[j]._ubound 1076 - dest->dim[j].lower_bound + 1)) 1077 * dest->dim[j]._stride; 1078 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); 1079 stride = dest->dim[j]._stride; 1080 } 1081 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; 1082 void *dst = (void *)((char *) MEMTOK (token) + offset 1083 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest)); 1084 void *sr; 1085 if (GFC_DESCRIPTOR_RANK (src) != 0) 1086 { 1087 ptrdiff_t array_offset_sr = 0; 1088 stride = 1; 1089 extent = 1; 1090 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) 1091 { 1092 array_offset_sr += ((i / (extent*stride)) 1093 % (src->dim[j]._ubound 1094 - src->dim[j].lower_bound + 1)) 1095 * src->dim[j]._stride; 1096 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); 1097 stride = src->dim[j]._stride; 1098 } 1099 array_offset_sr += (i / extent) * src->dim[rank-1]._stride; 1100 sr = (void *)((char *) src->base_addr 1101 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); 1102 } 1103 else 1104 sr = src->base_addr; 1105 1106 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) 1107 && dst_kind == src_kind) 1108 { 1109 memmove (dst, sr, 1110 dst_size > src_size ? src_size : dst_size); 1111 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size) 1112 { 1113 if (dst_kind == 1) 1114 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size); 1115 else /* dst_kind == 4. */ 1116 for (k = src_size/4; k < dst_size/4; k++) 1117 ((int32_t*) dst)[k] = (int32_t) ' '; 1118 } 1119 } 1120 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) 1121 assign_char1_from_char4 (dst_size, src_size, dst, sr); 1122 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) 1123 assign_char4_from_char1 (dst_size, src_size, dst, sr); 1124 else 1125 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, 1126 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); 1127 } 1128} 1129 1130 1131void 1132_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset, 1133 int dst_image_index, gfc_descriptor_t *dest, 1134 caf_vector_t *dst_vector, caf_token_t src_token, 1135 size_t src_offset, 1136 int src_image_index __attribute__ ((unused)), 1137 gfc_descriptor_t *src, 1138 caf_vector_t *src_vector __attribute__ ((unused)), 1139 int dst_kind, int src_kind, bool may_require_tmp) 1140{ 1141 /* FIXME: Handle vector subscript of 'src_vector'. */ 1142 /* For a single image, src->base_addr should be the same as src_token + offset 1143 but to play save, we do it properly. */ 1144 void *src_base = GFC_DESCRIPTOR_DATA (src); 1145 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token) 1146 + src_offset); 1147 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector, 1148 src, dst_kind, src_kind, may_require_tmp, NULL); 1149 GFC_DESCRIPTOR_DATA (src) = src_base; 1150} 1151 1152 1153/* Emitted when a theorectically unreachable part is reached. */ 1154const char unreachable[] = "Fatal error: unreachable alternative found.\n"; 1155 1156 1157static void 1158copy_data (void *ds, void *sr, int dst_type, int src_type, 1159 int dst_kind, int src_kind, size_t dst_size, size_t src_size, 1160 size_t num, int *stat) 1161{ 1162 size_t k; 1163 if (dst_type == src_type && dst_kind == src_kind) 1164 { 1165 memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num); 1166 if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER) 1167 && dst_size > src_size) 1168 { 1169 if (dst_kind == 1) 1170 memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size); 1171 else /* dst_kind == 4. */ 1172 for (k = src_size/4; k < dst_size/4; k++) 1173 ((int32_t*) ds)[k] = (int32_t) ' '; 1174 } 1175 } 1176 else if (dst_type == BT_CHARACTER && dst_kind == 1) 1177 assign_char1_from_char4 (dst_size, src_size, ds, sr); 1178 else if (dst_type == BT_CHARACTER) 1179 assign_char4_from_char1 (dst_size, src_size, ds, sr); 1180 else 1181 for (k = 0; k < num; ++k) 1182 { 1183 convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat); 1184 ds += dst_size; 1185 sr += src_size; 1186 } 1187} 1188 1189 1190#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \ 1191 do { \ 1192 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \ 1193 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \ 1194 if (num <= 0 || abs_stride < 1) return; \ 1195 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \ 1196 } while (0) 1197 1198 1199static void 1200get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, 1201 caf_single_token_t single_token, gfc_descriptor_t *dst, 1202 gfc_descriptor_t *src, void *ds, void *sr, 1203 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, 1204 size_t num, int *stat, int src_type) 1205{ 1206 ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src; 1207 size_t next_dst_dim; 1208 1209 if (unlikely (ref == NULL)) 1210 /* May be we should issue an error here, because this case should not 1211 occur. */ 1212 return; 1213 1214 if (ref->next == NULL) 1215 { 1216 size_t dst_size = GFC_DESCRIPTOR_SIZE (dst); 1217 ptrdiff_t array_offset_dst = 0;; 1218 size_t dst_rank = GFC_DESCRIPTOR_RANK (dst); 1219 1220 switch (ref->type) 1221 { 1222 case CAF_REF_COMPONENT: 1223 /* Because the token is always registered after the component, its 1224 offset is always greater zero. */ 1225 if (ref->u.c.caf_token_offset > 0) 1226 /* Note, that sr is dereffed here. */ 1227 copy_data (ds, *(void **)(sr + ref->u.c.offset), 1228 GFC_DESCRIPTOR_TYPE (dst), src_type, 1229 dst_kind, src_kind, dst_size, ref->item_size, 1, stat); 1230 else 1231 copy_data (ds, sr + ref->u.c.offset, 1232 GFC_DESCRIPTOR_TYPE (dst), src_type, 1233 dst_kind, src_kind, dst_size, ref->item_size, 1, stat); 1234 ++(*i); 1235 return; 1236 case CAF_REF_STATIC_ARRAY: 1237 /* Intentionally fall through. */ 1238 case CAF_REF_ARRAY: 1239 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) 1240 { 1241 for (size_t d = 0; d < dst_rank; ++d) 1242 array_offset_dst += dst_index[d]; 1243 copy_data (ds + array_offset_dst * dst_size, sr, 1244 GFC_DESCRIPTOR_TYPE (dst), src_type, 1245 dst_kind, src_kind, dst_size, ref->item_size, num, 1246 stat); 1247 *i += num; 1248 return; 1249 } 1250 break; 1251 default: 1252 caf_runtime_error (unreachable); 1253 } 1254 } 1255 1256 switch (ref->type) 1257 { 1258 case CAF_REF_COMPONENT: 1259 if (ref->u.c.caf_token_offset > 0) 1260 { 1261 single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset); 1262 1263 if (ref->next && ref->next->type == CAF_REF_ARRAY) 1264 src = single_token->desc; 1265 else 1266 src = NULL; 1267 1268 if (ref->next && ref->next->type == CAF_REF_COMPONENT) 1269 /* The currently ref'ed component was allocatabe (caf_token_offset 1270 > 0) and the next ref is a component, too, then the new sr has to 1271 be dereffed. (static arrays cannot be allocatable or they 1272 become an array with descriptor. */ 1273 sr = *(void **)(sr + ref->u.c.offset); 1274 else 1275 sr += ref->u.c.offset; 1276 1277 get_for_ref (ref->next, i, dst_index, single_token, dst, src, 1278 ds, sr, dst_kind, src_kind, dst_dim, 0, 1279 1, stat, src_type); 1280 } 1281 else 1282 get_for_ref (ref->next, i, dst_index, single_token, dst, 1283 (gfc_descriptor_t *)(sr + ref->u.c.offset), ds, 1284 sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1, 1285 stat, src_type); 1286 return; 1287 case CAF_REF_ARRAY: 1288 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) 1289 { 1290 get_for_ref (ref->next, i, dst_index, single_token, dst, 1291 src, ds, sr, dst_kind, src_kind, 1292 dst_dim, 0, 1, stat, src_type); 1293 return; 1294 } 1295 /* Only when on the left most index switch the data pointer to 1296 the array's data pointer. */ 1297 if (src_dim == 0) 1298 sr = GFC_DESCRIPTOR_DATA (src); 1299 switch (ref->u.a.mode[src_dim]) 1300 { 1301 case CAF_ARR_REF_VECTOR: 1302 extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]); 1303 array_offset_src = 0; 1304 dst_index[dst_dim] = 0; 1305 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec; 1306 ++idx) 1307 { 1308#define KINDCASE(kind, type) case kind: \ 1309 array_offset_src = (((index_type) \ 1310 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \ 1311 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \ 1312 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \ 1313 break 1314 1315 switch (ref->u.a.dim[src_dim].v.kind) 1316 { 1317 KINDCASE (1, GFC_INTEGER_1); 1318 KINDCASE (2, GFC_INTEGER_2); 1319 KINDCASE (4, GFC_INTEGER_4); 1320#ifdef HAVE_GFC_INTEGER_8 1321 KINDCASE (8, GFC_INTEGER_8); 1322#endif 1323#ifdef HAVE_GFC_INTEGER_16 1324 KINDCASE (16, GFC_INTEGER_16); 1325#endif 1326 default: 1327 caf_runtime_error (unreachable); 1328 return; 1329 } 1330#undef KINDCASE 1331 1332 get_for_ref (ref, i, dst_index, single_token, dst, src, 1333 ds, sr + array_offset_src * ref->item_size, 1334 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1335 1, stat, src_type); 1336 dst_index[dst_dim] 1337 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1338 } 1339 return; 1340 case CAF_ARR_REF_FULL: 1341 COMPUTE_NUM_ITEMS (extent_src, 1342 ref->u.a.dim[src_dim].s.stride, 1343 GFC_DIMENSION_LBOUND (src->dim[src_dim]), 1344 GFC_DIMENSION_UBOUND (src->dim[src_dim])); 1345 stride_src = src->dim[src_dim]._stride 1346 * ref->u.a.dim[src_dim].s.stride; 1347 array_offset_src = 0; 1348 dst_index[dst_dim] = 0; 1349 for (index_type idx = 0; idx < extent_src; 1350 ++idx, array_offset_src += stride_src) 1351 { 1352 get_for_ref (ref, i, dst_index, single_token, dst, src, 1353 ds, sr + array_offset_src * ref->item_size, 1354 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1355 1, stat, src_type); 1356 dst_index[dst_dim] 1357 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1358 } 1359 return; 1360 case CAF_ARR_REF_RANGE: 1361 COMPUTE_NUM_ITEMS (extent_src, 1362 ref->u.a.dim[src_dim].s.stride, 1363 ref->u.a.dim[src_dim].s.start, 1364 ref->u.a.dim[src_dim].s.end); 1365 array_offset_src = (ref->u.a.dim[src_dim].s.start 1366 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) 1367 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); 1368 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) 1369 * ref->u.a.dim[src_dim].s.stride; 1370 dst_index[dst_dim] = 0; 1371 /* Increase the dst_dim only, when the src_extent is greater one 1372 or src and dst extent are both one. Don't increase when the scalar 1373 source is not present in the dst. */ 1374 next_dst_dim = extent_src > 1 1375 || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1 1376 && extent_src == 1) ? (dst_dim + 1) : dst_dim; 1377 for (index_type idx = 0; idx < extent_src; ++idx) 1378 { 1379 get_for_ref (ref, i, dst_index, single_token, dst, src, 1380 ds, sr + array_offset_src * ref->item_size, 1381 dst_kind, src_kind, next_dst_dim, src_dim + 1, 1382 1, stat, src_type); 1383 dst_index[dst_dim] 1384 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1385 array_offset_src += stride_src; 1386 } 1387 return; 1388 case CAF_ARR_REF_SINGLE: 1389 array_offset_src = (ref->u.a.dim[src_dim].s.start 1390 - src->dim[src_dim].lower_bound) 1391 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); 1392 dst_index[dst_dim] = 0; 1393 get_for_ref (ref, i, dst_index, single_token, dst, src, ds, 1394 sr + array_offset_src * ref->item_size, 1395 dst_kind, src_kind, dst_dim, src_dim + 1, 1, 1396 stat, src_type); 1397 return; 1398 case CAF_ARR_REF_OPEN_END: 1399 COMPUTE_NUM_ITEMS (extent_src, 1400 ref->u.a.dim[src_dim].s.stride, 1401 ref->u.a.dim[src_dim].s.start, 1402 GFC_DIMENSION_UBOUND (src->dim[src_dim])); 1403 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) 1404 * ref->u.a.dim[src_dim].s.stride; 1405 array_offset_src = (ref->u.a.dim[src_dim].s.start 1406 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) 1407 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); 1408 dst_index[dst_dim] = 0; 1409 for (index_type idx = 0; idx < extent_src; ++idx) 1410 { 1411 get_for_ref (ref, i, dst_index, single_token, dst, src, 1412 ds, sr + array_offset_src * ref->item_size, 1413 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1414 1, stat, src_type); 1415 dst_index[dst_dim] 1416 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1417 array_offset_src += stride_src; 1418 } 1419 return; 1420 case CAF_ARR_REF_OPEN_START: 1421 COMPUTE_NUM_ITEMS (extent_src, 1422 ref->u.a.dim[src_dim].s.stride, 1423 GFC_DIMENSION_LBOUND (src->dim[src_dim]), 1424 ref->u.a.dim[src_dim].s.end); 1425 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) 1426 * ref->u.a.dim[src_dim].s.stride; 1427 array_offset_src = 0; 1428 dst_index[dst_dim] = 0; 1429 for (index_type idx = 0; idx < extent_src; ++idx) 1430 { 1431 get_for_ref (ref, i, dst_index, single_token, dst, src, 1432 ds, sr + array_offset_src * ref->item_size, 1433 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1434 1, stat, src_type); 1435 dst_index[dst_dim] 1436 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1437 array_offset_src += stride_src; 1438 } 1439 return; 1440 default: 1441 caf_runtime_error (unreachable); 1442 } 1443 return; 1444 case CAF_REF_STATIC_ARRAY: 1445 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) 1446 { 1447 get_for_ref (ref->next, i, dst_index, single_token, dst, 1448 NULL, ds, sr, dst_kind, src_kind, 1449 dst_dim, 0, 1, stat, src_type); 1450 return; 1451 } 1452 switch (ref->u.a.mode[src_dim]) 1453 { 1454 case CAF_ARR_REF_VECTOR: 1455 array_offset_src = 0; 1456 dst_index[dst_dim] = 0; 1457 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec; 1458 ++idx) 1459 { 1460#define KINDCASE(kind, type) case kind: \ 1461 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \ 1462 break 1463 1464 switch (ref->u.a.dim[src_dim].v.kind) 1465 { 1466 KINDCASE (1, GFC_INTEGER_1); 1467 KINDCASE (2, GFC_INTEGER_2); 1468 KINDCASE (4, GFC_INTEGER_4); 1469#ifdef HAVE_GFC_INTEGER_8 1470 KINDCASE (8, GFC_INTEGER_8); 1471#endif 1472#ifdef HAVE_GFC_INTEGER_16 1473 KINDCASE (16, GFC_INTEGER_16); 1474#endif 1475 default: 1476 caf_runtime_error (unreachable); 1477 return; 1478 } 1479#undef KINDCASE 1480 1481 get_for_ref (ref, i, dst_index, single_token, dst, NULL, 1482 ds, sr + array_offset_src * ref->item_size, 1483 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1484 1, stat, src_type); 1485 dst_index[dst_dim] 1486 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1487 } 1488 return; 1489 case CAF_ARR_REF_FULL: 1490 dst_index[dst_dim] = 0; 1491 for (array_offset_src = 0 ; 1492 array_offset_src <= ref->u.a.dim[src_dim].s.end; 1493 array_offset_src += ref->u.a.dim[src_dim].s.stride) 1494 { 1495 get_for_ref (ref, i, dst_index, single_token, dst, NULL, 1496 ds, sr + array_offset_src * ref->item_size, 1497 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1498 1, stat, src_type); 1499 dst_index[dst_dim] 1500 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1501 } 1502 return; 1503 case CAF_ARR_REF_RANGE: 1504 COMPUTE_NUM_ITEMS (extent_src, 1505 ref->u.a.dim[src_dim].s.stride, 1506 ref->u.a.dim[src_dim].s.start, 1507 ref->u.a.dim[src_dim].s.end); 1508 array_offset_src = ref->u.a.dim[src_dim].s.start; 1509 dst_index[dst_dim] = 0; 1510 for (index_type idx = 0; idx < extent_src; ++idx) 1511 { 1512 get_for_ref (ref, i, dst_index, single_token, dst, NULL, 1513 ds, sr + array_offset_src * ref->item_size, 1514 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 1515 1, stat, src_type); 1516 dst_index[dst_dim] 1517 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 1518 array_offset_src += ref->u.a.dim[src_dim].s.stride; 1519 } 1520 return; 1521 case CAF_ARR_REF_SINGLE: 1522 array_offset_src = ref->u.a.dim[src_dim].s.start; 1523 get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, 1524 sr + array_offset_src * ref->item_size, 1525 dst_kind, src_kind, dst_dim, src_dim + 1, 1, 1526 stat, src_type); 1527 return; 1528 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */ 1529 case CAF_ARR_REF_OPEN_END: 1530 case CAF_ARR_REF_OPEN_START: 1531 default: 1532 caf_runtime_error (unreachable); 1533 } 1534 return; 1535 default: 1536 caf_runtime_error (unreachable); 1537 } 1538} 1539 1540 1541void 1542_gfortran_caf_get_by_ref (caf_token_t token, 1543 int image_index __attribute__ ((unused)), 1544 gfc_descriptor_t *dst, caf_reference_t *refs, 1545 int dst_kind, int src_kind, 1546 bool may_require_tmp __attribute__ ((unused)), 1547 bool dst_reallocatable, int *stat, 1548 int src_type) 1549{ 1550 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " 1551 "unknown kind in vector-ref.\n"; 1552 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): " 1553 "unknown reference type.\n"; 1554 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): " 1555 "unknown array reference type.\n"; 1556 const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): " 1557 "rank out of range.\n"; 1558 const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): " 1559 "extent out of range.\n"; 1560 const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): " 1561 "cannot allocate memory.\n"; 1562 const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): " 1563 "extent of non-allocatable arrays mismatch (%lu != %lu).\n"; 1564 const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): " 1565 "two or more array part references are not supported.\n"; 1566 size_t size, i; 1567 size_t dst_index[GFC_MAX_DIMENSIONS]; 1568 int dst_rank = GFC_DESCRIPTOR_RANK (dst); 1569 int dst_cur_dim = 0; 1570 size_t src_size = 0; 1571 caf_single_token_t single_token = TOKEN (token); 1572 void *memptr = single_token->memptr; 1573 gfc_descriptor_t *src = single_token->desc; 1574 caf_reference_t *riter = refs; 1575 long delta; 1576 /* Reallocation of dst.data is needed (e.g., array to small). */ 1577 bool realloc_needed; 1578 /* Reallocation of dst.data is required, because data is not alloced at 1579 all. */ 1580 bool realloc_required; 1581 bool extent_mismatch = false; 1582 /* Set when the first non-scalar array reference is encountered. */ 1583 bool in_array_ref = false; 1584 bool array_extent_fixed = false; 1585 realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL; 1586 1587 assert (!realloc_needed || dst_reallocatable); 1588 1589 if (stat) 1590 *stat = 0; 1591 1592 /* Compute the size of the result. In the beginning size just counts the 1593 number of elements. */ 1594 size = 1; 1595 while (riter) 1596 { 1597 switch (riter->type) 1598 { 1599 case CAF_REF_COMPONENT: 1600 if (riter->u.c.caf_token_offset) 1601 { 1602 single_token = *(caf_single_token_t*) 1603 (memptr + riter->u.c.caf_token_offset); 1604 memptr = single_token->memptr; 1605 src = single_token->desc; 1606 } 1607 else 1608 { 1609 memptr += riter->u.c.offset; 1610 /* When the next ref is an array ref, assume there is an 1611 array descriptor at memptr. Note, static arrays do not have 1612 a descriptor. */ 1613 if (riter->next && riter->next->type == CAF_REF_ARRAY) 1614 src = (gfc_descriptor_t *)memptr; 1615 else 1616 src = NULL; 1617 } 1618 break; 1619 case CAF_REF_ARRAY: 1620 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 1621 { 1622 switch (riter->u.a.mode[i]) 1623 { 1624 case CAF_ARR_REF_VECTOR: 1625 delta = riter->u.a.dim[i].v.nvec; 1626#define KINDCASE(kind, type) case kind: \ 1627 memptr += (((index_type) \ 1628 ((type *)riter->u.a.dim[i].v.vector)[0]) \ 1629 - GFC_DIMENSION_LBOUND (src->dim[i])) \ 1630 * GFC_DIMENSION_STRIDE (src->dim[i]) \ 1631 * riter->item_size; \ 1632 break 1633 1634 switch (riter->u.a.dim[i].v.kind) 1635 { 1636 KINDCASE (1, GFC_INTEGER_1); 1637 KINDCASE (2, GFC_INTEGER_2); 1638 KINDCASE (4, GFC_INTEGER_4); 1639#ifdef HAVE_GFC_INTEGER_8 1640 KINDCASE (8, GFC_INTEGER_8); 1641#endif 1642#ifdef HAVE_GFC_INTEGER_16 1643 KINDCASE (16, GFC_INTEGER_16); 1644#endif 1645 default: 1646 caf_internal_error (vecrefunknownkind, stat, NULL, 0); 1647 return; 1648 } 1649#undef KINDCASE 1650 break; 1651 case CAF_ARR_REF_FULL: 1652 COMPUTE_NUM_ITEMS (delta, 1653 riter->u.a.dim[i].s.stride, 1654 GFC_DIMENSION_LBOUND (src->dim[i]), 1655 GFC_DIMENSION_UBOUND (src->dim[i])); 1656 /* The memptr stays unchanged when ref'ing the first element 1657 in a dimension. */ 1658 break; 1659 case CAF_ARR_REF_RANGE: 1660 COMPUTE_NUM_ITEMS (delta, 1661 riter->u.a.dim[i].s.stride, 1662 riter->u.a.dim[i].s.start, 1663 riter->u.a.dim[i].s.end); 1664 memptr += (riter->u.a.dim[i].s.start 1665 - GFC_DIMENSION_LBOUND (src->dim[i])) 1666 * GFC_DIMENSION_STRIDE (src->dim[i]) 1667 * riter->item_size; 1668 break; 1669 case CAF_ARR_REF_SINGLE: 1670 delta = 1; 1671 memptr += (riter->u.a.dim[i].s.start 1672 - GFC_DIMENSION_LBOUND (src->dim[i])) 1673 * GFC_DIMENSION_STRIDE (src->dim[i]) 1674 * riter->item_size; 1675 break; 1676 case CAF_ARR_REF_OPEN_END: 1677 COMPUTE_NUM_ITEMS (delta, 1678 riter->u.a.dim[i].s.stride, 1679 riter->u.a.dim[i].s.start, 1680 GFC_DIMENSION_UBOUND (src->dim[i])); 1681 memptr += (riter->u.a.dim[i].s.start 1682 - GFC_DIMENSION_LBOUND (src->dim[i])) 1683 * GFC_DIMENSION_STRIDE (src->dim[i]) 1684 * riter->item_size; 1685 break; 1686 case CAF_ARR_REF_OPEN_START: 1687 COMPUTE_NUM_ITEMS (delta, 1688 riter->u.a.dim[i].s.stride, 1689 GFC_DIMENSION_LBOUND (src->dim[i]), 1690 riter->u.a.dim[i].s.end); 1691 /* The memptr stays unchanged when ref'ing the first element 1692 in a dimension. */ 1693 break; 1694 default: 1695 caf_internal_error (unknownarrreftype, stat, NULL, 0); 1696 return; 1697 } 1698 if (delta <= 0) 1699 return; 1700 /* Check the various properties of the destination array. 1701 Is an array expected and present? */ 1702 if (delta > 1 && dst_rank == 0) 1703 { 1704 /* No, an array is required, but not provided. */ 1705 caf_internal_error (extentoutofrange, stat, NULL, 0); 1706 return; 1707 } 1708 /* Special mode when called by __caf_sendget_by_ref (). */ 1709 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) 1710 { 1711 dst_rank = dst_cur_dim + 1; 1712 GFC_DESCRIPTOR_RANK (dst) = dst_rank; 1713 GFC_DESCRIPTOR_SIZE (dst) = dst_kind; 1714 } 1715 /* When dst is an array. */ 1716 if (dst_rank > 0) 1717 { 1718 /* Check that dst_cur_dim is valid for dst. Can be 1719 superceeded only by scalar data. */ 1720 if (dst_cur_dim >= dst_rank && delta != 1) 1721 { 1722 caf_internal_error (rankoutofrange, stat, NULL, 0); 1723 return; 1724 } 1725 /* Do further checks, when the source is not scalar. */ 1726 else if (delta != 1) 1727 { 1728 /* Check that the extent is not scalar and we are not in 1729 an array ref for the dst side. */ 1730 if (!in_array_ref) 1731 { 1732 /* Check that this is the non-scalar extent. */ 1733 if (!array_extent_fixed) 1734 { 1735 /* In an array extent now. */ 1736 in_array_ref = true; 1737 /* Check that we haven't skipped any scalar 1738 dimensions yet and that the dst is 1739 compatible. */ 1740 if (i > 0 1741 && dst_rank == GFC_DESCRIPTOR_RANK (src)) 1742 { 1743 if (dst_reallocatable) 1744 { 1745 /* Dst is reallocatable, which means that 1746 the bounds are not set. Set them. */ 1747 for (dst_cur_dim= 0; dst_cur_dim < (int)i; 1748 ++dst_cur_dim) 1749 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1750 1, 1, 1); 1751 } 1752 else 1753 dst_cur_dim = i; 1754 } 1755 /* Else press thumbs, that there are enough 1756 dimensional refs to come. Checked below. */ 1757 } 1758 else 1759 { 1760 caf_internal_error (doublearrayref, stat, NULL, 1761 0); 1762 return; 1763 } 1764 } 1765 /* When the realloc is required, then no extent may have 1766 been set. */ 1767 extent_mismatch = realloc_required 1768 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta; 1769 /* When it already known, that a realloc is needed or 1770 the extent does not match the needed one. */ 1771 if (realloc_required || realloc_needed 1772 || extent_mismatch) 1773 { 1774 /* Check whether dst is reallocatable. */ 1775 if (unlikely (!dst_reallocatable)) 1776 { 1777 caf_internal_error (nonallocextentmismatch, stat, 1778 NULL, 0, delta, 1779 GFC_DESCRIPTOR_EXTENT (dst, 1780 dst_cur_dim)); 1781 return; 1782 } 1783 /* Only report an error, when the extent needs to be 1784 modified, which is not allowed. */ 1785 else if (!dst_reallocatable && extent_mismatch) 1786 { 1787 caf_internal_error (extentoutofrange, stat, NULL, 1788 0); 1789 return; 1790 } 1791 realloc_needed = true; 1792 } 1793 /* Only change the extent when it does not match. This is 1794 to prevent resetting given array bounds. */ 1795 if (extent_mismatch) 1796 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta, 1797 size); 1798 } 1799 1800 /* Only increase the dim counter, when in an array ref. */ 1801 if (in_array_ref && dst_cur_dim < dst_rank) 1802 ++dst_cur_dim; 1803 } 1804 size *= (index_type)delta; 1805 } 1806 if (in_array_ref) 1807 { 1808 array_extent_fixed = true; 1809 in_array_ref = false; 1810 /* Check, if we got less dimensional refs than the rank of dst 1811 expects. */ 1812 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst)); 1813 } 1814 break; 1815 case CAF_REF_STATIC_ARRAY: 1816 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 1817 { 1818 switch (riter->u.a.mode[i]) 1819 { 1820 case CAF_ARR_REF_VECTOR: 1821 delta = riter->u.a.dim[i].v.nvec; 1822#define KINDCASE(kind, type) case kind: \ 1823 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \ 1824 * riter->item_size; \ 1825 break 1826 1827 switch (riter->u.a.dim[i].v.kind) 1828 { 1829 KINDCASE (1, GFC_INTEGER_1); 1830 KINDCASE (2, GFC_INTEGER_2); 1831 KINDCASE (4, GFC_INTEGER_4); 1832#ifdef HAVE_GFC_INTEGER_8 1833 KINDCASE (8, GFC_INTEGER_8); 1834#endif 1835#ifdef HAVE_GFC_INTEGER_16 1836 KINDCASE (16, GFC_INTEGER_16); 1837#endif 1838 default: 1839 caf_internal_error (vecrefunknownkind, stat, NULL, 0); 1840 return; 1841 } 1842#undef KINDCASE 1843 break; 1844 case CAF_ARR_REF_FULL: 1845 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride 1846 + 1; 1847 /* The memptr stays unchanged when ref'ing the first element 1848 in a dimension. */ 1849 break; 1850 case CAF_ARR_REF_RANGE: 1851 COMPUTE_NUM_ITEMS (delta, 1852 riter->u.a.dim[i].s.stride, 1853 riter->u.a.dim[i].s.start, 1854 riter->u.a.dim[i].s.end); 1855 memptr += riter->u.a.dim[i].s.start 1856 * riter->u.a.dim[i].s.stride 1857 * riter->item_size; 1858 break; 1859 case CAF_ARR_REF_SINGLE: 1860 delta = 1; 1861 memptr += riter->u.a.dim[i].s.start 1862 * riter->u.a.dim[i].s.stride 1863 * riter->item_size; 1864 break; 1865 case CAF_ARR_REF_OPEN_END: 1866 /* This and OPEN_START are mapped to a RANGE and therefore 1867 cannot occur here. */ 1868 case CAF_ARR_REF_OPEN_START: 1869 default: 1870 caf_internal_error (unknownarrreftype, stat, NULL, 0); 1871 return; 1872 } 1873 if (delta <= 0) 1874 return; 1875 /* Check the various properties of the destination array. 1876 Is an array expected and present? */ 1877 if (delta > 1 && dst_rank == 0) 1878 { 1879 /* No, an array is required, but not provided. */ 1880 caf_internal_error (extentoutofrange, stat, NULL, 0); 1881 return; 1882 } 1883 /* Special mode when called by __caf_sendget_by_ref (). */ 1884 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) 1885 { 1886 dst_rank = dst_cur_dim + 1; 1887 GFC_DESCRIPTOR_RANK (dst) = dst_rank; 1888 GFC_DESCRIPTOR_SIZE (dst) = dst_kind; 1889 } 1890 /* When dst is an array. */ 1891 if (dst_rank > 0) 1892 { 1893 /* Check that dst_cur_dim is valid for dst. Can be 1894 superceeded only by scalar data. */ 1895 if (dst_cur_dim >= dst_rank && delta != 1) 1896 { 1897 caf_internal_error (rankoutofrange, stat, NULL, 0); 1898 return; 1899 } 1900 /* Do further checks, when the source is not scalar. */ 1901 else if (delta != 1) 1902 { 1903 /* Check that the extent is not scalar and we are not in 1904 an array ref for the dst side. */ 1905 if (!in_array_ref) 1906 { 1907 /* Check that this is the non-scalar extent. */ 1908 if (!array_extent_fixed) 1909 { 1910 /* In an array extent now. */ 1911 in_array_ref = true; 1912 /* The dst is not reallocatable, so nothing more 1913 to do, then correct the dim counter. */ 1914 dst_cur_dim = i; 1915 } 1916 else 1917 { 1918 caf_internal_error (doublearrayref, stat, NULL, 1919 0); 1920 return; 1921 } 1922 } 1923 /* When the realloc is required, then no extent may have 1924 been set. */ 1925 extent_mismatch = realloc_required 1926 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta; 1927 /* When it is already known, that a realloc is needed or 1928 the extent does not match the needed one. */ 1929 if (realloc_required || realloc_needed 1930 || extent_mismatch) 1931 { 1932 /* Check whether dst is reallocatable. */ 1933 if (unlikely (!dst_reallocatable)) 1934 { 1935 caf_internal_error (nonallocextentmismatch, stat, 1936 NULL, 0, delta, 1937 GFC_DESCRIPTOR_EXTENT (dst, 1938 dst_cur_dim)); 1939 return; 1940 } 1941 /* Only report an error, when the extent needs to be 1942 modified, which is not allowed. */ 1943 else if (!dst_reallocatable && extent_mismatch) 1944 { 1945 caf_internal_error (extentoutofrange, stat, NULL, 1946 0); 1947 return; 1948 } 1949 realloc_needed = true; 1950 } 1951 /* Only change the extent when it does not match. This is 1952 to prevent resetting given array bounds. */ 1953 if (extent_mismatch) 1954 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta, 1955 size); 1956 } 1957 /* Only increase the dim counter, when in an array ref. */ 1958 if (in_array_ref && dst_cur_dim < dst_rank) 1959 ++dst_cur_dim; 1960 } 1961 size *= (index_type)delta; 1962 } 1963 if (in_array_ref) 1964 { 1965 array_extent_fixed = true; 1966 in_array_ref = false; 1967 /* Check, if we got less dimensional refs than the rank of dst 1968 expects. */ 1969 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst)); 1970 } 1971 break; 1972 default: 1973 caf_internal_error (unknownreftype, stat, NULL, 0); 1974 return; 1975 } 1976 src_size = riter->item_size; 1977 riter = riter->next; 1978 } 1979 if (size == 0 || src_size == 0) 1980 return; 1981 /* Postcondition: 1982 - size contains the number of elements to store in the destination array, 1983 - src_size gives the size in bytes of each item in the destination array. 1984 */ 1985 1986 if (realloc_needed) 1987 { 1988 if (!array_extent_fixed) 1989 { 1990 assert (size == 1); 1991 /* Special mode when called by __caf_sendget_by_ref (). */ 1992 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) 1993 { 1994 dst_rank = dst_cur_dim + 1; 1995 GFC_DESCRIPTOR_RANK (dst) = dst_rank; 1996 GFC_DESCRIPTOR_SIZE (dst) = dst_kind; 1997 } 1998 /* This can happen only, when the result is scalar. */ 1999 for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim) 2000 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1); 2001 } 2002 2003 GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst)); 2004 if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL)) 2005 { 2006 caf_internal_error (cannotallocdst, stat, NULL, 0); 2007 return; 2008 } 2009 } 2010 2011 /* Reset the token. */ 2012 single_token = TOKEN (token); 2013 memptr = single_token->memptr; 2014 src = single_token->desc; 2015 memset(dst_index, 0, sizeof (dst_index)); 2016 i = 0; 2017 get_for_ref (refs, &i, dst_index, single_token, dst, src, 2018 GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0, 2019 1, stat, src_type); 2020} 2021 2022 2023static void 2024send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, 2025 caf_single_token_t single_token, gfc_descriptor_t *dst, 2026 gfc_descriptor_t *src, void *ds, void *sr, 2027 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, 2028 size_t num, size_t size, int *stat, int dst_type) 2029{ 2030 const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): " 2031 "unknown kind in vector-ref.\n"; 2032 ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst; 2033 const size_t src_rank = GFC_DESCRIPTOR_RANK (src); 2034 2035 if (unlikely (ref == NULL)) 2036 /* May be we should issue an error here, because this case should not 2037 occur. */ 2038 return; 2039 2040 if (ref->next == NULL) 2041 { 2042 size_t src_size = GFC_DESCRIPTOR_SIZE (src); 2043 ptrdiff_t array_offset_src = 0;; 2044 2045 switch (ref->type) 2046 { 2047 case CAF_REF_COMPONENT: 2048 if (ref->u.c.caf_token_offset > 0) 2049 { 2050 if (*(void**)(ds + ref->u.c.offset) == NULL) 2051 { 2052 /* Create a scalar temporary array descriptor. */ 2053 gfc_descriptor_t static_dst; 2054 GFC_DESCRIPTOR_DATA (&static_dst) = NULL; 2055 GFC_DESCRIPTOR_DTYPE (&static_dst) 2056 = GFC_DESCRIPTOR_DTYPE (src); 2057 /* The component can be allocated now, because it is a 2058 scalar. */ 2059 _gfortran_caf_register (ref->item_size, 2060 CAF_REGTYPE_COARRAY_ALLOC, 2061 ds + ref->u.c.caf_token_offset, 2062 &static_dst, stat, NULL, 0); 2063 single_token = *(caf_single_token_t *) 2064 (ds + ref->u.c.caf_token_offset); 2065 /* In case of an error in allocation return. When stat is 2066 NULL, then register_component() terminates on error. */ 2067 if (stat != NULL && *stat) 2068 return; 2069 /* Publish the allocated memory. */ 2070 *((void **)(ds + ref->u.c.offset)) 2071 = GFC_DESCRIPTOR_DATA (&static_dst); 2072 ds = GFC_DESCRIPTOR_DATA (&static_dst); 2073 /* Set the type from the src. */ 2074 dst_type = GFC_DESCRIPTOR_TYPE (src); 2075 } 2076 else 2077 { 2078 single_token = *(caf_single_token_t *) 2079 (ds + ref->u.c.caf_token_offset); 2080 dst = single_token->desc; 2081 if (dst) 2082 { 2083 ds = GFC_DESCRIPTOR_DATA (dst); 2084 dst_type = GFC_DESCRIPTOR_TYPE (dst); 2085 } 2086 else 2087 ds = *(void **)(ds + ref->u.c.offset); 2088 } 2089 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), 2090 dst_kind, src_kind, ref->item_size, src_size, 1, stat); 2091 } 2092 else 2093 copy_data (ds + ref->u.c.offset, sr, dst_type, 2094 GFC_DESCRIPTOR_TYPE (src), 2095 dst_kind, src_kind, ref->item_size, src_size, 1, stat); 2096 ++(*i); 2097 return; 2098 case CAF_REF_STATIC_ARRAY: 2099 /* Intentionally fall through. */ 2100 case CAF_REF_ARRAY: 2101 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) 2102 { 2103 if (src_rank > 0) 2104 { 2105 for (size_t d = 0; d < src_rank; ++d) 2106 array_offset_src += src_index[d]; 2107 copy_data (ds, sr + array_offset_src * src_size, 2108 dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, 2109 src_kind, ref->item_size, src_size, num, stat); 2110 } 2111 else 2112 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), 2113 dst_kind, src_kind, ref->item_size, src_size, num, 2114 stat); 2115 *i += num; 2116 return; 2117 } 2118 break; 2119 default: 2120 caf_runtime_error (unreachable); 2121 } 2122 } 2123 2124 switch (ref->type) 2125 { 2126 case CAF_REF_COMPONENT: 2127 if (ref->u.c.caf_token_offset > 0) 2128 { 2129 if (*(void**)(ds + ref->u.c.offset) == NULL) 2130 { 2131 /* This component refs an unallocated array. Non-arrays are 2132 caught in the if (!ref->next) above. */ 2133 dst = (gfc_descriptor_t *)(ds + ref->u.c.offset); 2134 /* Assume that the rank and the dimensions fit for copying src 2135 to dst. */ 2136 GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src); 2137 dst->offset = 0; 2138 stride_dst = 1; 2139 for (size_t d = 0; d < src_rank; ++d) 2140 { 2141 extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]); 2142 GFC_DIMENSION_LBOUND (dst->dim[d]) = 0; 2143 GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1; 2144 GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst; 2145 stride_dst *= extent_dst; 2146 } 2147 /* Null the data-pointer to make register_component allocate 2148 its own memory. */ 2149 GFC_DESCRIPTOR_DATA (dst) = NULL; 2150 2151 /* The size of the array is given by size. */ 2152 _gfortran_caf_register (size * ref->item_size, 2153 CAF_REGTYPE_COARRAY_ALLOC, 2154 ds + ref->u.c.caf_token_offset, 2155 dst, stat, NULL, 0); 2156 /* In case of an error in allocation return. When stat is 2157 NULL, then register_component() terminates on error. */ 2158 if (stat != NULL && *stat) 2159 return; 2160 } 2161 single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset); 2162 /* When a component is allocatable (caf_token_offset != 0) and not an 2163 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be 2164 dereffed. */ 2165 if (ref->next && ref->next->type == CAF_REF_COMPONENT) 2166 ds = *(void **)(ds + ref->u.c.offset); 2167 else 2168 ds += ref->u.c.offset; 2169 2170 send_by_ref (ref->next, i, src_index, single_token, 2171 single_token->desc, src, ds, sr, 2172 dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type); 2173 } 2174 else 2175 send_by_ref (ref->next, i, src_index, single_token, 2176 (gfc_descriptor_t *)(ds + ref->u.c.offset), src, 2177 ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim, 2178 1, size, stat, dst_type); 2179 return; 2180 case CAF_REF_ARRAY: 2181 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) 2182 { 2183 send_by_ref (ref->next, i, src_index, single_token, 2184 (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind, 2185 0, src_dim, 1, size, stat, dst_type); 2186 return; 2187 } 2188 /* Only when on the left most index switch the data pointer to 2189 the array's data pointer. And only for non-static arrays. */ 2190 if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY) 2191 ds = GFC_DESCRIPTOR_DATA (dst); 2192 switch (ref->u.a.mode[dst_dim]) 2193 { 2194 case CAF_ARR_REF_VECTOR: 2195 array_offset_dst = 0; 2196 src_index[src_dim] = 0; 2197 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec; 2198 ++idx) 2199 { 2200#define KINDCASE(kind, type) case kind: \ 2201 array_offset_dst = (((index_type) \ 2202 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \ 2203 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \ 2204 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \ 2205 break 2206 2207 switch (ref->u.a.dim[dst_dim].v.kind) 2208 { 2209 KINDCASE (1, GFC_INTEGER_1); 2210 KINDCASE (2, GFC_INTEGER_2); 2211 KINDCASE (4, GFC_INTEGER_4); 2212#ifdef HAVE_GFC_INTEGER_8 2213 KINDCASE (8, GFC_INTEGER_8); 2214#endif 2215#ifdef HAVE_GFC_INTEGER_16 2216 KINDCASE (16, GFC_INTEGER_16); 2217#endif 2218 default: 2219 caf_internal_error (vecrefunknownkind, stat, NULL, 0); 2220 return; 2221 } 2222#undef KINDCASE 2223 2224 send_by_ref (ref, i, src_index, single_token, dst, src, 2225 ds + array_offset_dst * ref->item_size, sr, 2226 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2227 1, size, stat, dst_type); 2228 if (src_rank > 0) 2229 src_index[src_dim] 2230 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2231 } 2232 return; 2233 case CAF_ARR_REF_FULL: 2234 COMPUTE_NUM_ITEMS (extent_dst, 2235 ref->u.a.dim[dst_dim].s.stride, 2236 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]), 2237 GFC_DIMENSION_UBOUND (dst->dim[dst_dim])); 2238 array_offset_dst = 0; 2239 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) 2240 * ref->u.a.dim[dst_dim].s.stride; 2241 src_index[src_dim] = 0; 2242 for (index_type idx = 0; idx < extent_dst; 2243 ++idx, array_offset_dst += stride_dst) 2244 { 2245 send_by_ref (ref, i, src_index, single_token, dst, src, 2246 ds + array_offset_dst * ref->item_size, sr, 2247 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2248 1, size, stat, dst_type); 2249 if (src_rank > 0) 2250 src_index[src_dim] 2251 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2252 } 2253 return; 2254 case CAF_ARR_REF_RANGE: 2255 COMPUTE_NUM_ITEMS (extent_dst, 2256 ref->u.a.dim[dst_dim].s.stride, 2257 ref->u.a.dim[dst_dim].s.start, 2258 ref->u.a.dim[dst_dim].s.end); 2259 array_offset_dst = ref->u.a.dim[dst_dim].s.start 2260 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]); 2261 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) 2262 * ref->u.a.dim[dst_dim].s.stride; 2263 src_index[src_dim] = 0; 2264 for (index_type idx = 0; idx < extent_dst; ++idx) 2265 { 2266 send_by_ref (ref, i, src_index, single_token, dst, src, 2267 ds + array_offset_dst * ref->item_size, sr, 2268 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2269 1, size, stat, dst_type); 2270 if (src_rank > 0) 2271 src_index[src_dim] 2272 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2273 array_offset_dst += stride_dst; 2274 } 2275 return; 2276 case CAF_ARR_REF_SINGLE: 2277 array_offset_dst = (ref->u.a.dim[dst_dim].s.start 2278 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) 2279 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); 2280 send_by_ref (ref, i, src_index, single_token, dst, src, ds 2281 + array_offset_dst * ref->item_size, sr, 2282 dst_kind, src_kind, dst_dim + 1, src_dim, 1, 2283 size, stat, dst_type); 2284 return; 2285 case CAF_ARR_REF_OPEN_END: 2286 COMPUTE_NUM_ITEMS (extent_dst, 2287 ref->u.a.dim[dst_dim].s.stride, 2288 ref->u.a.dim[dst_dim].s.start, 2289 GFC_DIMENSION_UBOUND (dst->dim[dst_dim])); 2290 array_offset_dst = ref->u.a.dim[dst_dim].s.start 2291 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]); 2292 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) 2293 * ref->u.a.dim[dst_dim].s.stride; 2294 src_index[src_dim] = 0; 2295 for (index_type idx = 0; idx < extent_dst; ++idx) 2296 { 2297 send_by_ref (ref, i, src_index, single_token, dst, src, 2298 ds + array_offset_dst * ref->item_size, sr, 2299 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2300 1, size, stat, dst_type); 2301 if (src_rank > 0) 2302 src_index[src_dim] 2303 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2304 array_offset_dst += stride_dst; 2305 } 2306 return; 2307 case CAF_ARR_REF_OPEN_START: 2308 COMPUTE_NUM_ITEMS (extent_dst, 2309 ref->u.a.dim[dst_dim].s.stride, 2310 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]), 2311 ref->u.a.dim[dst_dim].s.end); 2312 array_offset_dst = 0; 2313 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) 2314 * ref->u.a.dim[dst_dim].s.stride; 2315 src_index[src_dim] = 0; 2316 for (index_type idx = 0; idx < extent_dst; ++idx) 2317 { 2318 send_by_ref (ref, i, src_index, single_token, dst, src, 2319 ds + array_offset_dst * ref->item_size, sr, 2320 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2321 1, size, stat, dst_type); 2322 if (src_rank > 0) 2323 src_index[src_dim] 2324 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2325 array_offset_dst += stride_dst; 2326 } 2327 return; 2328 default: 2329 caf_runtime_error (unreachable); 2330 } 2331 return; 2332 case CAF_REF_STATIC_ARRAY: 2333 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) 2334 { 2335 send_by_ref (ref->next, i, src_index, single_token, NULL, 2336 src, ds, sr, dst_kind, src_kind, 2337 0, src_dim, 1, size, stat, dst_type); 2338 return; 2339 } 2340 switch (ref->u.a.mode[dst_dim]) 2341 { 2342 case CAF_ARR_REF_VECTOR: 2343 array_offset_dst = 0; 2344 src_index[src_dim] = 0; 2345 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec; 2346 ++idx) 2347 { 2348#define KINDCASE(kind, type) case kind: \ 2349 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \ 2350 break 2351 2352 switch (ref->u.a.dim[dst_dim].v.kind) 2353 { 2354 KINDCASE (1, GFC_INTEGER_1); 2355 KINDCASE (2, GFC_INTEGER_2); 2356 KINDCASE (4, GFC_INTEGER_4); 2357#ifdef HAVE_GFC_INTEGER_8 2358 KINDCASE (8, GFC_INTEGER_8); 2359#endif 2360#ifdef HAVE_GFC_INTEGER_16 2361 KINDCASE (16, GFC_INTEGER_16); 2362#endif 2363 default: 2364 caf_runtime_error (unreachable); 2365 return; 2366 } 2367#undef KINDCASE 2368 2369 send_by_ref (ref, i, src_index, single_token, NULL, src, 2370 ds + array_offset_dst * ref->item_size, sr, 2371 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2372 1, size, stat, dst_type); 2373 src_index[src_dim] 2374 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2375 } 2376 return; 2377 case CAF_ARR_REF_FULL: 2378 src_index[src_dim] = 0; 2379 for (array_offset_dst = 0 ; 2380 array_offset_dst <= ref->u.a.dim[dst_dim].s.end; 2381 array_offset_dst += ref->u.a.dim[dst_dim].s.stride) 2382 { 2383 send_by_ref (ref, i, src_index, single_token, NULL, src, 2384 ds + array_offset_dst * ref->item_size, sr, 2385 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2386 1, size, stat, dst_type); 2387 if (src_rank > 0) 2388 src_index[src_dim] 2389 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2390 } 2391 return; 2392 case CAF_ARR_REF_RANGE: 2393 COMPUTE_NUM_ITEMS (extent_dst, 2394 ref->u.a.dim[dst_dim].s.stride, 2395 ref->u.a.dim[dst_dim].s.start, 2396 ref->u.a.dim[dst_dim].s.end); 2397 array_offset_dst = ref->u.a.dim[dst_dim].s.start; 2398 src_index[src_dim] = 0; 2399 for (index_type idx = 0; idx < extent_dst; ++idx) 2400 { 2401 send_by_ref (ref, i, src_index, single_token, NULL, src, 2402 ds + array_offset_dst * ref->item_size, sr, 2403 dst_kind, src_kind, dst_dim + 1, src_dim + 1, 2404 1, size, stat, dst_type); 2405 if (src_rank > 0) 2406 src_index[src_dim] 2407 += GFC_DIMENSION_STRIDE (src->dim[src_dim]); 2408 array_offset_dst += ref->u.a.dim[dst_dim].s.stride; 2409 } 2410 return; 2411 case CAF_ARR_REF_SINGLE: 2412 array_offset_dst = ref->u.a.dim[dst_dim].s.start; 2413 send_by_ref (ref, i, src_index, single_token, NULL, src, 2414 ds + array_offset_dst * ref->item_size, sr, 2415 dst_kind, src_kind, dst_dim + 1, src_dim, 1, 2416 size, stat, dst_type); 2417 return; 2418 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */ 2419 case CAF_ARR_REF_OPEN_END: 2420 case CAF_ARR_REF_OPEN_START: 2421 default: 2422 caf_runtime_error (unreachable); 2423 } 2424 return; 2425 default: 2426 caf_runtime_error (unreachable); 2427 } 2428} 2429 2430 2431void 2432_gfortran_caf_send_by_ref (caf_token_t token, 2433 int image_index __attribute__ ((unused)), 2434 gfc_descriptor_t *src, caf_reference_t *refs, 2435 int dst_kind, int src_kind, 2436 bool may_require_tmp __attribute__ ((unused)), 2437 bool dst_reallocatable, int *stat, int dst_type) 2438{ 2439 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " 2440 "unknown kind in vector-ref.\n"; 2441 const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): " 2442 "unknown reference type.\n"; 2443 const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): " 2444 "unknown array reference type.\n"; 2445 const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): " 2446 "rank out of range.\n"; 2447 const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): " 2448 "reallocation of array followed by component ref not allowed.\n"; 2449 const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): " 2450 "cannot allocate memory.\n"; 2451 const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): " 2452 "extent of non-allocatable array mismatch.\n"; 2453 const char innercompref[] = "libcaf_single::caf_send_by_ref(): " 2454 "inner unallocated component detected.\n"; 2455 size_t size, i; 2456 size_t dst_index[GFC_MAX_DIMENSIONS]; 2457 int src_rank = GFC_DESCRIPTOR_RANK (src); 2458 int src_cur_dim = 0; 2459 size_t src_size = 0; 2460 caf_single_token_t single_token = TOKEN (token); 2461 void *memptr = single_token->memptr; 2462 gfc_descriptor_t *dst = single_token->desc; 2463 caf_reference_t *riter = refs; 2464 long delta; 2465 bool extent_mismatch; 2466 /* Note that the component is not allocated yet. */ 2467 index_type new_component_idx = -1; 2468 2469 if (stat) 2470 *stat = 0; 2471 2472 /* Compute the size of the result. In the beginning size just counts the 2473 number of elements. */ 2474 size = 1; 2475 while (riter) 2476 { 2477 switch (riter->type) 2478 { 2479 case CAF_REF_COMPONENT: 2480 if (unlikely (new_component_idx != -1)) 2481 { 2482 /* Allocating a component in the middle of a component ref is not 2483 support. We don't know the type to allocate. */ 2484 caf_internal_error (innercompref, stat, NULL, 0); 2485 return; 2486 } 2487 if (riter->u.c.caf_token_offset > 0) 2488 { 2489 /* Check whether the allocatable component is zero, then no 2490 token is present, too. The token's pointer is not cleared 2491 when the structure is initialized. */ 2492 if (*(void**)(memptr + riter->u.c.offset) == NULL) 2493 { 2494 /* This component is not yet allocated. Check that it is 2495 allocatable here. */ 2496 if (!dst_reallocatable) 2497 { 2498 caf_internal_error (cannotallocdst, stat, NULL, 0); 2499 return; 2500 } 2501 single_token = NULL; 2502 memptr = NULL; 2503 dst = NULL; 2504 break; 2505 } 2506 single_token = *(caf_single_token_t*) 2507 (memptr + riter->u.c.caf_token_offset); 2508 memptr += riter->u.c.offset; 2509 dst = single_token->desc; 2510 } 2511 else 2512 { 2513 /* Regular component. */ 2514 memptr += riter->u.c.offset; 2515 dst = (gfc_descriptor_t *)memptr; 2516 } 2517 break; 2518 case CAF_REF_ARRAY: 2519 if (dst != NULL) 2520 memptr = GFC_DESCRIPTOR_DATA (dst); 2521 else 2522 dst = src; 2523 /* When the dst array needs to be allocated, then look at the 2524 extent of the source array in the dimension dst_cur_dim. */ 2525 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 2526 { 2527 switch (riter->u.a.mode[i]) 2528 { 2529 case CAF_ARR_REF_VECTOR: 2530 delta = riter->u.a.dim[i].v.nvec; 2531#define KINDCASE(kind, type) case kind: \ 2532 memptr += (((index_type) \ 2533 ((type *)riter->u.a.dim[i].v.vector)[0]) \ 2534 - GFC_DIMENSION_LBOUND (dst->dim[i])) \ 2535 * GFC_DIMENSION_STRIDE (dst->dim[i]) \ 2536 * riter->item_size; \ 2537 break 2538 2539 switch (riter->u.a.dim[i].v.kind) 2540 { 2541 KINDCASE (1, GFC_INTEGER_1); 2542 KINDCASE (2, GFC_INTEGER_2); 2543 KINDCASE (4, GFC_INTEGER_4); 2544#ifdef HAVE_GFC_INTEGER_8 2545 KINDCASE (8, GFC_INTEGER_8); 2546#endif 2547#ifdef HAVE_GFC_INTEGER_16 2548 KINDCASE (16, GFC_INTEGER_16); 2549#endif 2550 default: 2551 caf_internal_error (vecrefunknownkind, stat, NULL, 0); 2552 return; 2553 } 2554#undef KINDCASE 2555 break; 2556 case CAF_ARR_REF_FULL: 2557 if (dst) 2558 COMPUTE_NUM_ITEMS (delta, 2559 riter->u.a.dim[i].s.stride, 2560 GFC_DIMENSION_LBOUND (dst->dim[i]), 2561 GFC_DIMENSION_UBOUND (dst->dim[i])); 2562 else 2563 COMPUTE_NUM_ITEMS (delta, 2564 riter->u.a.dim[i].s.stride, 2565 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]), 2566 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim])); 2567 break; 2568 case CAF_ARR_REF_RANGE: 2569 COMPUTE_NUM_ITEMS (delta, 2570 riter->u.a.dim[i].s.stride, 2571 riter->u.a.dim[i].s.start, 2572 riter->u.a.dim[i].s.end); 2573 memptr += (riter->u.a.dim[i].s.start 2574 - dst->dim[i].lower_bound) 2575 * GFC_DIMENSION_STRIDE (dst->dim[i]) 2576 * riter->item_size; 2577 break; 2578 case CAF_ARR_REF_SINGLE: 2579 delta = 1; 2580 memptr += (riter->u.a.dim[i].s.start 2581 - dst->dim[i].lower_bound) 2582 * GFC_DIMENSION_STRIDE (dst->dim[i]) 2583 * riter->item_size; 2584 break; 2585 case CAF_ARR_REF_OPEN_END: 2586 if (dst) 2587 COMPUTE_NUM_ITEMS (delta, 2588 riter->u.a.dim[i].s.stride, 2589 riter->u.a.dim[i].s.start, 2590 GFC_DIMENSION_UBOUND (dst->dim[i])); 2591 else 2592 COMPUTE_NUM_ITEMS (delta, 2593 riter->u.a.dim[i].s.stride, 2594 riter->u.a.dim[i].s.start, 2595 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim])); 2596 memptr += (riter->u.a.dim[i].s.start 2597 - dst->dim[i].lower_bound) 2598 * GFC_DIMENSION_STRIDE (dst->dim[i]) 2599 * riter->item_size; 2600 break; 2601 case CAF_ARR_REF_OPEN_START: 2602 if (dst) 2603 COMPUTE_NUM_ITEMS (delta, 2604 riter->u.a.dim[i].s.stride, 2605 GFC_DIMENSION_LBOUND (dst->dim[i]), 2606 riter->u.a.dim[i].s.end); 2607 else 2608 COMPUTE_NUM_ITEMS (delta, 2609 riter->u.a.dim[i].s.stride, 2610 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]), 2611 riter->u.a.dim[i].s.end); 2612 /* The memptr stays unchanged when ref'ing the first element 2613 in a dimension. */ 2614 break; 2615 default: 2616 caf_internal_error (unknownarrreftype, stat, NULL, 0); 2617 return; 2618 } 2619 2620 if (delta <= 0) 2621 return; 2622 /* Check the various properties of the source array. 2623 When src is an array. */ 2624 if (delta > 1 && src_rank > 0) 2625 { 2626 /* Check that src_cur_dim is valid for src. Can be 2627 superceeded only by scalar data. */ 2628 if (src_cur_dim >= src_rank) 2629 { 2630 caf_internal_error (rankoutofrange, stat, NULL, 0); 2631 return; 2632 } 2633 /* Do further checks, when the source is not scalar. */ 2634 else 2635 { 2636 /* When the realloc is required, then no extent may have 2637 been set. */ 2638 extent_mismatch = memptr == NULL 2639 || (dst 2640 && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim) 2641 != delta); 2642 /* When it already known, that a realloc is needed or 2643 the extent does not match the needed one. */ 2644 if (extent_mismatch) 2645 { 2646 /* Check whether dst is reallocatable. */ 2647 if (unlikely (!dst_reallocatable)) 2648 { 2649 caf_internal_error (nonallocextentmismatch, stat, 2650 NULL, 0, delta, 2651 GFC_DESCRIPTOR_EXTENT (dst, 2652 src_cur_dim)); 2653 return; 2654 } 2655 /* Report error on allocatable but missing inner 2656 ref. */ 2657 else if (riter->next != NULL) 2658 { 2659 caf_internal_error (realloconinnerref, stat, NULL, 2660 0); 2661 return; 2662 } 2663 } 2664 /* Only change the extent when it does not match. This is 2665 to prevent resetting given array bounds. */ 2666 if (extent_mismatch) 2667 GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta, 2668 size); 2669 } 2670 /* Increase the dim-counter of the src only when the extent 2671 matches. */ 2672 if (src_cur_dim < src_rank 2673 && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta) 2674 ++src_cur_dim; 2675 } 2676 size *= (index_type)delta; 2677 } 2678 break; 2679 case CAF_REF_STATIC_ARRAY: 2680 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 2681 { 2682 switch (riter->u.a.mode[i]) 2683 { 2684 case CAF_ARR_REF_VECTOR: 2685 delta = riter->u.a.dim[i].v.nvec; 2686#define KINDCASE(kind, type) case kind: \ 2687 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \ 2688 * riter->item_size; \ 2689 break 2690 2691 switch (riter->u.a.dim[i].v.kind) 2692 { 2693 KINDCASE (1, GFC_INTEGER_1); 2694 KINDCASE (2, GFC_INTEGER_2); 2695 KINDCASE (4, GFC_INTEGER_4); 2696#ifdef HAVE_GFC_INTEGER_8 2697 KINDCASE (8, GFC_INTEGER_8); 2698#endif 2699#ifdef HAVE_GFC_INTEGER_16 2700 KINDCASE (16, GFC_INTEGER_16); 2701#endif 2702 default: 2703 caf_internal_error (vecrefunknownkind, stat, NULL, 0); 2704 return; 2705 } 2706#undef KINDCASE 2707 break; 2708 case CAF_ARR_REF_FULL: 2709 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride 2710 + 1; 2711 /* The memptr stays unchanged when ref'ing the first element 2712 in a dimension. */ 2713 break; 2714 case CAF_ARR_REF_RANGE: 2715 COMPUTE_NUM_ITEMS (delta, 2716 riter->u.a.dim[i].s.stride, 2717 riter->u.a.dim[i].s.start, 2718 riter->u.a.dim[i].s.end); 2719 memptr += riter->u.a.dim[i].s.start 2720 * riter->u.a.dim[i].s.stride 2721 * riter->item_size; 2722 break; 2723 case CAF_ARR_REF_SINGLE: 2724 delta = 1; 2725 memptr += riter->u.a.dim[i].s.start 2726 * riter->u.a.dim[i].s.stride 2727 * riter->item_size; 2728 break; 2729 case CAF_ARR_REF_OPEN_END: 2730 /* This and OPEN_START are mapped to a RANGE and therefore 2731 cannot occur here. */ 2732 case CAF_ARR_REF_OPEN_START: 2733 default: 2734 caf_internal_error (unknownarrreftype, stat, NULL, 0); 2735 return; 2736 } 2737 if (delta <= 0) 2738 return; 2739 /* Check the various properties of the source array. 2740 Only when the source array is not scalar examine its 2741 properties. */ 2742 if (delta > 1 && src_rank > 0) 2743 { 2744 /* Check that src_cur_dim is valid for src. Can be 2745 superceeded only by scalar data. */ 2746 if (src_cur_dim >= src_rank) 2747 { 2748 caf_internal_error (rankoutofrange, stat, NULL, 0); 2749 return; 2750 } 2751 else 2752 { 2753 /* We will not be able to realloc the dst, because that's 2754 a fixed size array. */ 2755 extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) 2756 != delta; 2757 /* When the extent does not match the needed one we can 2758 only stop here. */ 2759 if (extent_mismatch) 2760 { 2761 caf_internal_error (nonallocextentmismatch, stat, 2762 NULL, 0, delta, 2763 GFC_DESCRIPTOR_EXTENT (src, 2764 src_cur_dim)); 2765 return; 2766 } 2767 } 2768 ++src_cur_dim; 2769 } 2770 size *= (index_type)delta; 2771 } 2772 break; 2773 default: 2774 caf_internal_error (unknownreftype, stat, NULL, 0); 2775 return; 2776 } 2777 src_size = riter->item_size; 2778 riter = riter->next; 2779 } 2780 if (size == 0 || src_size == 0) 2781 return; 2782 /* Postcondition: 2783 - size contains the number of elements to store in the destination array, 2784 - src_size gives the size in bytes of each item in the destination array. 2785 */ 2786 2787 /* Reset the token. */ 2788 single_token = TOKEN (token); 2789 memptr = single_token->memptr; 2790 dst = single_token->desc; 2791 memset (dst_index, 0, sizeof (dst_index)); 2792 i = 0; 2793 send_by_ref (refs, &i, dst_index, single_token, dst, src, 2794 memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0, 2795 1, size, stat, dst_type); 2796 assert (i == size); 2797} 2798 2799 2800void 2801_gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, 2802 caf_reference_t *dst_refs, caf_token_t src_token, 2803 int src_image_index, 2804 caf_reference_t *src_refs, int dst_kind, 2805 int src_kind, bool may_require_tmp, int *dst_stat, 2806 int *src_stat, int dst_type, int src_type) 2807{ 2808 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp; 2809 GFC_DESCRIPTOR_DATA (&temp) = NULL; 2810 GFC_DESCRIPTOR_RANK (&temp) = -1; 2811 GFC_DESCRIPTOR_TYPE (&temp) = dst_type; 2812 2813 _gfortran_caf_get_by_ref (src_token, src_image_index, 2814 (gfc_descriptor_t *) &temp, src_refs, 2815 dst_kind, src_kind, may_require_tmp, true, 2816 src_stat, src_type); 2817 2818 if (src_stat && *src_stat != 0) 2819 return; 2820 2821 _gfortran_caf_send_by_ref (dst_token, dst_image_index, 2822 (gfc_descriptor_t *) &temp, dst_refs, 2823 dst_kind, dst_kind, may_require_tmp, true, 2824 dst_stat, dst_type); 2825 if (GFC_DESCRIPTOR_DATA (&temp)) 2826 free (GFC_DESCRIPTOR_DATA (&temp)); 2827} 2828 2829 2830void 2831_gfortran_caf_atomic_define (caf_token_t token, size_t offset, 2832 int image_index __attribute__ ((unused)), 2833 void *value, int *stat, 2834 int type __attribute__ ((unused)), int kind) 2835{ 2836 assert(kind == 4); 2837 2838 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset); 2839 2840 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED); 2841 2842 if (stat) 2843 *stat = 0; 2844} 2845 2846void 2847_gfortran_caf_atomic_ref (caf_token_t token, size_t offset, 2848 int image_index __attribute__ ((unused)), 2849 void *value, int *stat, 2850 int type __attribute__ ((unused)), int kind) 2851{ 2852 assert(kind == 4); 2853 2854 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset); 2855 2856 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED); 2857 2858 if (stat) 2859 *stat = 0; 2860} 2861 2862 2863void 2864_gfortran_caf_atomic_cas (caf_token_t token, size_t offset, 2865 int image_index __attribute__ ((unused)), 2866 void *old, void *compare, void *new_val, int *stat, 2867 int type __attribute__ ((unused)), int kind) 2868{ 2869 assert(kind == 4); 2870 2871 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset); 2872 2873 *(uint32_t *) old = *(uint32_t *) compare; 2874 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old, 2875 *(uint32_t *) new_val, false, 2876 __ATOMIC_RELAXED, __ATOMIC_RELAXED); 2877 if (stat) 2878 *stat = 0; 2879} 2880 2881 2882void 2883_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset, 2884 int image_index __attribute__ ((unused)), 2885 void *value, void *old, int *stat, 2886 int type __attribute__ ((unused)), int kind) 2887{ 2888 assert(kind == 4); 2889 2890 uint32_t res; 2891 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset); 2892 2893 switch (op) 2894 { 2895 case GFC_CAF_ATOMIC_ADD: 2896 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED); 2897 break; 2898 case GFC_CAF_ATOMIC_AND: 2899 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED); 2900 break; 2901 case GFC_CAF_ATOMIC_OR: 2902 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED); 2903 break; 2904 case GFC_CAF_ATOMIC_XOR: 2905 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED); 2906 break; 2907 default: 2908 __builtin_unreachable(); 2909 } 2910 2911 if (old) 2912 *(uint32_t *) old = res; 2913 2914 if (stat) 2915 *stat = 0; 2916} 2917 2918void 2919_gfortran_caf_event_post (caf_token_t token, size_t index, 2920 int image_index __attribute__ ((unused)), 2921 int *stat, char *errmsg __attribute__ ((unused)), 2922 size_t errmsg_len __attribute__ ((unused))) 2923{ 2924 uint32_t value = 1; 2925 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index 2926 * sizeof (uint32_t)); 2927 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED); 2928 2929 if(stat) 2930 *stat = 0; 2931} 2932 2933void 2934_gfortran_caf_event_wait (caf_token_t token, size_t index, 2935 int until_count, int *stat, 2936 char *errmsg __attribute__ ((unused)), 2937 size_t errmsg_len __attribute__ ((unused))) 2938{ 2939 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index 2940 * sizeof (uint32_t)); 2941 uint32_t value = (uint32_t)-until_count; 2942 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED); 2943 2944 if(stat) 2945 *stat = 0; 2946} 2947 2948void 2949_gfortran_caf_event_query (caf_token_t token, size_t index, 2950 int image_index __attribute__ ((unused)), 2951 int *count, int *stat) 2952{ 2953 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index 2954 * sizeof (uint32_t)); 2955 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED); 2956 2957 if(stat) 2958 *stat = 0; 2959} 2960 2961void 2962_gfortran_caf_lock (caf_token_t token, size_t index, 2963 int image_index __attribute__ ((unused)), 2964 int *acquired_lock, int *stat, char *errmsg, 2965 size_t errmsg_len) 2966{ 2967 const char *msg = "Already locked"; 2968 bool *lock = &((bool *) MEMTOK (token))[index]; 2969 2970 if (!*lock) 2971 { 2972 *lock = true; 2973 if (acquired_lock) 2974 *acquired_lock = (int) true; 2975 if (stat) 2976 *stat = 0; 2977 return; 2978 } 2979 2980 if (acquired_lock) 2981 { 2982 *acquired_lock = (int) false; 2983 if (stat) 2984 *stat = 0; 2985 return; 2986 } 2987 2988 2989 if (stat) 2990 { 2991 *stat = 1; 2992 if (errmsg_len > 0) 2993 { 2994 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len 2995 : sizeof (msg); 2996 memcpy (errmsg, msg, len); 2997 if (errmsg_len > len) 2998 memset (&errmsg[len], ' ', errmsg_len-len); 2999 } 3000 return; 3001 } 3002 _gfortran_caf_error_stop_str (msg, strlen (msg), false); 3003} 3004 3005 3006void 3007_gfortran_caf_unlock (caf_token_t token, size_t index, 3008 int image_index __attribute__ ((unused)), 3009 int *stat, char *errmsg, size_t errmsg_len) 3010{ 3011 const char *msg = "Variable is not locked"; 3012 bool *lock = &((bool *) MEMTOK (token))[index]; 3013 3014 if (*lock) 3015 { 3016 *lock = false; 3017 if (stat) 3018 *stat = 0; 3019 return; 3020 } 3021 3022 if (stat) 3023 { 3024 *stat = 1; 3025 if (errmsg_len > 0) 3026 { 3027 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len 3028 : sizeof (msg); 3029 memcpy (errmsg, msg, len); 3030 if (errmsg_len > len) 3031 memset (&errmsg[len], ' ', errmsg_len-len); 3032 } 3033 return; 3034 } 3035 _gfortran_caf_error_stop_str (msg, strlen (msg), false); 3036} 3037 3038int 3039_gfortran_caf_is_present (caf_token_t token, 3040 int image_index __attribute__ ((unused)), 3041 caf_reference_t *refs) 3042{ 3043 const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): " 3044 "only scalar indexes allowed.\n"; 3045 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): " 3046 "unknown reference type.\n"; 3047 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): " 3048 "unknown array reference type.\n"; 3049 size_t i; 3050 caf_single_token_t single_token = TOKEN (token); 3051 void *memptr = single_token->memptr; 3052 gfc_descriptor_t *src = single_token->desc; 3053 caf_reference_t *riter = refs; 3054 3055 while (riter) 3056 { 3057 switch (riter->type) 3058 { 3059 case CAF_REF_COMPONENT: 3060 if (riter->u.c.caf_token_offset) 3061 { 3062 single_token = *(caf_single_token_t*) 3063 (memptr + riter->u.c.caf_token_offset); 3064 memptr = single_token->memptr; 3065 src = single_token->desc; 3066 } 3067 else 3068 { 3069 memptr += riter->u.c.offset; 3070 src = (gfc_descriptor_t *)memptr; 3071 } 3072 break; 3073 case CAF_REF_ARRAY: 3074 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 3075 { 3076 switch (riter->u.a.mode[i]) 3077 { 3078 case CAF_ARR_REF_SINGLE: 3079 memptr += (riter->u.a.dim[i].s.start 3080 - GFC_DIMENSION_LBOUND (src->dim[i])) 3081 * GFC_DIMENSION_STRIDE (src->dim[i]) 3082 * riter->item_size; 3083 break; 3084 case CAF_ARR_REF_FULL: 3085 /* A full array ref is allowed on the last reference only. */ 3086 if (riter->next == NULL) 3087 break; 3088 /* else fall through reporting an error. */ 3089 /* FALLTHROUGH */ 3090 case CAF_ARR_REF_VECTOR: 3091 case CAF_ARR_REF_RANGE: 3092 case CAF_ARR_REF_OPEN_END: 3093 case CAF_ARR_REF_OPEN_START: 3094 caf_internal_error (arraddressingnotallowed, 0, NULL, 0); 3095 return 0; 3096 default: 3097 caf_internal_error (unknownarrreftype, 0, NULL, 0); 3098 return 0; 3099 } 3100 } 3101 break; 3102 case CAF_REF_STATIC_ARRAY: 3103 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) 3104 { 3105 switch (riter->u.a.mode[i]) 3106 { 3107 case CAF_ARR_REF_SINGLE: 3108 memptr += riter->u.a.dim[i].s.start 3109 * riter->u.a.dim[i].s.stride 3110 * riter->item_size; 3111 break; 3112 case CAF_ARR_REF_FULL: 3113 /* A full array ref is allowed on the last reference only. */ 3114 if (riter->next == NULL) 3115 break; 3116 /* else fall through reporting an error. */ 3117 /* FALLTHROUGH */ 3118 case CAF_ARR_REF_VECTOR: 3119 case CAF_ARR_REF_RANGE: 3120 case CAF_ARR_REF_OPEN_END: 3121 case CAF_ARR_REF_OPEN_START: 3122 caf_internal_error (arraddressingnotallowed, 0, NULL, 0); 3123 return 0; 3124 default: 3125 caf_internal_error (unknownarrreftype, 0, NULL, 0); 3126 return 0; 3127 } 3128 } 3129 break; 3130 default: 3131 caf_internal_error (unknownreftype, 0, NULL, 0); 3132 return 0; 3133 } 3134 riter = riter->next; 3135 } 3136 return memptr != NULL; 3137} 3138 3139/* Reference the libraries implementation. */ 3140extern void _gfortran_random_init (int32_t, int32_t, int32_t); 3141 3142void _gfortran_caf_random_init (bool repeatable, bool image_distinct) 3143{ 3144 /* In a single image implementation always forward to the gfortran 3145 routine. */ 3146 _gfortran_random_init (repeatable, image_distinct, 1); 3147} 3148