single.c revision 1.1.1.3
1 /* Single-image implementation of GNU Fortran Coarray Library 2 Copyright (C) 2011-2022 Free Software Foundation, Inc. 3 Contributed by Tobias Burnus <burnus (at) net-b.de> 4 5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf). 6 7 Libcaf is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 3, or (at your option) 10 any later version. 11 12 Libcaf is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 Under Section 7 of GPL version 3, you are granted additional 18 permissions described in the GCC Runtime Library Exception, version 19 3.1, as published by the Free Software Foundation. 20 21 You should have received a copy of the GNU General Public License and 22 a copy of the GCC Runtime Library Exception along with this program; 23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24 <http://www.gnu.org/licenses/>. */ 25 26 #include "libcaf.h" 27 #include <stdio.h> /* For fputs and fprintf. */ 28 #include <stdlib.h> /* For exit and malloc. */ 29 #include <string.h> /* For memcpy and memset. */ 30 #include <stdarg.h> /* For variadic arguments. */ 31 #include <stdint.h> 32 #include <assert.h> 33 34 /* Define GFC_CAF_CHECK to enable run-time checking. */ 35 /* #define GFC_CAF_CHECK 1 */ 36 37 struct 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 }; 48 typedef 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. */ 58 caf_static_t *caf_static_list = NULL; 59 60 /* Keep in sync with mpi.c. */ 61 static void 62 caf_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. */ 76 static void 77 caf_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 100 void 101 _gfortran_caf_init (int *argc __attribute__ ((unused)), 102 char ***argv __attribute__ ((unused))) 103 { 104 } 105 106 107 void 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 120 int 121 _gfortran_caf_this_image (int distance __attribute__ ((unused))) 122 { 123 return 1; 124 } 125 126 127 int 128 _gfortran_caf_num_images (int distance __attribute__ ((unused)), 129 int failed __attribute__ ((unused))) 130 { 131 return 1; 132 } 133 134 135 void 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 196 void 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 222 void 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 233 void 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 244 void 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 269 void 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 278 void 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 292 void 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 310 void _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 320 int _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 333 void 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 355 void 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 374 void 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 383 void 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 393 void 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 403 void 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 414 void 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 426 void 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 441 static void 442 assign_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 454 static void 455 assign_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 467 static void 468 convert_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 719 error: 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 729 void 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 922 void 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 1131 void 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. */ 1154 const char unreachable[] = "Fatal error: unreachable alternative found.\n"; 1155 1156 1157 static void 1158 copy_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 1199 static void 1200 get_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 1541 void 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 2023 static void 2024 send_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 2431 void 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 2800 void 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 2830 void 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 2846 void 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 2863 void 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 2882 void 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 2918 void 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 2933 void 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 2948 void 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 2961 void 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 3006 void 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 3038 int 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. */ 3140 extern void _gfortran_random_init (int32_t, int32_t, int32_t); 3141 3142 void _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
Indexes created Wed Apr 01 00:32:07 UTC 2026