ada: Reference to nonexistent operator in reduction expression accepted
[official-gcc.git] / libgfortran / caf / single.c
blob79f7822041dc3c19ae13fb714c647020505704d0
1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2024 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
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.
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.
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.
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/>. */
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>
34 /* Define GFC_CAF_CHECK to enable run-time checking. */
35 /* #define GFC_CAF_CHECK 1 */
37 struct caf_single_token
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;
48 typedef struct caf_single_token *caf_single_token_t;
50 #define TOKEN(X) ((caf_single_token_t) (X))
51 #define MEMTOK(X) ((caf_single_token_t) (X))->memptr
53 /* Single-image implementation of the CAF library.
54 Note: For performance reasons -fcoarry=single should be used
55 rather than this library. */
57 /* Global variables. */
58 caf_static_t *caf_static_list = NULL;
60 /* Keep in sync with mpi.c. */
61 static void
62 caf_runtime_error (const char *message, ...)
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");
71 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
72 exit (EXIT_FAILURE);
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, ...)
80 va_list args;
81 va_start (args, errmsg_len);
82 if (stat)
84 *stat = 1;
85 if (errmsg_len > 0)
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);
91 va_end (args);
92 return;
94 else
95 caf_runtime_error (msg, args);
96 va_end (args);
100 void
101 _gfortran_caf_init (int *argc __attribute__ ((unused)),
102 char ***argv __attribute__ ((unused)))
107 void
108 _gfortran_caf_finalize (void)
110 while (caf_static_list != NULL)
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;
121 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
123 return 1;
128 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
129 int failed __attribute__ ((unused)))
131 return 1;
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)
140 const char alloc_fail_msg[] = "Failed to allocate coarray";
141 void *local;
142 caf_single_token_t single_token;
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);
156 if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
157 *token = malloc (sizeof (struct caf_single_token));
159 if (unlikely (*token == NULL
160 || (local == NULL
161 && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
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 free (local);
167 free (*token);
168 caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
169 return;
172 single_token = TOKEN (*token);
173 single_token->memptr = local;
174 single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
175 single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
178 if (stat)
179 *stat = 0;
181 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
182 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
183 || type == CAF_REGTYPE_EVENT_ALLOC)
185 caf_static_t *tmp = malloc (sizeof (caf_static_t));
186 tmp->prev = caf_static_list;
187 tmp->token = *token;
188 caf_static_list = tmp;
190 GFC_DESCRIPTOR_DATA (data) = local;
194 void
195 _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
196 char *errmsg __attribute__ ((unused)),
197 size_t errmsg_len __attribute__ ((unused)))
199 caf_single_token_t single_token = TOKEN (*token);
201 if (single_token->owning_memory && single_token->memptr)
202 free (single_token->memptr);
204 if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
206 free (TOKEN (*token));
207 *token = NULL;
209 else
211 single_token->memptr = NULL;
212 single_token->owning_memory = false;
215 if (stat)
216 *stat = 0;
220 void
221 _gfortran_caf_sync_all (int *stat,
222 char *errmsg __attribute__ ((unused)),
223 size_t errmsg_len __attribute__ ((unused)))
225 __asm__ __volatile__ ("":::"memory");
226 if (stat)
227 *stat = 0;
231 void
232 _gfortran_caf_sync_memory (int *stat,
233 char *errmsg __attribute__ ((unused)),
234 size_t errmsg_len __attribute__ ((unused)))
236 __asm__ __volatile__ ("":::"memory");
237 if (stat)
238 *stat = 0;
242 void
243 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
244 int images[] __attribute__ ((unused)),
245 int *stat,
246 char *errmsg __attribute__ ((unused)),
247 size_t errmsg_len __attribute__ ((unused)))
249 #ifdef GFC_CAF_CHECK
250 int i;
252 for (i = 0; i < count; i++)
253 if (images[i] != 1)
255 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
256 "IMAGES", images[i]);
257 exit (EXIT_FAILURE);
259 #endif
261 __asm__ __volatile__ ("":::"memory");
262 if (stat)
263 *stat = 0;
267 void
268 _gfortran_caf_stop_numeric(int stop_code, bool quiet)
270 if (!quiet)
271 fprintf (stderr, "STOP %d\n", stop_code);
272 exit (0);
276 void
277 _gfortran_caf_stop_str(const char *string, size_t len, bool quiet)
279 if (!quiet)
281 fputs ("STOP ", stderr);
282 while (len--)
283 fputc (*(string++), stderr);
284 fputs ("\n", stderr);
286 exit (0);
290 void
291 _gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
293 if (!quiet)
295 fputs ("ERROR STOP ", stderr);
296 while (len--)
297 fputc (*(string++), stderr);
298 fputs ("\n", stderr);
300 exit (1);
304 /* Reported that the program terminated because of a fail image issued.
305 Because this is a single image library, nothing else than aborting the whole
306 program can be done. */
308 void _gfortran_caf_fail_image (void)
310 fputs ("IMAGE FAILED!\n", stderr);
311 exit (0);
315 /* Get the status of image IMAGE. Because being the single image library all
316 other images are reported to be stopped. */
318 int _gfortran_caf_image_status (int image,
319 caf_team_t * team __attribute__ ((unused)))
321 if (image == 1)
322 return 0;
323 else
324 return CAF_STAT_STOPPED_IMAGE;
328 /* Single image library. There cannot be any failed images with only one
329 image. */
331 void
332 _gfortran_caf_failed_images (gfc_descriptor_t *array,
333 caf_team_t * team __attribute__ ((unused)),
334 int * kind)
336 int local_kind = kind != NULL ? *kind : 4;
338 array->base_addr = NULL;
339 array->dtype.type = BT_INTEGER;
340 array->dtype.elem_len = local_kind;
341 /* Setting lower_bound higher then upper_bound is what the compiler does to
342 indicate an empty array. */
343 array->dim[0].lower_bound = 0;
344 array->dim[0]._ubound = -1;
345 array->dim[0]._stride = 1;
346 array->offset = 0;
350 /* With only one image available no other images can be stopped. Therefore
351 return an empty array. */
353 void
354 _gfortran_caf_stopped_images (gfc_descriptor_t *array,
355 caf_team_t * team __attribute__ ((unused)),
356 int * kind)
358 int local_kind = kind != NULL ? *kind : 4;
360 array->base_addr = NULL;
361 array->dtype.type = BT_INTEGER;
362 array->dtype.elem_len = local_kind;
363 /* Setting lower_bound higher then upper_bound is what the compiler does to
364 indicate an empty array. */
365 array->dim[0].lower_bound = 0;
366 array->dim[0]._ubound = -1;
367 array->dim[0]._stride = 1;
368 array->offset = 0;
372 void
373 _gfortran_caf_error_stop (int error, bool quiet)
375 if (!quiet)
376 fprintf (stderr, "ERROR STOP %d\n", error);
377 exit (error);
381 void
382 _gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
383 int source_image __attribute__ ((unused)),
384 int *stat, char *errmsg __attribute__ ((unused)),
385 size_t errmsg_len __attribute__ ((unused)))
387 if (stat)
388 *stat = 0;
391 void
392 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
393 int result_image __attribute__ ((unused)),
394 int *stat, char *errmsg __attribute__ ((unused)),
395 size_t errmsg_len __attribute__ ((unused)))
397 if (stat)
398 *stat = 0;
401 void
402 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
403 int result_image __attribute__ ((unused)),
404 int *stat, char *errmsg __attribute__ ((unused)),
405 int a_len __attribute__ ((unused)),
406 size_t errmsg_len __attribute__ ((unused)))
408 if (stat)
409 *stat = 0;
412 void
413 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
414 int result_image __attribute__ ((unused)),
415 int *stat, char *errmsg __attribute__ ((unused)),
416 int a_len __attribute__ ((unused)),
417 size_t errmsg_len __attribute__ ((unused)))
419 if (stat)
420 *stat = 0;
424 void
425 _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
426 void * (*opr) (void *, void *)
427 __attribute__ ((unused)),
428 int opr_flags __attribute__ ((unused)),
429 int result_image __attribute__ ((unused)),
430 int *stat, char *errmsg __attribute__ ((unused)),
431 int a_len __attribute__ ((unused)),
432 size_t errmsg_len __attribute__ ((unused)))
434 if (stat)
435 *stat = 0;
439 static void
440 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
441 unsigned char *src)
443 size_t i, n;
444 n = dst_size/4 > src_size ? src_size : dst_size/4;
445 for (i = 0; i < n; ++i)
446 dst[i] = (int32_t) src[i];
447 for (; i < dst_size/4; ++i)
448 dst[i] = (int32_t) ' ';
452 static void
453 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
454 uint32_t *src)
456 size_t i, n;
457 n = dst_size > src_size/4 ? src_size/4 : dst_size;
458 for (i = 0; i < n; ++i)
459 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
460 if (dst_size > n)
461 memset (&dst[n], ' ', dst_size - n);
465 static void
466 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
467 int src_kind, int *stat)
469 #ifdef HAVE_GFC_INTEGER_16
470 typedef __int128 int128t;
471 #else
472 typedef int64_t int128t;
473 #endif
475 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
476 typedef long double real128t;
477 typedef _Complex long double complex128t;
478 #elif defined(HAVE_GFC_REAL_16)
479 typedef _Float128 real128t;
480 typedef _Complex _Float128 complex128t;
481 #elif defined(HAVE_GFC_REAL_10)
482 typedef long double real128t;
483 typedef _Complex long double complex128t;
484 #else
485 typedef double real128t;
486 typedef _Complex double complex128t;
487 #endif
489 int128t int_val = 0;
490 real128t real_val = 0;
491 complex128t cmpx_val = 0;
493 switch (src_type)
495 case BT_INTEGER:
496 if (src_kind == 1)
497 int_val = *(int8_t*) src;
498 else if (src_kind == 2)
499 int_val = *(int16_t*) src;
500 else if (src_kind == 4)
501 int_val = *(int32_t*) src;
502 else if (src_kind == 8)
503 int_val = *(int64_t*) src;
504 #ifdef HAVE_GFC_INTEGER_16
505 else if (src_kind == 16)
506 int_val = *(int128t*) src;
507 #endif
508 else
509 goto error;
510 break;
511 case BT_REAL:
512 if (src_kind == 4)
513 real_val = *(float*) src;
514 else if (src_kind == 8)
515 real_val = *(double*) src;
516 #ifdef HAVE_GFC_REAL_10
517 else if (src_kind == 10)
518 real_val = *(long double*) src;
519 #endif
520 #ifdef HAVE_GFC_REAL_16
521 else if (src_kind == 16)
522 real_val = *(real128t*) src;
523 #endif
524 else
525 goto error;
526 break;
527 case BT_COMPLEX:
528 if (src_kind == 4)
529 cmpx_val = *(_Complex float*) src;
530 else if (src_kind == 8)
531 cmpx_val = *(_Complex double*) src;
532 #ifdef HAVE_GFC_REAL_10
533 else if (src_kind == 10)
534 cmpx_val = *(_Complex long double*) src;
535 #endif
536 #ifdef HAVE_GFC_REAL_16
537 else if (src_kind == 16)
538 cmpx_val = *(complex128t*) src;
539 #endif
540 else
541 goto error;
542 break;
543 default:
544 goto error;
547 switch (dst_type)
549 case BT_INTEGER:
550 if (src_type == BT_INTEGER)
552 if (dst_kind == 1)
553 *(int8_t*) dst = (int8_t) int_val;
554 else if (dst_kind == 2)
555 *(int16_t*) dst = (int16_t) int_val;
556 else if (dst_kind == 4)
557 *(int32_t*) dst = (int32_t) int_val;
558 else if (dst_kind == 8)
559 *(int64_t*) dst = (int64_t) int_val;
560 #ifdef HAVE_GFC_INTEGER_16
561 else if (dst_kind == 16)
562 *(int128t*) dst = (int128t) int_val;
563 #endif
564 else
565 goto error;
567 else if (src_type == BT_REAL)
569 if (dst_kind == 1)
570 *(int8_t*) dst = (int8_t) real_val;
571 else if (dst_kind == 2)
572 *(int16_t*) dst = (int16_t) real_val;
573 else if (dst_kind == 4)
574 *(int32_t*) dst = (int32_t) real_val;
575 else if (dst_kind == 8)
576 *(int64_t*) dst = (int64_t) real_val;
577 #ifdef HAVE_GFC_INTEGER_16
578 else if (dst_kind == 16)
579 *(int128t*) dst = (int128t) real_val;
580 #endif
581 else
582 goto error;
584 else if (src_type == BT_COMPLEX)
586 if (dst_kind == 1)
587 *(int8_t*) dst = (int8_t) cmpx_val;
588 else if (dst_kind == 2)
589 *(int16_t*) dst = (int16_t) cmpx_val;
590 else if (dst_kind == 4)
591 *(int32_t*) dst = (int32_t) cmpx_val;
592 else if (dst_kind == 8)
593 *(int64_t*) dst = (int64_t) cmpx_val;
594 #ifdef HAVE_GFC_INTEGER_16
595 else if (dst_kind == 16)
596 *(int128t*) dst = (int128t) cmpx_val;
597 #endif
598 else
599 goto error;
601 else
602 goto error;
603 return;
604 case BT_REAL:
605 if (src_type == BT_INTEGER)
607 if (dst_kind == 4)
608 *(float*) dst = (float) int_val;
609 else if (dst_kind == 8)
610 *(double*) dst = (double) int_val;
611 #ifdef HAVE_GFC_REAL_10
612 else if (dst_kind == 10)
613 *(long double*) dst = (long double) int_val;
614 #endif
615 #ifdef HAVE_GFC_REAL_16
616 else if (dst_kind == 16)
617 *(real128t*) dst = (real128t) int_val;
618 #endif
619 else
620 goto error;
622 else if (src_type == BT_REAL)
624 if (dst_kind == 4)
625 *(float*) dst = (float) real_val;
626 else if (dst_kind == 8)
627 *(double*) dst = (double) real_val;
628 #ifdef HAVE_GFC_REAL_10
629 else if (dst_kind == 10)
630 *(long double*) dst = (long double) real_val;
631 #endif
632 #ifdef HAVE_GFC_REAL_16
633 else if (dst_kind == 16)
634 *(real128t*) dst = (real128t) real_val;
635 #endif
636 else
637 goto error;
639 else if (src_type == BT_COMPLEX)
641 if (dst_kind == 4)
642 *(float*) dst = (float) cmpx_val;
643 else if (dst_kind == 8)
644 *(double*) dst = (double) cmpx_val;
645 #ifdef HAVE_GFC_REAL_10
646 else if (dst_kind == 10)
647 *(long double*) dst = (long double) cmpx_val;
648 #endif
649 #ifdef HAVE_GFC_REAL_16
650 else if (dst_kind == 16)
651 *(real128t*) dst = (real128t) cmpx_val;
652 #endif
653 else
654 goto error;
656 return;
657 case BT_COMPLEX:
658 if (src_type == BT_INTEGER)
660 if (dst_kind == 4)
661 *(_Complex float*) dst = (_Complex float) int_val;
662 else if (dst_kind == 8)
663 *(_Complex double*) dst = (_Complex double) int_val;
664 #ifdef HAVE_GFC_REAL_10
665 else if (dst_kind == 10)
666 *(_Complex long double*) dst = (_Complex long double) int_val;
667 #endif
668 #ifdef HAVE_GFC_REAL_16
669 else if (dst_kind == 16)
670 *(complex128t*) dst = (complex128t) int_val;
671 #endif
672 else
673 goto error;
675 else if (src_type == BT_REAL)
677 if (dst_kind == 4)
678 *(_Complex float*) dst = (_Complex float) real_val;
679 else if (dst_kind == 8)
680 *(_Complex double*) dst = (_Complex double) real_val;
681 #ifdef HAVE_GFC_REAL_10
682 else if (dst_kind == 10)
683 *(_Complex long double*) dst = (_Complex long double) real_val;
684 #endif
685 #ifdef HAVE_GFC_REAL_16
686 else if (dst_kind == 16)
687 *(complex128t*) dst = (complex128t) real_val;
688 #endif
689 else
690 goto error;
692 else if (src_type == BT_COMPLEX)
694 if (dst_kind == 4)
695 *(_Complex float*) dst = (_Complex float) cmpx_val;
696 else if (dst_kind == 8)
697 *(_Complex double*) dst = (_Complex double) cmpx_val;
698 #ifdef HAVE_GFC_REAL_10
699 else if (dst_kind == 10)
700 *(_Complex long double*) dst = (_Complex long double) cmpx_val;
701 #endif
702 #ifdef HAVE_GFC_REAL_16
703 else if (dst_kind == 16)
704 *(complex128t*) dst = (complex128t) cmpx_val;
705 #endif
706 else
707 goto error;
709 else
710 goto error;
711 return;
712 default:
713 goto error;
716 error:
717 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
718 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
719 if (stat)
720 *stat = 1;
721 else
722 abort ();
726 void
727 _gfortran_caf_get (caf_token_t token, size_t offset,
728 int image_index __attribute__ ((unused)),
729 gfc_descriptor_t *src,
730 caf_vector_t *src_vector __attribute__ ((unused)),
731 gfc_descriptor_t *dest, int src_kind, int dst_kind,
732 bool may_require_tmp, int *stat)
734 /* FIXME: Handle vector subscripts. */
735 size_t i, k, size;
736 int j;
737 int rank = GFC_DESCRIPTOR_RANK (dest);
738 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
739 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
741 if (stat)
742 *stat = 0;
744 if (rank == 0)
746 void *sr = (void *) ((char *) MEMTOK (token) + offset);
747 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
748 && dst_kind == src_kind)
750 memmove (GFC_DESCRIPTOR_DATA (dest), sr,
751 dst_size > src_size ? src_size : dst_size);
752 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
754 if (dst_kind == 1)
755 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
756 ' ', dst_size - src_size);
757 else /* dst_kind == 4. */
758 for (i = src_size/4; i < dst_size/4; i++)
759 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
762 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
763 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
764 sr);
765 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
766 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
767 sr);
768 else
769 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
770 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
771 return;
774 size = 1;
775 for (j = 0; j < rank; j++)
777 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
778 if (dimextent < 0)
779 dimextent = 0;
780 size *= dimextent;
783 if (size == 0)
784 return;
786 if (may_require_tmp)
788 ptrdiff_t array_offset_sr, array_offset_dst;
789 void *tmp = malloc (size*src_size);
791 array_offset_dst = 0;
792 for (i = 0; i < size; i++)
794 ptrdiff_t array_offset_sr = 0;
795 ptrdiff_t stride = 1;
796 ptrdiff_t extent = 1;
797 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
799 array_offset_sr += ((i / (extent*stride))
800 % (src->dim[j]._ubound
801 - src->dim[j].lower_bound + 1))
802 * src->dim[j]._stride;
803 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
804 stride = src->dim[j]._stride;
806 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
807 void *sr = (void *)((char *) MEMTOK (token) + offset
808 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
809 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
810 array_offset_dst += src_size;
813 array_offset_sr = 0;
814 for (i = 0; i < size; i++)
816 ptrdiff_t array_offset_dst = 0;
817 ptrdiff_t stride = 1;
818 ptrdiff_t extent = 1;
819 for (j = 0; j < rank-1; j++)
821 array_offset_dst += ((i / (extent*stride))
822 % (dest->dim[j]._ubound
823 - dest->dim[j].lower_bound + 1))
824 * dest->dim[j]._stride;
825 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
826 stride = dest->dim[j]._stride;
828 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
829 void *dst = dest->base_addr
830 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
831 void *sr = tmp + array_offset_sr;
833 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
834 && dst_kind == src_kind)
836 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
837 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
838 && dst_size > src_size)
840 if (dst_kind == 1)
841 memset ((void*)(char*) dst + src_size, ' ',
842 dst_size-src_size);
843 else /* dst_kind == 4. */
844 for (k = src_size/4; k < dst_size/4; k++)
845 ((int32_t*) dst)[k] = (int32_t) ' ';
848 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
849 assign_char1_from_char4 (dst_size, src_size, dst, sr);
850 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
851 assign_char4_from_char1 (dst_size, src_size, dst, sr);
852 else
853 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
854 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
855 array_offset_sr += src_size;
858 free (tmp);
859 return;
862 for (i = 0; i < size; i++)
864 ptrdiff_t array_offset_dst = 0;
865 ptrdiff_t stride = 1;
866 ptrdiff_t extent = 1;
867 for (j = 0; j < rank-1; j++)
869 array_offset_dst += ((i / (extent*stride))
870 % (dest->dim[j]._ubound
871 - dest->dim[j].lower_bound + 1))
872 * dest->dim[j]._stride;
873 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
874 stride = dest->dim[j]._stride;
876 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
877 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
879 ptrdiff_t array_offset_sr = 0;
880 stride = 1;
881 extent = 1;
882 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
884 array_offset_sr += ((i / (extent*stride))
885 % (src->dim[j]._ubound
886 - src->dim[j].lower_bound + 1))
887 * src->dim[j]._stride;
888 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
889 stride = src->dim[j]._stride;
891 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
892 void *sr = (void *)((char *) MEMTOK (token) + offset
893 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
895 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
896 && dst_kind == src_kind)
898 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
899 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
901 if (dst_kind == 1)
902 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
903 else /* dst_kind == 4. */
904 for (k = src_size/4; k < dst_size/4; k++)
905 ((int32_t*) dst)[k] = (int32_t) ' ';
908 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
909 assign_char1_from_char4 (dst_size, src_size, dst, sr);
910 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
911 assign_char4_from_char1 (dst_size, src_size, dst, sr);
912 else
913 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
914 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
919 void
920 _gfortran_caf_send (caf_token_t token, size_t offset,
921 int image_index __attribute__ ((unused)),
922 gfc_descriptor_t *dest,
923 caf_vector_t *dst_vector __attribute__ ((unused)),
924 gfc_descriptor_t *src, int dst_kind, int src_kind,
925 bool may_require_tmp, int *stat)
927 /* FIXME: Handle vector subscripts. */
928 size_t i, k, size;
929 int j;
930 int rank = GFC_DESCRIPTOR_RANK (dest);
931 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
932 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
934 if (stat)
935 *stat = 0;
937 if (rank == 0)
939 void *dst = (void *) ((char *) MEMTOK (token) + offset);
940 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
941 && dst_kind == src_kind)
943 memmove (dst, GFC_DESCRIPTOR_DATA (src),
944 dst_size > src_size ? src_size : dst_size);
945 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
947 if (dst_kind == 1)
948 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
949 else /* dst_kind == 4. */
950 for (i = src_size/4; i < dst_size/4; i++)
951 ((int32_t*) dst)[i] = (int32_t) ' ';
954 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
955 assign_char1_from_char4 (dst_size, src_size, dst,
956 GFC_DESCRIPTOR_DATA (src));
957 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
958 assign_char4_from_char1 (dst_size, src_size, dst,
959 GFC_DESCRIPTOR_DATA (src));
960 else
961 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
962 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
963 src_kind, stat);
964 return;
967 size = 1;
968 for (j = 0; j < rank; j++)
970 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
971 if (dimextent < 0)
972 dimextent = 0;
973 size *= dimextent;
976 if (size == 0)
977 return;
979 if (may_require_tmp)
981 ptrdiff_t array_offset_sr, array_offset_dst;
982 void *tmp;
984 if (GFC_DESCRIPTOR_RANK (src) == 0)
986 tmp = malloc (src_size);
987 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
989 else
991 tmp = malloc (size*src_size);
992 array_offset_dst = 0;
993 for (i = 0; i < size; i++)
995 ptrdiff_t array_offset_sr = 0;
996 ptrdiff_t stride = 1;
997 ptrdiff_t extent = 1;
998 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1000 array_offset_sr += ((i / (extent*stride))
1001 % (src->dim[j]._ubound
1002 - src->dim[j].lower_bound + 1))
1003 * src->dim[j]._stride;
1004 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1005 stride = src->dim[j]._stride;
1007 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1008 void *sr = (void *) ((char *) src->base_addr
1009 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1010 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
1011 array_offset_dst += src_size;
1015 array_offset_sr = 0;
1016 for (i = 0; i < size; i++)
1018 ptrdiff_t array_offset_dst = 0;
1019 ptrdiff_t stride = 1;
1020 ptrdiff_t extent = 1;
1021 for (j = 0; j < rank-1; j++)
1023 array_offset_dst += ((i / (extent*stride))
1024 % (dest->dim[j]._ubound
1025 - dest->dim[j].lower_bound + 1))
1026 * dest->dim[j]._stride;
1027 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1028 stride = dest->dim[j]._stride;
1030 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
1031 void *dst = (void *)((char *) MEMTOK (token) + offset
1032 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1033 void *sr = tmp + array_offset_sr;
1034 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1035 && dst_kind == src_kind)
1037 memmove (dst, sr,
1038 dst_size > src_size ? src_size : dst_size);
1039 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
1040 && dst_size > src_size)
1042 if (dst_kind == 1)
1043 memset ((void*)(char*) dst + src_size, ' ',
1044 dst_size-src_size);
1045 else /* dst_kind == 4. */
1046 for (k = src_size/4; k < dst_size/4; k++)
1047 ((int32_t*) dst)[k] = (int32_t) ' ';
1050 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1051 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1052 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1053 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1054 else
1055 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
1056 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
1057 if (GFC_DESCRIPTOR_RANK (src))
1058 array_offset_sr += src_size;
1060 free (tmp);
1061 return;
1064 for (i = 0; i < size; i++)
1066 ptrdiff_t array_offset_dst = 0;
1067 ptrdiff_t stride = 1;
1068 ptrdiff_t extent = 1;
1069 for (j = 0; j < rank-1; j++)
1071 array_offset_dst += ((i / (extent*stride))
1072 % (dest->dim[j]._ubound
1073 - dest->dim[j].lower_bound + 1))
1074 * dest->dim[j]._stride;
1075 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1076 stride = dest->dim[j]._stride;
1078 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
1079 void *dst = (void *)((char *) MEMTOK (token) + offset
1080 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1081 void *sr;
1082 if (GFC_DESCRIPTOR_RANK (src) != 0)
1084 ptrdiff_t array_offset_sr = 0;
1085 stride = 1;
1086 extent = 1;
1087 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1089 array_offset_sr += ((i / (extent*stride))
1090 % (src->dim[j]._ubound
1091 - src->dim[j].lower_bound + 1))
1092 * src->dim[j]._stride;
1093 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1094 stride = src->dim[j]._stride;
1096 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1097 sr = (void *)((char *) src->base_addr
1098 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1100 else
1101 sr = src->base_addr;
1103 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1104 && dst_kind == src_kind)
1106 memmove (dst, sr,
1107 dst_size > src_size ? src_size : dst_size);
1108 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
1110 if (dst_kind == 1)
1111 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
1112 else /* dst_kind == 4. */
1113 for (k = src_size/4; k < dst_size/4; k++)
1114 ((int32_t*) dst)[k] = (int32_t) ' ';
1117 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1118 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1119 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1120 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1121 else
1122 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
1123 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
1128 void
1129 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
1130 int dst_image_index, gfc_descriptor_t *dest,
1131 caf_vector_t *dst_vector, caf_token_t src_token,
1132 size_t src_offset,
1133 int src_image_index __attribute__ ((unused)),
1134 gfc_descriptor_t *src,
1135 caf_vector_t *src_vector __attribute__ ((unused)),
1136 int dst_kind, int src_kind, bool may_require_tmp)
1138 /* FIXME: Handle vector subscript of 'src_vector'. */
1139 /* For a single image, src->base_addr should be the same as src_token + offset
1140 but to play save, we do it properly. */
1141 void *src_base = GFC_DESCRIPTOR_DATA (src);
1142 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
1143 + src_offset);
1144 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
1145 src, dst_kind, src_kind, may_require_tmp, NULL);
1146 GFC_DESCRIPTOR_DATA (src) = src_base;
1150 /* Emitted when a theorectically unreachable part is reached. */
1151 const char unreachable[] = "Fatal error: unreachable alternative found.\n";
1154 static void
1155 copy_data (void *ds, void *sr, int dst_type, int src_type,
1156 int dst_kind, int src_kind, size_t dst_size, size_t src_size,
1157 size_t num, int *stat)
1159 size_t k;
1160 if (dst_type == src_type && dst_kind == src_kind)
1162 memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
1163 if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
1164 && dst_size > src_size)
1166 if (dst_kind == 1)
1167 memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
1168 else /* dst_kind == 4. */
1169 for (k = src_size/4; k < dst_size/4; k++)
1170 ((int32_t*) ds)[k] = (int32_t) ' ';
1173 else if (dst_type == BT_CHARACTER && dst_kind == 1)
1174 assign_char1_from_char4 (dst_size, src_size, ds, sr);
1175 else if (dst_type == BT_CHARACTER)
1176 assign_char4_from_char1 (dst_size, src_size, ds, sr);
1177 else
1178 for (k = 0; k < num; ++k)
1180 convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
1181 ds += dst_size;
1182 sr += src_size;
1187 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1188 do { \
1189 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1190 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1191 if (num <= 0 || abs_stride < 1) return; \
1192 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1193 } while (0)
1196 static void
1197 get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
1198 caf_single_token_t single_token, gfc_descriptor_t *dst,
1199 gfc_descriptor_t *src, void *ds, void *sr,
1200 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
1201 size_t num, int *stat, int src_type)
1203 ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
1204 size_t next_dst_dim;
1206 if (unlikely (ref == NULL))
1207 /* May be we should issue an error here, because this case should not
1208 occur. */
1209 return;
1211 if (ref->next == NULL)
1213 size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
1214 ptrdiff_t array_offset_dst = 0;;
1215 size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
1217 switch (ref->type)
1219 case CAF_REF_COMPONENT:
1220 /* Because the token is always registered after the component, its
1221 offset is always greater zero. */
1222 if (ref->u.c.caf_token_offset > 0)
1223 /* Note, that sr is dereffed here. */
1224 copy_data (ds, *(void **)(sr + ref->u.c.offset),
1225 GFC_DESCRIPTOR_TYPE (dst), src_type,
1226 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1227 else
1228 copy_data (ds, sr + ref->u.c.offset,
1229 GFC_DESCRIPTOR_TYPE (dst), src_type,
1230 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1231 ++(*i);
1232 return;
1233 case CAF_REF_STATIC_ARRAY:
1234 /* Intentionally fall through. */
1235 case CAF_REF_ARRAY:
1236 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1238 for (size_t d = 0; d < dst_rank; ++d)
1239 array_offset_dst += dst_index[d];
1240 copy_data (ds + array_offset_dst * dst_size, sr,
1241 GFC_DESCRIPTOR_TYPE (dst), src_type,
1242 dst_kind, src_kind, dst_size, ref->item_size, num,
1243 stat);
1244 *i += num;
1245 return;
1247 break;
1248 default:
1249 caf_runtime_error (unreachable);
1253 switch (ref->type)
1255 case CAF_REF_COMPONENT:
1256 if (ref->u.c.caf_token_offset > 0)
1258 single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset);
1260 if (ref->next && ref->next->type == CAF_REF_ARRAY)
1261 src = single_token->desc;
1262 else
1263 src = NULL;
1265 if (ref->next && ref->next->type == CAF_REF_COMPONENT)
1266 /* The currently ref'ed component was allocatabe (caf_token_offset
1267 > 0) and the next ref is a component, too, then the new sr has to
1268 be dereffed. (static arrays cannot be allocatable or they
1269 become an array with descriptor. */
1270 sr = *(void **)(sr + ref->u.c.offset);
1271 else
1272 sr += ref->u.c.offset;
1274 get_for_ref (ref->next, i, dst_index, single_token, dst, src,
1275 ds, sr, dst_kind, src_kind, dst_dim, 0,
1276 1, stat, src_type);
1278 else
1279 get_for_ref (ref->next, i, dst_index, single_token, dst,
1280 (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
1281 sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
1282 stat, src_type);
1283 return;
1284 case CAF_REF_ARRAY:
1285 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1287 get_for_ref (ref->next, i, dst_index, single_token, dst,
1288 src, ds, sr, dst_kind, src_kind,
1289 dst_dim, 0, 1, stat, src_type);
1290 return;
1292 /* Only when on the left most index switch the data pointer to
1293 the array's data pointer. */
1294 if (src_dim == 0)
1295 sr = GFC_DESCRIPTOR_DATA (src);
1296 switch (ref->u.a.mode[src_dim])
1298 case CAF_ARR_REF_VECTOR:
1299 extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
1300 array_offset_src = 0;
1301 dst_index[dst_dim] = 0;
1302 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1303 ++idx)
1305 #define KINDCASE(kind, type) case kind: \
1306 array_offset_src = (((index_type) \
1307 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1308 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1309 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1310 break
1312 switch (ref->u.a.dim[src_dim].v.kind)
1314 KINDCASE (1, GFC_INTEGER_1);
1315 KINDCASE (2, GFC_INTEGER_2);
1316 KINDCASE (4, GFC_INTEGER_4);
1317 #ifdef HAVE_GFC_INTEGER_8
1318 KINDCASE (8, GFC_INTEGER_8);
1319 #endif
1320 #ifdef HAVE_GFC_INTEGER_16
1321 KINDCASE (16, GFC_INTEGER_16);
1322 #endif
1323 default:
1324 caf_runtime_error (unreachable);
1325 return;
1327 #undef KINDCASE
1329 get_for_ref (ref, i, dst_index, single_token, dst, src,
1330 ds, sr + array_offset_src * ref->item_size,
1331 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1332 1, stat, src_type);
1333 dst_index[dst_dim]
1334 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1336 return;
1337 case CAF_ARR_REF_FULL:
1338 COMPUTE_NUM_ITEMS (extent_src,
1339 ref->u.a.dim[src_dim].s.stride,
1340 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1341 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1342 stride_src = src->dim[src_dim]._stride
1343 * ref->u.a.dim[src_dim].s.stride;
1344 array_offset_src = 0;
1345 dst_index[dst_dim] = 0;
1346 for (index_type idx = 0; idx < extent_src;
1347 ++idx, array_offset_src += stride_src)
1349 get_for_ref (ref, i, dst_index, single_token, dst, src,
1350 ds, sr + array_offset_src * ref->item_size,
1351 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1352 1, stat, src_type);
1353 dst_index[dst_dim]
1354 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1356 return;
1357 case CAF_ARR_REF_RANGE:
1358 COMPUTE_NUM_ITEMS (extent_src,
1359 ref->u.a.dim[src_dim].s.stride,
1360 ref->u.a.dim[src_dim].s.start,
1361 ref->u.a.dim[src_dim].s.end);
1362 array_offset_src = (ref->u.a.dim[src_dim].s.start
1363 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1364 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1365 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1366 * ref->u.a.dim[src_dim].s.stride;
1367 dst_index[dst_dim] = 0;
1368 /* Increase the dst_dim only, when the src_extent is greater one
1369 or src and dst extent are both one. Don't increase when the scalar
1370 source is not present in the dst. */
1371 next_dst_dim = extent_src > 1
1372 || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
1373 && extent_src == 1) ? (dst_dim + 1) : dst_dim;
1374 for (index_type idx = 0; idx < extent_src; ++idx)
1376 get_for_ref (ref, i, dst_index, single_token, dst, src,
1377 ds, sr + array_offset_src * ref->item_size,
1378 dst_kind, src_kind, next_dst_dim, src_dim + 1,
1379 1, stat, src_type);
1380 dst_index[dst_dim]
1381 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1382 array_offset_src += stride_src;
1384 return;
1385 case CAF_ARR_REF_SINGLE:
1386 array_offset_src = (ref->u.a.dim[src_dim].s.start
1387 - src->dim[src_dim].lower_bound)
1388 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1389 dst_index[dst_dim] = 0;
1390 get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
1391 sr + array_offset_src * ref->item_size,
1392 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1393 stat, src_type);
1394 return;
1395 case CAF_ARR_REF_OPEN_END:
1396 COMPUTE_NUM_ITEMS (extent_src,
1397 ref->u.a.dim[src_dim].s.stride,
1398 ref->u.a.dim[src_dim].s.start,
1399 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1400 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1401 * ref->u.a.dim[src_dim].s.stride;
1402 array_offset_src = (ref->u.a.dim[src_dim].s.start
1403 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1404 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1405 dst_index[dst_dim] = 0;
1406 for (index_type idx = 0; idx < extent_src; ++idx)
1408 get_for_ref (ref, i, dst_index, single_token, dst, src,
1409 ds, sr + array_offset_src * ref->item_size,
1410 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1411 1, stat, src_type);
1412 dst_index[dst_dim]
1413 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1414 array_offset_src += stride_src;
1416 return;
1417 case CAF_ARR_REF_OPEN_START:
1418 COMPUTE_NUM_ITEMS (extent_src,
1419 ref->u.a.dim[src_dim].s.stride,
1420 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1421 ref->u.a.dim[src_dim].s.end);
1422 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1423 * ref->u.a.dim[src_dim].s.stride;
1424 array_offset_src = 0;
1425 dst_index[dst_dim] = 0;
1426 for (index_type idx = 0; idx < extent_src; ++idx)
1428 get_for_ref (ref, i, dst_index, single_token, dst, src,
1429 ds, sr + array_offset_src * ref->item_size,
1430 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1431 1, stat, src_type);
1432 dst_index[dst_dim]
1433 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1434 array_offset_src += stride_src;
1436 return;
1437 default:
1438 caf_runtime_error (unreachable);
1440 return;
1441 case CAF_REF_STATIC_ARRAY:
1442 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1444 get_for_ref (ref->next, i, dst_index, single_token, dst,
1445 NULL, ds, sr, dst_kind, src_kind,
1446 dst_dim, 0, 1, stat, src_type);
1447 return;
1449 switch (ref->u.a.mode[src_dim])
1451 case CAF_ARR_REF_VECTOR:
1452 array_offset_src = 0;
1453 dst_index[dst_dim] = 0;
1454 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1455 ++idx)
1457 #define KINDCASE(kind, type) case kind: \
1458 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1459 break
1461 switch (ref->u.a.dim[src_dim].v.kind)
1463 KINDCASE (1, GFC_INTEGER_1);
1464 KINDCASE (2, GFC_INTEGER_2);
1465 KINDCASE (4, GFC_INTEGER_4);
1466 #ifdef HAVE_GFC_INTEGER_8
1467 KINDCASE (8, GFC_INTEGER_8);
1468 #endif
1469 #ifdef HAVE_GFC_INTEGER_16
1470 KINDCASE (16, GFC_INTEGER_16);
1471 #endif
1472 default:
1473 caf_runtime_error (unreachable);
1474 return;
1476 #undef KINDCASE
1478 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1479 ds, sr + array_offset_src * ref->item_size,
1480 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1481 1, stat, src_type);
1482 dst_index[dst_dim]
1483 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1485 return;
1486 case CAF_ARR_REF_FULL:
1487 dst_index[dst_dim] = 0;
1488 for (array_offset_src = 0 ;
1489 array_offset_src <= ref->u.a.dim[src_dim].s.end;
1490 array_offset_src += ref->u.a.dim[src_dim].s.stride)
1492 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1493 ds, sr + array_offset_src * ref->item_size,
1494 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1495 1, stat, src_type);
1496 dst_index[dst_dim]
1497 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1499 return;
1500 case CAF_ARR_REF_RANGE:
1501 COMPUTE_NUM_ITEMS (extent_src,
1502 ref->u.a.dim[src_dim].s.stride,
1503 ref->u.a.dim[src_dim].s.start,
1504 ref->u.a.dim[src_dim].s.end);
1505 array_offset_src = ref->u.a.dim[src_dim].s.start;
1506 dst_index[dst_dim] = 0;
1507 for (index_type idx = 0; idx < extent_src; ++idx)
1509 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1510 ds, sr + array_offset_src * ref->item_size,
1511 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1512 1, stat, src_type);
1513 dst_index[dst_dim]
1514 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1515 array_offset_src += ref->u.a.dim[src_dim].s.stride;
1517 return;
1518 case CAF_ARR_REF_SINGLE:
1519 array_offset_src = ref->u.a.dim[src_dim].s.start;
1520 get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
1521 sr + array_offset_src * ref->item_size,
1522 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1523 stat, src_type);
1524 return;
1525 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
1526 case CAF_ARR_REF_OPEN_END:
1527 case CAF_ARR_REF_OPEN_START:
1528 default:
1529 caf_runtime_error (unreachable);
1531 return;
1532 default:
1533 caf_runtime_error (unreachable);
1538 void
1539 _gfortran_caf_get_by_ref (caf_token_t token,
1540 int image_index __attribute__ ((unused)),
1541 gfc_descriptor_t *dst, caf_reference_t *refs,
1542 int dst_kind, int src_kind,
1543 bool may_require_tmp __attribute__ ((unused)),
1544 bool dst_reallocatable, int *stat,
1545 int src_type)
1547 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
1548 "unknown kind in vector-ref.\n";
1549 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
1550 "unknown reference type.\n";
1551 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
1552 "unknown array reference type.\n";
1553 const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1554 "rank out of range.\n";
1555 const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1556 "extent out of range.\n";
1557 const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
1558 "cannot allocate memory.\n";
1559 const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
1560 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1561 const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
1562 "two or more array part references are not supported.\n";
1563 size_t size, i;
1564 size_t dst_index[GFC_MAX_DIMENSIONS];
1565 int dst_rank = GFC_DESCRIPTOR_RANK (dst);
1566 int dst_cur_dim = 0;
1567 size_t src_size = 0;
1568 caf_single_token_t single_token = TOKEN (token);
1569 void *memptr = single_token->memptr;
1570 gfc_descriptor_t *src = single_token->desc;
1571 caf_reference_t *riter = refs;
1572 long delta;
1573 /* Reallocation of dst.data is needed (e.g., array to small). */
1574 bool realloc_needed;
1575 /* Reallocation of dst.data is required, because data is not alloced at
1576 all. */
1577 bool realloc_required;
1578 bool extent_mismatch = false;
1579 /* Set when the first non-scalar array reference is encountered. */
1580 bool in_array_ref = false;
1581 bool array_extent_fixed = false;
1582 realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
1584 assert (!realloc_needed || dst_reallocatable);
1586 if (stat)
1587 *stat = 0;
1589 /* Compute the size of the result. In the beginning size just counts the
1590 number of elements. */
1591 size = 1;
1592 while (riter)
1594 switch (riter->type)
1596 case CAF_REF_COMPONENT:
1597 if (riter->u.c.caf_token_offset)
1599 single_token = *(caf_single_token_t*)
1600 (memptr + riter->u.c.caf_token_offset);
1601 memptr = single_token->memptr;
1602 src = single_token->desc;
1604 else
1606 memptr += riter->u.c.offset;
1607 /* When the next ref is an array ref, assume there is an
1608 array descriptor at memptr. Note, static arrays do not have
1609 a descriptor. */
1610 if (riter->next && riter->next->type == CAF_REF_ARRAY)
1611 src = (gfc_descriptor_t *)memptr;
1612 else
1613 src = NULL;
1615 break;
1616 case CAF_REF_ARRAY:
1617 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1619 switch (riter->u.a.mode[i])
1621 case CAF_ARR_REF_VECTOR:
1622 delta = riter->u.a.dim[i].v.nvec;
1623 #define KINDCASE(kind, type) case kind: \
1624 memptr += (((index_type) \
1625 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1626 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1627 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1628 * riter->item_size; \
1629 break
1631 switch (riter->u.a.dim[i].v.kind)
1633 KINDCASE (1, GFC_INTEGER_1);
1634 KINDCASE (2, GFC_INTEGER_2);
1635 KINDCASE (4, GFC_INTEGER_4);
1636 #ifdef HAVE_GFC_INTEGER_8
1637 KINDCASE (8, GFC_INTEGER_8);
1638 #endif
1639 #ifdef HAVE_GFC_INTEGER_16
1640 KINDCASE (16, GFC_INTEGER_16);
1641 #endif
1642 default:
1643 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1644 return;
1646 #undef KINDCASE
1647 break;
1648 case CAF_ARR_REF_FULL:
1649 COMPUTE_NUM_ITEMS (delta,
1650 riter->u.a.dim[i].s.stride,
1651 GFC_DIMENSION_LBOUND (src->dim[i]),
1652 GFC_DIMENSION_UBOUND (src->dim[i]));
1653 /* The memptr stays unchanged when ref'ing the first element
1654 in a dimension. */
1655 break;
1656 case CAF_ARR_REF_RANGE:
1657 COMPUTE_NUM_ITEMS (delta,
1658 riter->u.a.dim[i].s.stride,
1659 riter->u.a.dim[i].s.start,
1660 riter->u.a.dim[i].s.end);
1661 memptr += (riter->u.a.dim[i].s.start
1662 - GFC_DIMENSION_LBOUND (src->dim[i]))
1663 * GFC_DIMENSION_STRIDE (src->dim[i])
1664 * riter->item_size;
1665 break;
1666 case CAF_ARR_REF_SINGLE:
1667 delta = 1;
1668 memptr += (riter->u.a.dim[i].s.start
1669 - GFC_DIMENSION_LBOUND (src->dim[i]))
1670 * GFC_DIMENSION_STRIDE (src->dim[i])
1671 * riter->item_size;
1672 break;
1673 case CAF_ARR_REF_OPEN_END:
1674 COMPUTE_NUM_ITEMS (delta,
1675 riter->u.a.dim[i].s.stride,
1676 riter->u.a.dim[i].s.start,
1677 GFC_DIMENSION_UBOUND (src->dim[i]));
1678 memptr += (riter->u.a.dim[i].s.start
1679 - GFC_DIMENSION_LBOUND (src->dim[i]))
1680 * GFC_DIMENSION_STRIDE (src->dim[i])
1681 * riter->item_size;
1682 break;
1683 case CAF_ARR_REF_OPEN_START:
1684 COMPUTE_NUM_ITEMS (delta,
1685 riter->u.a.dim[i].s.stride,
1686 GFC_DIMENSION_LBOUND (src->dim[i]),
1687 riter->u.a.dim[i].s.end);
1688 /* The memptr stays unchanged when ref'ing the first element
1689 in a dimension. */
1690 break;
1691 default:
1692 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1693 return;
1695 if (delta <= 0)
1696 return;
1697 /* Check the various properties of the destination array.
1698 Is an array expected and present? */
1699 if (delta > 1 && dst_rank == 0)
1701 /* No, an array is required, but not provided. */
1702 caf_internal_error (extentoutofrange, stat, NULL, 0);
1703 return;
1705 /* Special mode when called by __caf_sendget_by_ref (). */
1706 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1708 dst_rank = dst_cur_dim + 1;
1709 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1710 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1712 /* When dst is an array. */
1713 if (dst_rank > 0)
1715 /* Check that dst_cur_dim is valid for dst. Can be
1716 superceeded only by scalar data. */
1717 if (dst_cur_dim >= dst_rank && delta != 1)
1719 caf_internal_error (rankoutofrange, stat, NULL, 0);
1720 return;
1722 /* Do further checks, when the source is not scalar. */
1723 else if (delta != 1)
1725 /* Check that the extent is not scalar and we are not in
1726 an array ref for the dst side. */
1727 if (!in_array_ref)
1729 /* Check that this is the non-scalar extent. */
1730 if (!array_extent_fixed)
1732 /* In an array extent now. */
1733 in_array_ref = true;
1734 /* Check that we haven't skipped any scalar
1735 dimensions yet and that the dst is
1736 compatible. */
1737 if (i > 0
1738 && dst_rank == GFC_DESCRIPTOR_RANK (src))
1740 if (dst_reallocatable)
1742 /* Dst is reallocatable, which means that
1743 the bounds are not set. Set them. */
1744 for (dst_cur_dim= 0; dst_cur_dim < (int)i;
1745 ++dst_cur_dim)
1746 GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
1747 1, 1, 1);
1749 else
1750 dst_cur_dim = i;
1752 /* Else press thumbs, that there are enough
1753 dimensional refs to come. Checked below. */
1755 else
1757 caf_internal_error (doublearrayref, stat, NULL,
1759 return;
1762 /* When the realloc is required, then no extent may have
1763 been set. */
1764 extent_mismatch = realloc_required
1765 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1766 /* When it already known, that a realloc is needed or
1767 the extent does not match the needed one. */
1768 if (realloc_required || realloc_needed
1769 || extent_mismatch)
1771 /* Check whether dst is reallocatable. */
1772 if (unlikely (!dst_reallocatable))
1774 caf_internal_error (nonallocextentmismatch, stat,
1775 NULL, 0, delta,
1776 GFC_DESCRIPTOR_EXTENT (dst,
1777 dst_cur_dim));
1778 return;
1780 /* Only report an error, when the extent needs to be
1781 modified, which is not allowed. */
1782 else if (!dst_reallocatable && extent_mismatch)
1784 caf_internal_error (extentoutofrange, stat, NULL,
1786 return;
1788 realloc_needed = true;
1790 /* Only change the extent when it does not match. This is
1791 to prevent resetting given array bounds. */
1792 if (extent_mismatch)
1793 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1794 size);
1797 /* Only increase the dim counter, when in an array ref. */
1798 if (in_array_ref && dst_cur_dim < dst_rank)
1799 ++dst_cur_dim;
1801 size *= (index_type)delta;
1803 if (in_array_ref)
1805 array_extent_fixed = true;
1806 in_array_ref = false;
1807 /* Check, if we got less dimensional refs than the rank of dst
1808 expects. */
1809 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1811 break;
1812 case CAF_REF_STATIC_ARRAY:
1813 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1815 switch (riter->u.a.mode[i])
1817 case CAF_ARR_REF_VECTOR:
1818 delta = riter->u.a.dim[i].v.nvec;
1819 #define KINDCASE(kind, type) case kind: \
1820 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1821 * riter->item_size; \
1822 break
1824 switch (riter->u.a.dim[i].v.kind)
1826 KINDCASE (1, GFC_INTEGER_1);
1827 KINDCASE (2, GFC_INTEGER_2);
1828 KINDCASE (4, GFC_INTEGER_4);
1829 #ifdef HAVE_GFC_INTEGER_8
1830 KINDCASE (8, GFC_INTEGER_8);
1831 #endif
1832 #ifdef HAVE_GFC_INTEGER_16
1833 KINDCASE (16, GFC_INTEGER_16);
1834 #endif
1835 default:
1836 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1837 return;
1839 #undef KINDCASE
1840 break;
1841 case CAF_ARR_REF_FULL:
1842 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
1843 + 1;
1844 /* The memptr stays unchanged when ref'ing the first element
1845 in a dimension. */
1846 break;
1847 case CAF_ARR_REF_RANGE:
1848 COMPUTE_NUM_ITEMS (delta,
1849 riter->u.a.dim[i].s.stride,
1850 riter->u.a.dim[i].s.start,
1851 riter->u.a.dim[i].s.end);
1852 memptr += riter->u.a.dim[i].s.start
1853 * riter->u.a.dim[i].s.stride
1854 * riter->item_size;
1855 break;
1856 case CAF_ARR_REF_SINGLE:
1857 delta = 1;
1858 memptr += riter->u.a.dim[i].s.start
1859 * riter->u.a.dim[i].s.stride
1860 * riter->item_size;
1861 break;
1862 case CAF_ARR_REF_OPEN_END:
1863 /* This and OPEN_START are mapped to a RANGE and therefore
1864 cannot occur here. */
1865 case CAF_ARR_REF_OPEN_START:
1866 default:
1867 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1868 return;
1870 if (delta <= 0)
1871 return;
1872 /* Check the various properties of the destination array.
1873 Is an array expected and present? */
1874 if (delta > 1 && dst_rank == 0)
1876 /* No, an array is required, but not provided. */
1877 caf_internal_error (extentoutofrange, stat, NULL, 0);
1878 return;
1880 /* Special mode when called by __caf_sendget_by_ref (). */
1881 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1883 dst_rank = dst_cur_dim + 1;
1884 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1885 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1887 /* When dst is an array. */
1888 if (dst_rank > 0)
1890 /* Check that dst_cur_dim is valid for dst. Can be
1891 superceeded only by scalar data. */
1892 if (dst_cur_dim >= dst_rank && delta != 1)
1894 caf_internal_error (rankoutofrange, stat, NULL, 0);
1895 return;
1897 /* Do further checks, when the source is not scalar. */
1898 else if (delta != 1)
1900 /* Check that the extent is not scalar and we are not in
1901 an array ref for the dst side. */
1902 if (!in_array_ref)
1904 /* Check that this is the non-scalar extent. */
1905 if (!array_extent_fixed)
1907 /* In an array extent now. */
1908 in_array_ref = true;
1909 /* The dst is not reallocatable, so nothing more
1910 to do, then correct the dim counter. */
1911 dst_cur_dim = i;
1913 else
1915 caf_internal_error (doublearrayref, stat, NULL,
1917 return;
1920 /* When the realloc is required, then no extent may have
1921 been set. */
1922 extent_mismatch = realloc_required
1923 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1924 /* When it is already known, that a realloc is needed or
1925 the extent does not match the needed one. */
1926 if (realloc_required || realloc_needed
1927 || extent_mismatch)
1929 /* Check whether dst is reallocatable. */
1930 if (unlikely (!dst_reallocatable))
1932 caf_internal_error (nonallocextentmismatch, stat,
1933 NULL, 0, delta,
1934 GFC_DESCRIPTOR_EXTENT (dst,
1935 dst_cur_dim));
1936 return;
1938 /* Only report an error, when the extent needs to be
1939 modified, which is not allowed. */
1940 else if (!dst_reallocatable && extent_mismatch)
1942 caf_internal_error (extentoutofrange, stat, NULL,
1944 return;
1946 realloc_needed = true;
1948 /* Only change the extent when it does not match. This is
1949 to prevent resetting given array bounds. */
1950 if (extent_mismatch)
1951 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1952 size);
1954 /* Only increase the dim counter, when in an array ref. */
1955 if (in_array_ref && dst_cur_dim < dst_rank)
1956 ++dst_cur_dim;
1958 size *= (index_type)delta;
1960 if (in_array_ref)
1962 array_extent_fixed = true;
1963 in_array_ref = false;
1964 /* Check, if we got less dimensional refs than the rank of dst
1965 expects. */
1966 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1968 break;
1969 default:
1970 caf_internal_error (unknownreftype, stat, NULL, 0);
1971 return;
1973 src_size = riter->item_size;
1974 riter = riter->next;
1976 if (size == 0 || src_size == 0)
1977 return;
1978 /* Postcondition:
1979 - size contains the number of elements to store in the destination array,
1980 - src_size gives the size in bytes of each item in the destination array.
1983 if (realloc_needed)
1985 if (!array_extent_fixed)
1987 assert (size == 1);
1988 /* Special mode when called by __caf_sendget_by_ref (). */
1989 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1991 dst_rank = dst_cur_dim + 1;
1992 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1993 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1995 /* This can happen only, when the result is scalar. */
1996 for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
1997 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
2000 GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
2001 if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
2003 caf_internal_error (cannotallocdst, stat, NULL, 0);
2004 return;
2008 /* Reset the token. */
2009 single_token = TOKEN (token);
2010 memptr = single_token->memptr;
2011 src = single_token->desc;
2012 memset(dst_index, 0, sizeof (dst_index));
2013 i = 0;
2014 get_for_ref (refs, &i, dst_index, single_token, dst, src,
2015 GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
2016 1, stat, src_type);
2020 static void
2021 send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
2022 caf_single_token_t single_token, gfc_descriptor_t *dst,
2023 gfc_descriptor_t *src, void *ds, void *sr,
2024 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
2025 size_t num, size_t size, int *stat, int dst_type)
2027 const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
2028 "unknown kind in vector-ref.\n";
2029 ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
2030 const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
2032 if (unlikely (ref == NULL))
2033 /* May be we should issue an error here, because this case should not
2034 occur. */
2035 return;
2037 if (ref->next == NULL)
2039 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
2040 ptrdiff_t array_offset_src = 0;;
2042 switch (ref->type)
2044 case CAF_REF_COMPONENT:
2045 if (ref->u.c.caf_token_offset > 0)
2047 if (*(void**)(ds + ref->u.c.offset) == NULL)
2049 /* Create a scalar temporary array descriptor. */
2050 gfc_descriptor_t static_dst;
2051 GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
2052 GFC_DESCRIPTOR_DTYPE (&static_dst)
2053 = GFC_DESCRIPTOR_DTYPE (src);
2054 /* The component can be allocated now, because it is a
2055 scalar. */
2056 _gfortran_caf_register (ref->item_size,
2057 CAF_REGTYPE_COARRAY_ALLOC,
2058 ds + ref->u.c.caf_token_offset,
2059 &static_dst, stat, NULL, 0);
2060 single_token = *(caf_single_token_t *)
2061 (ds + ref->u.c.caf_token_offset);
2062 /* In case of an error in allocation return. When stat is
2063 NULL, then register_component() terminates on error. */
2064 if (stat != NULL && *stat)
2065 return;
2066 /* Publish the allocated memory. */
2067 *((void **)(ds + ref->u.c.offset))
2068 = GFC_DESCRIPTOR_DATA (&static_dst);
2069 ds = GFC_DESCRIPTOR_DATA (&static_dst);
2070 /* Set the type from the src. */
2071 dst_type = GFC_DESCRIPTOR_TYPE (src);
2073 else
2075 single_token = *(caf_single_token_t *)
2076 (ds + ref->u.c.caf_token_offset);
2077 dst = single_token->desc;
2078 if (dst)
2080 ds = GFC_DESCRIPTOR_DATA (dst);
2081 dst_type = GFC_DESCRIPTOR_TYPE (dst);
2083 else
2084 ds = *(void **)(ds + ref->u.c.offset);
2086 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
2087 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
2089 else
2090 copy_data (ds + ref->u.c.offset, sr, dst_type,
2091 GFC_DESCRIPTOR_TYPE (src),
2092 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
2093 ++(*i);
2094 return;
2095 case CAF_REF_STATIC_ARRAY:
2096 /* Intentionally fall through. */
2097 case CAF_REF_ARRAY:
2098 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2100 if (src_rank > 0)
2102 for (size_t d = 0; d < src_rank; ++d)
2103 array_offset_src += src_index[d];
2104 copy_data (ds, sr + array_offset_src * src_size,
2105 dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind,
2106 src_kind, ref->item_size, src_size, num, stat);
2108 else
2109 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
2110 dst_kind, src_kind, ref->item_size, src_size, num,
2111 stat);
2112 *i += num;
2113 return;
2115 break;
2116 default:
2117 caf_runtime_error (unreachable);
2121 switch (ref->type)
2123 case CAF_REF_COMPONENT:
2124 if (ref->u.c.caf_token_offset > 0)
2126 if (*(void**)(ds + ref->u.c.offset) == NULL)
2128 /* This component refs an unallocated array. Non-arrays are
2129 caught in the if (!ref->next) above. */
2130 dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
2131 /* Assume that the rank and the dimensions fit for copying src
2132 to dst. */
2133 GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
2134 dst->offset = 0;
2135 stride_dst = 1;
2136 for (size_t d = 0; d < src_rank; ++d)
2138 extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
2139 GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
2140 GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
2141 GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
2142 stride_dst *= extent_dst;
2144 /* Null the data-pointer to make register_component allocate
2145 its own memory. */
2146 GFC_DESCRIPTOR_DATA (dst) = NULL;
2148 /* The size of the array is given by size. */
2149 _gfortran_caf_register (size * ref->item_size,
2150 CAF_REGTYPE_COARRAY_ALLOC,
2151 ds + ref->u.c.caf_token_offset,
2152 dst, stat, NULL, 0);
2153 /* In case of an error in allocation return. When stat is
2154 NULL, then register_component() terminates on error. */
2155 if (stat != NULL && *stat)
2156 return;
2158 single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
2159 /* When a component is allocatable (caf_token_offset != 0) and not an
2160 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
2161 dereffed. */
2162 if (ref->next && ref->next->type == CAF_REF_COMPONENT)
2163 ds = *(void **)(ds + ref->u.c.offset);
2164 else
2165 ds += ref->u.c.offset;
2167 send_by_ref (ref->next, i, src_index, single_token,
2168 single_token->desc, src, ds, sr,
2169 dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type);
2171 else
2172 send_by_ref (ref->next, i, src_index, single_token,
2173 (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
2174 ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
2175 1, size, stat, dst_type);
2176 return;
2177 case CAF_REF_ARRAY:
2178 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2180 send_by_ref (ref->next, i, src_index, single_token,
2181 (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
2182 0, src_dim, 1, size, stat, dst_type);
2183 return;
2185 /* Only when on the left most index switch the data pointer to
2186 the array's data pointer. And only for non-static arrays. */
2187 if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
2188 ds = GFC_DESCRIPTOR_DATA (dst);
2189 switch (ref->u.a.mode[dst_dim])
2191 case CAF_ARR_REF_VECTOR:
2192 array_offset_dst = 0;
2193 src_index[src_dim] = 0;
2194 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2195 ++idx)
2197 #define KINDCASE(kind, type) case kind: \
2198 array_offset_dst = (((index_type) \
2199 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2200 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2201 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2202 break
2204 switch (ref->u.a.dim[dst_dim].v.kind)
2206 KINDCASE (1, GFC_INTEGER_1);
2207 KINDCASE (2, GFC_INTEGER_2);
2208 KINDCASE (4, GFC_INTEGER_4);
2209 #ifdef HAVE_GFC_INTEGER_8
2210 KINDCASE (8, GFC_INTEGER_8);
2211 #endif
2212 #ifdef HAVE_GFC_INTEGER_16
2213 KINDCASE (16, GFC_INTEGER_16);
2214 #endif
2215 default:
2216 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2217 return;
2219 #undef KINDCASE
2221 send_by_ref (ref, i, src_index, single_token, dst, src,
2222 ds + array_offset_dst * ref->item_size, sr,
2223 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2224 1, size, stat, dst_type);
2225 if (src_rank > 0)
2226 src_index[src_dim]
2227 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2229 return;
2230 case CAF_ARR_REF_FULL:
2231 COMPUTE_NUM_ITEMS (extent_dst,
2232 ref->u.a.dim[dst_dim].s.stride,
2233 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2234 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2235 array_offset_dst = 0;
2236 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2237 * ref->u.a.dim[dst_dim].s.stride;
2238 src_index[src_dim] = 0;
2239 for (index_type idx = 0; idx < extent_dst;
2240 ++idx, array_offset_dst += stride_dst)
2242 send_by_ref (ref, i, src_index, single_token, dst, src,
2243 ds + array_offset_dst * ref->item_size, sr,
2244 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2245 1, size, stat, dst_type);
2246 if (src_rank > 0)
2247 src_index[src_dim]
2248 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2250 return;
2251 case CAF_ARR_REF_RANGE:
2252 COMPUTE_NUM_ITEMS (extent_dst,
2253 ref->u.a.dim[dst_dim].s.stride,
2254 ref->u.a.dim[dst_dim].s.start,
2255 ref->u.a.dim[dst_dim].s.end);
2256 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2257 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2258 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2259 * ref->u.a.dim[dst_dim].s.stride;
2260 src_index[src_dim] = 0;
2261 for (index_type idx = 0; idx < extent_dst; ++idx)
2263 send_by_ref (ref, i, src_index, single_token, dst, src,
2264 ds + array_offset_dst * ref->item_size, sr,
2265 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2266 1, size, stat, dst_type);
2267 if (src_rank > 0)
2268 src_index[src_dim]
2269 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2270 array_offset_dst += stride_dst;
2272 return;
2273 case CAF_ARR_REF_SINGLE:
2274 array_offset_dst = (ref->u.a.dim[dst_dim].s.start
2275 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
2276 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
2277 send_by_ref (ref, i, src_index, single_token, dst, src, ds
2278 + array_offset_dst * ref->item_size, sr,
2279 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
2280 size, stat, dst_type);
2281 return;
2282 case CAF_ARR_REF_OPEN_END:
2283 COMPUTE_NUM_ITEMS (extent_dst,
2284 ref->u.a.dim[dst_dim].s.stride,
2285 ref->u.a.dim[dst_dim].s.start,
2286 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2287 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2288 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2289 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2290 * ref->u.a.dim[dst_dim].s.stride;
2291 src_index[src_dim] = 0;
2292 for (index_type idx = 0; idx < extent_dst; ++idx)
2294 send_by_ref (ref, i, src_index, single_token, dst, src,
2295 ds + array_offset_dst * ref->item_size, sr,
2296 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2297 1, size, stat, dst_type);
2298 if (src_rank > 0)
2299 src_index[src_dim]
2300 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2301 array_offset_dst += stride_dst;
2303 return;
2304 case CAF_ARR_REF_OPEN_START:
2305 COMPUTE_NUM_ITEMS (extent_dst,
2306 ref->u.a.dim[dst_dim].s.stride,
2307 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2308 ref->u.a.dim[dst_dim].s.end);
2309 array_offset_dst = 0;
2310 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2311 * ref->u.a.dim[dst_dim].s.stride;
2312 src_index[src_dim] = 0;
2313 for (index_type idx = 0; idx < extent_dst; ++idx)
2315 send_by_ref (ref, i, src_index, single_token, dst, src,
2316 ds + array_offset_dst * ref->item_size, sr,
2317 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2318 1, size, stat, dst_type);
2319 if (src_rank > 0)
2320 src_index[src_dim]
2321 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2322 array_offset_dst += stride_dst;
2324 return;
2325 default:
2326 caf_runtime_error (unreachable);
2328 return;
2329 case CAF_REF_STATIC_ARRAY:
2330 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2332 send_by_ref (ref->next, i, src_index, single_token, NULL,
2333 src, ds, sr, dst_kind, src_kind,
2334 0, src_dim, 1, size, stat, dst_type);
2335 return;
2337 switch (ref->u.a.mode[dst_dim])
2339 case CAF_ARR_REF_VECTOR:
2340 array_offset_dst = 0;
2341 src_index[src_dim] = 0;
2342 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2343 ++idx)
2345 #define KINDCASE(kind, type) case kind: \
2346 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2347 break
2349 switch (ref->u.a.dim[dst_dim].v.kind)
2351 KINDCASE (1, GFC_INTEGER_1);
2352 KINDCASE (2, GFC_INTEGER_2);
2353 KINDCASE (4, GFC_INTEGER_4);
2354 #ifdef HAVE_GFC_INTEGER_8
2355 KINDCASE (8, GFC_INTEGER_8);
2356 #endif
2357 #ifdef HAVE_GFC_INTEGER_16
2358 KINDCASE (16, GFC_INTEGER_16);
2359 #endif
2360 default:
2361 caf_runtime_error (unreachable);
2362 return;
2364 #undef KINDCASE
2366 send_by_ref (ref, i, src_index, single_token, NULL, src,
2367 ds + array_offset_dst * ref->item_size, sr,
2368 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2369 1, size, stat, dst_type);
2370 src_index[src_dim]
2371 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2373 return;
2374 case CAF_ARR_REF_FULL:
2375 src_index[src_dim] = 0;
2376 for (array_offset_dst = 0 ;
2377 array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
2378 array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
2380 send_by_ref (ref, i, src_index, single_token, NULL, src,
2381 ds + array_offset_dst * ref->item_size, sr,
2382 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2383 1, size, stat, dst_type);
2384 if (src_rank > 0)
2385 src_index[src_dim]
2386 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2388 return;
2389 case CAF_ARR_REF_RANGE:
2390 COMPUTE_NUM_ITEMS (extent_dst,
2391 ref->u.a.dim[dst_dim].s.stride,
2392 ref->u.a.dim[dst_dim].s.start,
2393 ref->u.a.dim[dst_dim].s.end);
2394 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2395 src_index[src_dim] = 0;
2396 for (index_type idx = 0; idx < extent_dst; ++idx)
2398 send_by_ref (ref, i, src_index, single_token, NULL, src,
2399 ds + array_offset_dst * ref->item_size, sr,
2400 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2401 1, size, stat, dst_type);
2402 if (src_rank > 0)
2403 src_index[src_dim]
2404 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2405 array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
2407 return;
2408 case CAF_ARR_REF_SINGLE:
2409 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2410 send_by_ref (ref, i, src_index, single_token, NULL, src,
2411 ds + array_offset_dst * ref->item_size, sr,
2412 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
2413 size, stat, dst_type);
2414 return;
2415 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
2416 case CAF_ARR_REF_OPEN_END:
2417 case CAF_ARR_REF_OPEN_START:
2418 default:
2419 caf_runtime_error (unreachable);
2421 return;
2422 default:
2423 caf_runtime_error (unreachable);
2428 void
2429 _gfortran_caf_send_by_ref (caf_token_t token,
2430 int image_index __attribute__ ((unused)),
2431 gfc_descriptor_t *src, caf_reference_t *refs,
2432 int dst_kind, int src_kind,
2433 bool may_require_tmp __attribute__ ((unused)),
2434 bool dst_reallocatable, int *stat, int dst_type)
2436 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
2437 "unknown kind in vector-ref.\n";
2438 const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
2439 "unknown reference type.\n";
2440 const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
2441 "unknown array reference type.\n";
2442 const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
2443 "rank out of range.\n";
2444 const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
2445 "reallocation of array followed by component ref not allowed.\n";
2446 const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
2447 "cannot allocate memory.\n";
2448 const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
2449 "extent of non-allocatable array mismatch.\n";
2450 const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
2451 "inner unallocated component detected.\n";
2452 size_t size, i;
2453 size_t dst_index[GFC_MAX_DIMENSIONS];
2454 int src_rank = GFC_DESCRIPTOR_RANK (src);
2455 int src_cur_dim = 0;
2456 size_t src_size = 0;
2457 caf_single_token_t single_token = TOKEN (token);
2458 void *memptr = single_token->memptr;
2459 gfc_descriptor_t *dst = single_token->desc;
2460 caf_reference_t *riter = refs;
2461 long delta;
2462 bool extent_mismatch;
2463 /* Note that the component is not allocated yet. */
2464 index_type new_component_idx = -1;
2466 if (stat)
2467 *stat = 0;
2469 /* Compute the size of the result. In the beginning size just counts the
2470 number of elements. */
2471 size = 1;
2472 while (riter)
2474 switch (riter->type)
2476 case CAF_REF_COMPONENT:
2477 if (unlikely (new_component_idx != -1))
2479 /* Allocating a component in the middle of a component ref is not
2480 support. We don't know the type to allocate. */
2481 caf_internal_error (innercompref, stat, NULL, 0);
2482 return;
2484 if (riter->u.c.caf_token_offset > 0)
2486 /* Check whether the allocatable component is zero, then no
2487 token is present, too. The token's pointer is not cleared
2488 when the structure is initialized. */
2489 if (*(void**)(memptr + riter->u.c.offset) == NULL)
2491 /* This component is not yet allocated. Check that it is
2492 allocatable here. */
2493 if (!dst_reallocatable)
2495 caf_internal_error (cannotallocdst, stat, NULL, 0);
2496 return;
2498 single_token = NULL;
2499 memptr = NULL;
2500 dst = NULL;
2501 break;
2503 single_token = *(caf_single_token_t*)
2504 (memptr + riter->u.c.caf_token_offset);
2505 memptr += riter->u.c.offset;
2506 dst = single_token->desc;
2508 else
2510 /* Regular component. */
2511 memptr += riter->u.c.offset;
2512 dst = (gfc_descriptor_t *)memptr;
2514 break;
2515 case CAF_REF_ARRAY:
2516 if (dst != NULL)
2517 memptr = GFC_DESCRIPTOR_DATA (dst);
2518 else
2519 dst = src;
2520 /* When the dst array needs to be allocated, then look at the
2521 extent of the source array in the dimension dst_cur_dim. */
2522 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2524 switch (riter->u.a.mode[i])
2526 case CAF_ARR_REF_VECTOR:
2527 delta = riter->u.a.dim[i].v.nvec;
2528 #define KINDCASE(kind, type) case kind: \
2529 memptr += (((index_type) \
2530 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2531 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2532 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2533 * riter->item_size; \
2534 break
2536 switch (riter->u.a.dim[i].v.kind)
2538 KINDCASE (1, GFC_INTEGER_1);
2539 KINDCASE (2, GFC_INTEGER_2);
2540 KINDCASE (4, GFC_INTEGER_4);
2541 #ifdef HAVE_GFC_INTEGER_8
2542 KINDCASE (8, GFC_INTEGER_8);
2543 #endif
2544 #ifdef HAVE_GFC_INTEGER_16
2545 KINDCASE (16, GFC_INTEGER_16);
2546 #endif
2547 default:
2548 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2549 return;
2551 #undef KINDCASE
2552 break;
2553 case CAF_ARR_REF_FULL:
2554 if (dst)
2555 COMPUTE_NUM_ITEMS (delta,
2556 riter->u.a.dim[i].s.stride,
2557 GFC_DIMENSION_LBOUND (dst->dim[i]),
2558 GFC_DIMENSION_UBOUND (dst->dim[i]));
2559 else
2560 COMPUTE_NUM_ITEMS (delta,
2561 riter->u.a.dim[i].s.stride,
2562 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2563 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2564 break;
2565 case CAF_ARR_REF_RANGE:
2566 COMPUTE_NUM_ITEMS (delta,
2567 riter->u.a.dim[i].s.stride,
2568 riter->u.a.dim[i].s.start,
2569 riter->u.a.dim[i].s.end);
2570 memptr += (riter->u.a.dim[i].s.start
2571 - dst->dim[i].lower_bound)
2572 * GFC_DIMENSION_STRIDE (dst->dim[i])
2573 * riter->item_size;
2574 break;
2575 case CAF_ARR_REF_SINGLE:
2576 delta = 1;
2577 memptr += (riter->u.a.dim[i].s.start
2578 - dst->dim[i].lower_bound)
2579 * GFC_DIMENSION_STRIDE (dst->dim[i])
2580 * riter->item_size;
2581 break;
2582 case CAF_ARR_REF_OPEN_END:
2583 if (dst)
2584 COMPUTE_NUM_ITEMS (delta,
2585 riter->u.a.dim[i].s.stride,
2586 riter->u.a.dim[i].s.start,
2587 GFC_DIMENSION_UBOUND (dst->dim[i]));
2588 else
2589 COMPUTE_NUM_ITEMS (delta,
2590 riter->u.a.dim[i].s.stride,
2591 riter->u.a.dim[i].s.start,
2592 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2593 memptr += (riter->u.a.dim[i].s.start
2594 - dst->dim[i].lower_bound)
2595 * GFC_DIMENSION_STRIDE (dst->dim[i])
2596 * riter->item_size;
2597 break;
2598 case CAF_ARR_REF_OPEN_START:
2599 if (dst)
2600 COMPUTE_NUM_ITEMS (delta,
2601 riter->u.a.dim[i].s.stride,
2602 GFC_DIMENSION_LBOUND (dst->dim[i]),
2603 riter->u.a.dim[i].s.end);
2604 else
2605 COMPUTE_NUM_ITEMS (delta,
2606 riter->u.a.dim[i].s.stride,
2607 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2608 riter->u.a.dim[i].s.end);
2609 /* The memptr stays unchanged when ref'ing the first element
2610 in a dimension. */
2611 break;
2612 default:
2613 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2614 return;
2617 if (delta <= 0)
2618 return;
2619 /* Check the various properties of the source array.
2620 When src is an array. */
2621 if (delta > 1 && src_rank > 0)
2623 /* Check that src_cur_dim is valid for src. Can be
2624 superceeded only by scalar data. */
2625 if (src_cur_dim >= src_rank)
2627 caf_internal_error (rankoutofrange, stat, NULL, 0);
2628 return;
2630 /* Do further checks, when the source is not scalar. */
2631 else
2633 /* When the realloc is required, then no extent may have
2634 been set. */
2635 extent_mismatch = memptr == NULL
2636 || (dst
2637 && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
2638 != delta);
2639 /* When it already known, that a realloc is needed or
2640 the extent does not match the needed one. */
2641 if (extent_mismatch)
2643 /* Check whether dst is reallocatable. */
2644 if (unlikely (!dst_reallocatable))
2646 caf_internal_error (nonallocextentmismatch, stat,
2647 NULL, 0, delta,
2648 GFC_DESCRIPTOR_EXTENT (dst,
2649 src_cur_dim));
2650 return;
2652 /* Report error on allocatable but missing inner
2653 ref. */
2654 else if (riter->next != NULL)
2656 caf_internal_error (realloconinnerref, stat, NULL,
2658 return;
2661 /* Only change the extent when it does not match. This is
2662 to prevent resetting given array bounds. */
2663 if (extent_mismatch)
2664 GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
2665 size);
2667 /* Increase the dim-counter of the src only when the extent
2668 matches. */
2669 if (src_cur_dim < src_rank
2670 && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
2671 ++src_cur_dim;
2673 size *= (index_type)delta;
2675 break;
2676 case CAF_REF_STATIC_ARRAY:
2677 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2679 switch (riter->u.a.mode[i])
2681 case CAF_ARR_REF_VECTOR:
2682 delta = riter->u.a.dim[i].v.nvec;
2683 #define KINDCASE(kind, type) case kind: \
2684 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2685 * riter->item_size; \
2686 break
2688 switch (riter->u.a.dim[i].v.kind)
2690 KINDCASE (1, GFC_INTEGER_1);
2691 KINDCASE (2, GFC_INTEGER_2);
2692 KINDCASE (4, GFC_INTEGER_4);
2693 #ifdef HAVE_GFC_INTEGER_8
2694 KINDCASE (8, GFC_INTEGER_8);
2695 #endif
2696 #ifdef HAVE_GFC_INTEGER_16
2697 KINDCASE (16, GFC_INTEGER_16);
2698 #endif
2699 default:
2700 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2701 return;
2703 #undef KINDCASE
2704 break;
2705 case CAF_ARR_REF_FULL:
2706 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
2707 + 1;
2708 /* The memptr stays unchanged when ref'ing the first element
2709 in a dimension. */
2710 break;
2711 case CAF_ARR_REF_RANGE:
2712 COMPUTE_NUM_ITEMS (delta,
2713 riter->u.a.dim[i].s.stride,
2714 riter->u.a.dim[i].s.start,
2715 riter->u.a.dim[i].s.end);
2716 memptr += riter->u.a.dim[i].s.start
2717 * riter->u.a.dim[i].s.stride
2718 * riter->item_size;
2719 break;
2720 case CAF_ARR_REF_SINGLE:
2721 delta = 1;
2722 memptr += riter->u.a.dim[i].s.start
2723 * riter->u.a.dim[i].s.stride
2724 * riter->item_size;
2725 break;
2726 case CAF_ARR_REF_OPEN_END:
2727 /* This and OPEN_START are mapped to a RANGE and therefore
2728 cannot occur here. */
2729 case CAF_ARR_REF_OPEN_START:
2730 default:
2731 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2732 return;
2734 if (delta <= 0)
2735 return;
2736 /* Check the various properties of the source array.
2737 Only when the source array is not scalar examine its
2738 properties. */
2739 if (delta > 1 && src_rank > 0)
2741 /* Check that src_cur_dim is valid for src. Can be
2742 superceeded only by scalar data. */
2743 if (src_cur_dim >= src_rank)
2745 caf_internal_error (rankoutofrange, stat, NULL, 0);
2746 return;
2748 else
2750 /* We will not be able to realloc the dst, because that's
2751 a fixed size array. */
2752 extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
2753 != delta;
2754 /* When the extent does not match the needed one we can
2755 only stop here. */
2756 if (extent_mismatch)
2758 caf_internal_error (nonallocextentmismatch, stat,
2759 NULL, 0, delta,
2760 GFC_DESCRIPTOR_EXTENT (src,
2761 src_cur_dim));
2762 return;
2765 ++src_cur_dim;
2767 size *= (index_type)delta;
2769 break;
2770 default:
2771 caf_internal_error (unknownreftype, stat, NULL, 0);
2772 return;
2774 src_size = riter->item_size;
2775 riter = riter->next;
2777 if (size == 0 || src_size == 0)
2778 return;
2779 /* Postcondition:
2780 - size contains the number of elements to store in the destination array,
2781 - src_size gives the size in bytes of each item in the destination array.
2784 /* Reset the token. */
2785 single_token = TOKEN (token);
2786 memptr = single_token->memptr;
2787 dst = single_token->desc;
2788 memset (dst_index, 0, sizeof (dst_index));
2789 i = 0;
2790 send_by_ref (refs, &i, dst_index, single_token, dst, src,
2791 memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
2792 1, size, stat, dst_type);
2793 assert (i == size);
2797 void
2798 _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
2799 caf_reference_t *dst_refs, caf_token_t src_token,
2800 int src_image_index,
2801 caf_reference_t *src_refs, int dst_kind,
2802 int src_kind, bool may_require_tmp, int *dst_stat,
2803 int *src_stat, int dst_type, int src_type)
2805 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp;
2806 GFC_DESCRIPTOR_DATA (&temp) = NULL;
2807 GFC_DESCRIPTOR_RANK (&temp) = -1;
2808 GFC_DESCRIPTOR_TYPE (&temp) = dst_type;
2810 _gfortran_caf_get_by_ref (src_token, src_image_index,
2811 (gfc_descriptor_t *) &temp, src_refs,
2812 dst_kind, src_kind, may_require_tmp, true,
2813 src_stat, src_type);
2815 if (src_stat && *src_stat != 0)
2816 return;
2818 _gfortran_caf_send_by_ref (dst_token, dst_image_index,
2819 (gfc_descriptor_t *) &temp, dst_refs,
2820 dst_kind, dst_kind, may_require_tmp, true,
2821 dst_stat, dst_type);
2822 if (GFC_DESCRIPTOR_DATA (&temp))
2823 free (GFC_DESCRIPTOR_DATA (&temp));
2827 void
2828 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
2829 int image_index __attribute__ ((unused)),
2830 void *value, int *stat,
2831 int type __attribute__ ((unused)), int kind)
2833 assert(kind == 4);
2835 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2837 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2839 if (stat)
2840 *stat = 0;
2843 void
2844 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
2845 int image_index __attribute__ ((unused)),
2846 void *value, int *stat,
2847 int type __attribute__ ((unused)), int kind)
2849 assert(kind == 4);
2851 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2853 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2855 if (stat)
2856 *stat = 0;
2860 void
2861 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
2862 int image_index __attribute__ ((unused)),
2863 void *old, void *compare, void *new_val, int *stat,
2864 int type __attribute__ ((unused)), int kind)
2866 assert(kind == 4);
2868 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2870 *(uint32_t *) old = *(uint32_t *) compare;
2871 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
2872 *(uint32_t *) new_val, false,
2873 __ATOMIC_RELAXED, __ATOMIC_RELAXED);
2874 if (stat)
2875 *stat = 0;
2879 void
2880 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
2881 int image_index __attribute__ ((unused)),
2882 void *value, void *old, int *stat,
2883 int type __attribute__ ((unused)), int kind)
2885 assert(kind == 4);
2887 uint32_t res;
2888 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2890 switch (op)
2892 case GFC_CAF_ATOMIC_ADD:
2893 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2894 break;
2895 case GFC_CAF_ATOMIC_AND:
2896 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2897 break;
2898 case GFC_CAF_ATOMIC_OR:
2899 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2900 break;
2901 case GFC_CAF_ATOMIC_XOR:
2902 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2903 break;
2904 default:
2905 __builtin_unreachable();
2908 if (old)
2909 *(uint32_t *) old = res;
2911 if (stat)
2912 *stat = 0;
2915 void
2916 _gfortran_caf_event_post (caf_token_t token, size_t index,
2917 int image_index __attribute__ ((unused)),
2918 int *stat, char *errmsg __attribute__ ((unused)),
2919 size_t errmsg_len __attribute__ ((unused)))
2921 uint32_t value = 1;
2922 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2923 * sizeof (uint32_t));
2924 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2926 if(stat)
2927 *stat = 0;
2930 void
2931 _gfortran_caf_event_wait (caf_token_t token, size_t index,
2932 int until_count, int *stat,
2933 char *errmsg __attribute__ ((unused)),
2934 size_t errmsg_len __attribute__ ((unused)))
2936 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2937 * sizeof (uint32_t));
2938 uint32_t value = (uint32_t)-until_count;
2939 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2941 if(stat)
2942 *stat = 0;
2945 void
2946 _gfortran_caf_event_query (caf_token_t token, size_t index,
2947 int image_index __attribute__ ((unused)),
2948 int *count, int *stat)
2950 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2951 * sizeof (uint32_t));
2952 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
2954 if(stat)
2955 *stat = 0;
2958 void
2959 _gfortran_caf_lock (caf_token_t token, size_t index,
2960 int image_index __attribute__ ((unused)),
2961 int *acquired_lock, int *stat, char *errmsg,
2962 size_t errmsg_len)
2964 const char *msg = "Already locked";
2965 bool *lock = &((bool *) MEMTOK (token))[index];
2967 if (!*lock)
2969 *lock = true;
2970 if (acquired_lock)
2971 *acquired_lock = (int) true;
2972 if (stat)
2973 *stat = 0;
2974 return;
2977 if (acquired_lock)
2979 *acquired_lock = (int) false;
2980 if (stat)
2981 *stat = 0;
2982 return;
2986 if (stat)
2988 *stat = 1;
2989 if (errmsg_len > 0)
2991 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
2992 : sizeof (msg);
2993 memcpy (errmsg, msg, len);
2994 if (errmsg_len > len)
2995 memset (&errmsg[len], ' ', errmsg_len-len);
2997 return;
2999 _gfortran_caf_error_stop_str (msg, strlen (msg), false);
3003 void
3004 _gfortran_caf_unlock (caf_token_t token, size_t index,
3005 int image_index __attribute__ ((unused)),
3006 int *stat, char *errmsg, size_t errmsg_len)
3008 const char *msg = "Variable is not locked";
3009 bool *lock = &((bool *) MEMTOK (token))[index];
3011 if (*lock)
3013 *lock = false;
3014 if (stat)
3015 *stat = 0;
3016 return;
3019 if (stat)
3021 *stat = 1;
3022 if (errmsg_len > 0)
3024 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
3025 : sizeof (msg);
3026 memcpy (errmsg, msg, len);
3027 if (errmsg_len > len)
3028 memset (&errmsg[len], ' ', errmsg_len-len);
3030 return;
3032 _gfortran_caf_error_stop_str (msg, strlen (msg), false);
3036 _gfortran_caf_is_present (caf_token_t token,
3037 int image_index __attribute__ ((unused)),
3038 caf_reference_t *refs)
3040 const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
3041 "only scalar indexes allowed.\n";
3042 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
3043 "unknown reference type.\n";
3044 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
3045 "unknown array reference type.\n";
3046 size_t i;
3047 caf_single_token_t single_token = TOKEN (token);
3048 void *memptr = single_token->memptr;
3049 gfc_descriptor_t *src = single_token->desc;
3050 caf_reference_t *riter = refs;
3052 while (riter)
3054 switch (riter->type)
3056 case CAF_REF_COMPONENT:
3057 if (riter->u.c.caf_token_offset)
3059 single_token = *(caf_single_token_t*)
3060 (memptr + riter->u.c.caf_token_offset);
3061 memptr = single_token->memptr;
3062 src = single_token->desc;
3064 else
3066 memptr += riter->u.c.offset;
3067 src = (gfc_descriptor_t *)memptr;
3069 break;
3070 case CAF_REF_ARRAY:
3071 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3073 switch (riter->u.a.mode[i])
3075 case CAF_ARR_REF_SINGLE:
3076 memptr += (riter->u.a.dim[i].s.start
3077 - GFC_DIMENSION_LBOUND (src->dim[i]))
3078 * GFC_DIMENSION_STRIDE (src->dim[i])
3079 * riter->item_size;
3080 break;
3081 case CAF_ARR_REF_FULL:
3082 /* A full array ref is allowed on the last reference only. */
3083 if (riter->next == NULL)
3084 break;
3085 /* else fall through reporting an error. */
3086 /* FALLTHROUGH */
3087 case CAF_ARR_REF_VECTOR:
3088 case CAF_ARR_REF_RANGE:
3089 case CAF_ARR_REF_OPEN_END:
3090 case CAF_ARR_REF_OPEN_START:
3091 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3092 return 0;
3093 default:
3094 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3095 return 0;
3098 break;
3099 case CAF_REF_STATIC_ARRAY:
3100 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3102 switch (riter->u.a.mode[i])
3104 case CAF_ARR_REF_SINGLE:
3105 memptr += riter->u.a.dim[i].s.start
3106 * riter->u.a.dim[i].s.stride
3107 * riter->item_size;
3108 break;
3109 case CAF_ARR_REF_FULL:
3110 /* A full array ref is allowed on the last reference only. */
3111 if (riter->next == NULL)
3112 break;
3113 /* else fall through reporting an error. */
3114 /* FALLTHROUGH */
3115 case CAF_ARR_REF_VECTOR:
3116 case CAF_ARR_REF_RANGE:
3117 case CAF_ARR_REF_OPEN_END:
3118 case CAF_ARR_REF_OPEN_START:
3119 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3120 return 0;
3121 default:
3122 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3123 return 0;
3126 break;
3127 default:
3128 caf_internal_error (unknownreftype, 0, NULL, 0);
3129 return 0;
3131 riter = riter->next;
3133 return memptr != NULL;
3136 /* Reference the libraries implementation. */
3137 extern void _gfortran_random_init (int32_t, int32_t, int32_t);
3139 void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
3141 /* In a single image implementation always forward to the gfortran
3142 routine. */
3143 _gfortran_random_init (repeatable, image_distinct, 1);