compiler: bring escape analysis mostly in line with gc compiler
[official-gcc.git] / libgfortran / caf / single.c
blobbf1a229975403c0e68acbe62aa138c2fce5e76b8
1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2017 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 <assert.h>
33 /* Define GFC_CAF_CHECK to enable run-time checking. */
34 /* #define GFC_CAF_CHECK 1 */
36 struct caf_single_token
38 /* The pointer to the memory registered. For arrays this is the data member
39 in the descriptor. For components it's the pure data pointer. */
40 void *memptr;
41 /* The descriptor when this token is associated to an allocatable array. */
42 gfc_descriptor_t *desc;
43 /* Set when the caf lib has allocated the memory in memptr and is responsible
44 for freeing it on deregister. */
45 bool owning_memory;
47 typedef struct caf_single_token *caf_single_token_t;
49 #define TOKEN(X) ((caf_single_token_t) (X))
50 #define MEMTOK(X) ((caf_single_token_t) (X))->memptr
52 /* Single-image implementation of the CAF library.
53 Note: For performance reasons -fcoarry=single should be used
54 rather than this library. */
56 /* Global variables. */
57 caf_static_t *caf_static_list = NULL;
59 /* Keep in sync with mpi.c. */
60 static void
61 caf_runtime_error (const char *message, ...)
63 va_list ap;
64 fprintf (stderr, "Fortran runtime error: ");
65 va_start (ap, message);
66 vfprintf (stderr, message, ap);
67 va_end (ap);
68 fprintf (stderr, "\n");
70 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
71 exit (EXIT_FAILURE);
74 /* Error handling is similar everytime. */
75 static void
76 caf_internal_error (const char *msg, int *stat, char *errmsg,
77 int errmsg_len, ...)
79 va_list args;
80 va_start (args, errmsg_len);
81 if (stat)
83 *stat = 1;
84 if (errmsg_len > 0)
86 size_t len = snprintf (errmsg, errmsg_len, msg, args);
87 if ((size_t)errmsg_len > len)
88 memset (&errmsg[len], ' ', errmsg_len - len);
90 va_end (args);
91 return;
93 else
94 caf_runtime_error (msg, args);
95 va_end (args);
99 void
100 _gfortran_caf_init (int *argc __attribute__ ((unused)),
101 char ***argv __attribute__ ((unused)))
106 void
107 _gfortran_caf_finalize (void)
109 while (caf_static_list != NULL)
111 caf_static_t *tmp = caf_static_list->prev;
112 free (caf_static_list->token);
113 free (caf_static_list);
114 caf_static_list = tmp;
120 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
122 return 1;
127 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
128 int failed __attribute__ ((unused)))
130 return 1;
134 void
135 _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
136 gfc_descriptor_t *data, int *stat, char *errmsg,
137 int errmsg_len)
139 const char alloc_fail_msg[] = "Failed to allocate coarray";
140 void *local;
141 caf_single_token_t single_token;
143 if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
144 || type == CAF_REGTYPE_CRITICAL)
145 local = calloc (size, sizeof (bool));
146 else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC)
147 /* In the event_(wait|post) function the counter for events is a uint32,
148 so better allocate enough memory here. */
149 local = calloc (size, sizeof (uint32_t));
150 else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
151 local = NULL;
152 else
153 local = malloc (size);
155 if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
156 *token = malloc (sizeof (struct caf_single_token));
158 if (unlikely (*token == NULL
159 || (local == NULL
160 && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
162 /* Freeing the memory conditionally seems pointless, but
163 caf_internal_error () may return, when a stat is given and then the
164 memory may be lost. */
165 if (local)
166 free (local);
167 if (*token)
168 free (*token);
169 caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
170 return;
173 single_token = TOKEN (*token);
174 single_token->memptr = local;
175 single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
176 single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
179 if (stat)
180 *stat = 0;
182 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
183 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
184 || type == CAF_REGTYPE_EVENT_ALLOC)
186 caf_static_t *tmp = malloc (sizeof (caf_static_t));
187 tmp->prev = caf_static_list;
188 tmp->token = *token;
189 caf_static_list = tmp;
191 GFC_DESCRIPTOR_DATA (data) = local;
195 void
196 _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
197 char *errmsg __attribute__ ((unused)),
198 int errmsg_len __attribute__ ((unused)))
200 caf_single_token_t single_token = TOKEN (*token);
202 if (single_token->owning_memory && single_token->memptr)
203 free (single_token->memptr);
205 if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
207 free (TOKEN (*token));
208 *token = NULL;
210 else
212 single_token->memptr = NULL;
213 single_token->owning_memory = false;
216 if (stat)
217 *stat = 0;
221 void
222 _gfortran_caf_sync_all (int *stat,
223 char *errmsg __attribute__ ((unused)),
224 int errmsg_len __attribute__ ((unused)))
226 __asm__ __volatile__ ("":::"memory");
227 if (stat)
228 *stat = 0;
232 void
233 _gfortran_caf_sync_memory (int *stat,
234 char *errmsg __attribute__ ((unused)),
235 int errmsg_len __attribute__ ((unused)))
237 __asm__ __volatile__ ("":::"memory");
238 if (stat)
239 *stat = 0;
243 void
244 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
245 int images[] __attribute__ ((unused)),
246 int *stat,
247 char *errmsg __attribute__ ((unused)),
248 int errmsg_len __attribute__ ((unused)))
250 #ifdef GFC_CAF_CHECK
251 int i;
253 for (i = 0; i < count; i++)
254 if (images[i] != 1)
256 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
257 "IMAGES", images[i]);
258 exit (EXIT_FAILURE);
260 #endif
262 __asm__ __volatile__ ("":::"memory");
263 if (stat)
264 *stat = 0;
268 void
269 _gfortran_caf_stop_numeric(int32_t stop_code)
271 fprintf (stderr, "STOP %d\n", stop_code);
272 exit (0);
276 void
277 _gfortran_caf_stop_str(const char *string, int32_t len)
279 fputs ("STOP ", stderr);
280 while (len--)
281 fputc (*(string++), stderr);
282 fputs ("\n", stderr);
284 exit (0);
288 void
289 _gfortran_caf_error_stop_str (const char *string, int32_t len)
291 fputs ("ERROR STOP ", stderr);
292 while (len--)
293 fputc (*(string++), stderr);
294 fputs ("\n", stderr);
296 exit (1);
300 /* Reported that the program terminated because of a fail image issued.
301 Because this is a single image library, nothing else than aborting the whole
302 program can be done. */
304 void _gfortran_caf_fail_image (void)
306 fputs ("IMAGE FAILED!\n", stderr);
307 exit (0);
311 /* Get the status of image IMAGE. Because being the single image library all
312 other images are reported to be stopped. */
314 int _gfortran_caf_image_status (int image,
315 caf_team_t * team __attribute__ ((unused)))
317 if (image == 1)
318 return 0;
319 else
320 return CAF_STAT_STOPPED_IMAGE;
324 /* Single image library. There can not be any failed images with only one
325 image. */
327 void
328 _gfortran_caf_failed_images (gfc_descriptor_t *array,
329 caf_team_t * team __attribute__ ((unused)),
330 int * kind)
332 int local_kind = kind != NULL ? *kind : 4;
334 array->base_addr = NULL;
335 array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
336 | (local_kind << GFC_DTYPE_SIZE_SHIFT));
337 /* Setting lower_bound higher then upper_bound is what the compiler does to
338 indicate an empty array. */
339 array->dim[0].lower_bound = 0;
340 array->dim[0]._ubound = -1;
341 array->dim[0]._stride = 1;
342 array->offset = 0;
346 /* With only one image available no other images can be stopped. Therefore
347 return an empty array. */
349 void
350 _gfortran_caf_stopped_images (gfc_descriptor_t *array,
351 caf_team_t * team __attribute__ ((unused)),
352 int * kind)
354 int local_kind = kind != NULL ? *kind : 4;
356 array->base_addr = NULL;
357 array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
358 | (local_kind << GFC_DTYPE_SIZE_SHIFT));
359 /* Setting lower_bound higher then upper_bound is what the compiler does to
360 indicate an empty array. */
361 array->dim[0].lower_bound = 0;
362 array->dim[0]._ubound = -1;
363 array->dim[0]._stride = 1;
364 array->offset = 0;
368 void
369 _gfortran_caf_error_stop (int32_t error)
371 fprintf (stderr, "ERROR STOP %d\n", error);
372 exit (error);
376 void
377 _gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
378 int source_image __attribute__ ((unused)),
379 int *stat, char *errmsg __attribute__ ((unused)),
380 int errmsg_len __attribute__ ((unused)))
382 if (stat)
383 *stat = 0;
386 void
387 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
388 int result_image __attribute__ ((unused)),
389 int *stat, char *errmsg __attribute__ ((unused)),
390 int errmsg_len __attribute__ ((unused)))
392 if (stat)
393 *stat = 0;
396 void
397 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
398 int result_image __attribute__ ((unused)),
399 int *stat, char *errmsg __attribute__ ((unused)),
400 int a_len __attribute__ ((unused)),
401 int errmsg_len __attribute__ ((unused)))
403 if (stat)
404 *stat = 0;
407 void
408 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
409 int result_image __attribute__ ((unused)),
410 int *stat, char *errmsg __attribute__ ((unused)),
411 int a_len __attribute__ ((unused)),
412 int errmsg_len __attribute__ ((unused)))
414 if (stat)
415 *stat = 0;
419 void
420 _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
421 void * (*opr) (void *, void *)
422 __attribute__ ((unused)),
423 int opr_flags __attribute__ ((unused)),
424 int result_image __attribute__ ((unused)),
425 int *stat, char *errmsg __attribute__ ((unused)),
426 int a_len __attribute__ ((unused)),
427 int errmsg_len __attribute__ ((unused)))
429 if (stat)
430 *stat = 0;
434 static void
435 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
436 unsigned char *src)
438 size_t i, n;
439 n = dst_size/4 > src_size ? src_size : dst_size/4;
440 for (i = 0; i < n; ++i)
441 dst[i] = (int32_t) src[i];
442 for (; i < dst_size/4; ++i)
443 dst[i] = (int32_t) ' ';
447 static void
448 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
449 uint32_t *src)
451 size_t i, n;
452 n = dst_size > src_size/4 ? src_size/4 : dst_size;
453 for (i = 0; i < n; ++i)
454 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
455 if (dst_size > n)
456 memset (&dst[n], ' ', dst_size - n);
460 static void
461 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
462 int src_kind, int *stat)
464 #ifdef HAVE_GFC_INTEGER_16
465 typedef __int128 int128t;
466 #else
467 typedef int64_t int128t;
468 #endif
470 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
471 typedef long double real128t;
472 typedef _Complex long double complex128t;
473 #elif defined(HAVE_GFC_REAL_16)
474 typedef _Complex float __attribute__((mode(TC))) __complex128;
475 typedef __float128 real128t;
476 typedef __complex128 complex128t;
477 #elif defined(HAVE_GFC_REAL_10)
478 typedef long double real128t;
479 typedef long double complex128t;
480 #else
481 typedef double real128t;
482 typedef _Complex double complex128t;
483 #endif
485 int128t int_val = 0;
486 real128t real_val = 0;
487 complex128t cmpx_val = 0;
489 switch (src_type)
491 case BT_INTEGER:
492 if (src_kind == 1)
493 int_val = *(int8_t*) src;
494 else if (src_kind == 2)
495 int_val = *(int16_t*) src;
496 else if (src_kind == 4)
497 int_val = *(int32_t*) src;
498 else if (src_kind == 8)
499 int_val = *(int64_t*) src;
500 #ifdef HAVE_GFC_INTEGER_16
501 else if (src_kind == 16)
502 int_val = *(int128t*) src;
503 #endif
504 else
505 goto error;
506 break;
507 case BT_REAL:
508 if (src_kind == 4)
509 real_val = *(float*) src;
510 else if (src_kind == 8)
511 real_val = *(double*) src;
512 #ifdef HAVE_GFC_REAL_10
513 else if (src_kind == 10)
514 real_val = *(long double*) src;
515 #endif
516 #ifdef HAVE_GFC_REAL_16
517 else if (src_kind == 16)
518 real_val = *(real128t*) src;
519 #endif
520 else
521 goto error;
522 break;
523 case BT_COMPLEX:
524 if (src_kind == 4)
525 cmpx_val = *(_Complex float*) src;
526 else if (src_kind == 8)
527 cmpx_val = *(_Complex double*) src;
528 #ifdef HAVE_GFC_REAL_10
529 else if (src_kind == 10)
530 cmpx_val = *(_Complex long double*) src;
531 #endif
532 #ifdef HAVE_GFC_REAL_16
533 else if (src_kind == 16)
534 cmpx_val = *(complex128t*) src;
535 #endif
536 else
537 goto error;
538 break;
539 default:
540 goto error;
543 switch (dst_type)
545 case BT_INTEGER:
546 if (src_type == BT_INTEGER)
548 if (dst_kind == 1)
549 *(int8_t*) dst = (int8_t) int_val;
550 else if (dst_kind == 2)
551 *(int16_t*) dst = (int16_t) int_val;
552 else if (dst_kind == 4)
553 *(int32_t*) dst = (int32_t) int_val;
554 else if (dst_kind == 8)
555 *(int64_t*) dst = (int64_t) int_val;
556 #ifdef HAVE_GFC_INTEGER_16
557 else if (dst_kind == 16)
558 *(int128t*) dst = (int128t) int_val;
559 #endif
560 else
561 goto error;
563 else if (src_type == BT_REAL)
565 if (dst_kind == 1)
566 *(int8_t*) dst = (int8_t) real_val;
567 else if (dst_kind == 2)
568 *(int16_t*) dst = (int16_t) real_val;
569 else if (dst_kind == 4)
570 *(int32_t*) dst = (int32_t) real_val;
571 else if (dst_kind == 8)
572 *(int64_t*) dst = (int64_t) real_val;
573 #ifdef HAVE_GFC_INTEGER_16
574 else if (dst_kind == 16)
575 *(int128t*) dst = (int128t) real_val;
576 #endif
577 else
578 goto error;
580 else if (src_type == BT_COMPLEX)
582 if (dst_kind == 1)
583 *(int8_t*) dst = (int8_t) cmpx_val;
584 else if (dst_kind == 2)
585 *(int16_t*) dst = (int16_t) cmpx_val;
586 else if (dst_kind == 4)
587 *(int32_t*) dst = (int32_t) cmpx_val;
588 else if (dst_kind == 8)
589 *(int64_t*) dst = (int64_t) cmpx_val;
590 #ifdef HAVE_GFC_INTEGER_16
591 else if (dst_kind == 16)
592 *(int128t*) dst = (int128t) cmpx_val;
593 #endif
594 else
595 goto error;
597 else
598 goto error;
599 return;
600 case BT_REAL:
601 if (src_type == BT_INTEGER)
603 if (dst_kind == 4)
604 *(float*) dst = (float) int_val;
605 else if (dst_kind == 8)
606 *(double*) dst = (double) int_val;
607 #ifdef HAVE_GFC_REAL_10
608 else if (dst_kind == 10)
609 *(long double*) dst = (long double) int_val;
610 #endif
611 #ifdef HAVE_GFC_REAL_16
612 else if (dst_kind == 16)
613 *(real128t*) dst = (real128t) int_val;
614 #endif
615 else
616 goto error;
618 else if (src_type == BT_REAL)
620 if (dst_kind == 4)
621 *(float*) dst = (float) real_val;
622 else if (dst_kind == 8)
623 *(double*) dst = (double) real_val;
624 #ifdef HAVE_GFC_REAL_10
625 else if (dst_kind == 10)
626 *(long double*) dst = (long double) real_val;
627 #endif
628 #ifdef HAVE_GFC_REAL_16
629 else if (dst_kind == 16)
630 *(real128t*) dst = (real128t) real_val;
631 #endif
632 else
633 goto error;
635 else if (src_type == BT_COMPLEX)
637 if (dst_kind == 4)
638 *(float*) dst = (float) cmpx_val;
639 else if (dst_kind == 8)
640 *(double*) dst = (double) cmpx_val;
641 #ifdef HAVE_GFC_REAL_10
642 else if (dst_kind == 10)
643 *(long double*) dst = (long double) cmpx_val;
644 #endif
645 #ifdef HAVE_GFC_REAL_16
646 else if (dst_kind == 16)
647 *(real128t*) dst = (real128t) cmpx_val;
648 #endif
649 else
650 goto error;
652 return;
653 case BT_COMPLEX:
654 if (src_type == BT_INTEGER)
656 if (dst_kind == 4)
657 *(_Complex float*) dst = (_Complex float) int_val;
658 else if (dst_kind == 8)
659 *(_Complex double*) dst = (_Complex double) int_val;
660 #ifdef HAVE_GFC_REAL_10
661 else if (dst_kind == 10)
662 *(_Complex long double*) dst = (_Complex long double) int_val;
663 #endif
664 #ifdef HAVE_GFC_REAL_16
665 else if (dst_kind == 16)
666 *(complex128t*) dst = (complex128t) int_val;
667 #endif
668 else
669 goto error;
671 else if (src_type == BT_REAL)
673 if (dst_kind == 4)
674 *(_Complex float*) dst = (_Complex float) real_val;
675 else if (dst_kind == 8)
676 *(_Complex double*) dst = (_Complex double) real_val;
677 #ifdef HAVE_GFC_REAL_10
678 else if (dst_kind == 10)
679 *(_Complex long double*) dst = (_Complex long double) real_val;
680 #endif
681 #ifdef HAVE_GFC_REAL_16
682 else if (dst_kind == 16)
683 *(complex128t*) dst = (complex128t) real_val;
684 #endif
685 else
686 goto error;
688 else if (src_type == BT_COMPLEX)
690 if (dst_kind == 4)
691 *(_Complex float*) dst = (_Complex float) cmpx_val;
692 else if (dst_kind == 8)
693 *(_Complex double*) dst = (_Complex double) cmpx_val;
694 #ifdef HAVE_GFC_REAL_10
695 else if (dst_kind == 10)
696 *(_Complex long double*) dst = (_Complex long double) cmpx_val;
697 #endif
698 #ifdef HAVE_GFC_REAL_16
699 else if (dst_kind == 16)
700 *(complex128t*) dst = (complex128t) cmpx_val;
701 #endif
702 else
703 goto error;
705 else
706 goto error;
707 return;
708 default:
709 goto error;
712 error:
713 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
714 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
715 if (stat)
716 *stat = 1;
717 else
718 abort ();
722 void
723 _gfortran_caf_get (caf_token_t token, size_t offset,
724 int image_index __attribute__ ((unused)),
725 gfc_descriptor_t *src,
726 caf_vector_t *src_vector __attribute__ ((unused)),
727 gfc_descriptor_t *dest, int src_kind, int dst_kind,
728 bool may_require_tmp, int *stat)
730 /* FIXME: Handle vector subscripts. */
731 size_t i, k, size;
732 int j;
733 int rank = GFC_DESCRIPTOR_RANK (dest);
734 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
735 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
737 if (stat)
738 *stat = 0;
740 if (rank == 0)
742 void *sr = (void *) ((char *) MEMTOK (token) + offset);
743 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
744 && dst_kind == src_kind)
746 memmove (GFC_DESCRIPTOR_DATA (dest), sr,
747 dst_size > src_size ? src_size : dst_size);
748 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
750 if (dst_kind == 1)
751 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
752 ' ', dst_size - src_size);
753 else /* dst_kind == 4. */
754 for (i = src_size/4; i < dst_size/4; i++)
755 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
758 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
759 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
760 sr);
761 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
762 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
763 sr);
764 else
765 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
766 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
767 return;
770 size = 1;
771 for (j = 0; j < rank; j++)
773 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
774 if (dimextent < 0)
775 dimextent = 0;
776 size *= dimextent;
779 if (size == 0)
780 return;
782 if (may_require_tmp)
784 ptrdiff_t array_offset_sr, array_offset_dst;
785 void *tmp = malloc (size*src_size);
787 array_offset_dst = 0;
788 for (i = 0; i < size; i++)
790 ptrdiff_t array_offset_sr = 0;
791 ptrdiff_t stride = 1;
792 ptrdiff_t extent = 1;
793 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
795 array_offset_sr += ((i / (extent*stride))
796 % (src->dim[j]._ubound
797 - src->dim[j].lower_bound + 1))
798 * src->dim[j]._stride;
799 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
800 stride = src->dim[j]._stride;
802 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
803 void *sr = (void *)((char *) MEMTOK (token) + offset
804 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
805 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
806 array_offset_dst += src_size;
809 array_offset_sr = 0;
810 for (i = 0; i < size; i++)
812 ptrdiff_t array_offset_dst = 0;
813 ptrdiff_t stride = 1;
814 ptrdiff_t extent = 1;
815 for (j = 0; j < rank-1; j++)
817 array_offset_dst += ((i / (extent*stride))
818 % (dest->dim[j]._ubound
819 - dest->dim[j].lower_bound + 1))
820 * dest->dim[j]._stride;
821 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
822 stride = dest->dim[j]._stride;
824 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
825 void *dst = dest->base_addr
826 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
827 void *sr = tmp + array_offset_sr;
829 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
830 && dst_kind == src_kind)
832 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
833 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
834 && dst_size > src_size)
836 if (dst_kind == 1)
837 memset ((void*)(char*) dst + src_size, ' ',
838 dst_size-src_size);
839 else /* dst_kind == 4. */
840 for (k = src_size/4; k < dst_size/4; k++)
841 ((int32_t*) dst)[k] = (int32_t) ' ';
844 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
845 assign_char1_from_char4 (dst_size, src_size, dst, sr);
846 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
847 assign_char4_from_char1 (dst_size, src_size, dst, sr);
848 else
849 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
850 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
851 array_offset_sr += src_size;
854 free (tmp);
855 return;
858 for (i = 0; i < size; i++)
860 ptrdiff_t array_offset_dst = 0;
861 ptrdiff_t stride = 1;
862 ptrdiff_t extent = 1;
863 for (j = 0; j < rank-1; j++)
865 array_offset_dst += ((i / (extent*stride))
866 % (dest->dim[j]._ubound
867 - dest->dim[j].lower_bound + 1))
868 * dest->dim[j]._stride;
869 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
870 stride = dest->dim[j]._stride;
872 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
873 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
875 ptrdiff_t array_offset_sr = 0;
876 stride = 1;
877 extent = 1;
878 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
880 array_offset_sr += ((i / (extent*stride))
881 % (src->dim[j]._ubound
882 - src->dim[j].lower_bound + 1))
883 * src->dim[j]._stride;
884 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
885 stride = src->dim[j]._stride;
887 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
888 void *sr = (void *)((char *) MEMTOK (token) + offset
889 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
891 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
892 && dst_kind == src_kind)
894 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
895 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
897 if (dst_kind == 1)
898 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
899 else /* dst_kind == 4. */
900 for (k = src_size/4; k < dst_size/4; k++)
901 ((int32_t*) dst)[k] = (int32_t) ' ';
904 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
905 assign_char1_from_char4 (dst_size, src_size, dst, sr);
906 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
907 assign_char4_from_char1 (dst_size, src_size, dst, sr);
908 else
909 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
910 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
915 void
916 _gfortran_caf_send (caf_token_t token, size_t offset,
917 int image_index __attribute__ ((unused)),
918 gfc_descriptor_t *dest,
919 caf_vector_t *dst_vector __attribute__ ((unused)),
920 gfc_descriptor_t *src, int dst_kind, int src_kind,
921 bool may_require_tmp, int *stat)
923 /* FIXME: Handle vector subscripts. */
924 size_t i, k, size;
925 int j;
926 int rank = GFC_DESCRIPTOR_RANK (dest);
927 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
928 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
930 if (stat)
931 *stat = 0;
933 if (rank == 0)
935 void *dst = (void *) ((char *) MEMTOK (token) + offset);
936 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
937 && dst_kind == src_kind)
939 memmove (dst, GFC_DESCRIPTOR_DATA (src),
940 dst_size > src_size ? src_size : dst_size);
941 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
943 if (dst_kind == 1)
944 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
945 else /* dst_kind == 4. */
946 for (i = src_size/4; i < dst_size/4; i++)
947 ((int32_t*) dst)[i] = (int32_t) ' ';
950 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
951 assign_char1_from_char4 (dst_size, src_size, dst,
952 GFC_DESCRIPTOR_DATA (src));
953 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
954 assign_char4_from_char1 (dst_size, src_size, dst,
955 GFC_DESCRIPTOR_DATA (src));
956 else
957 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
958 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
959 src_kind, stat);
960 return;
963 size = 1;
964 for (j = 0; j < rank; j++)
966 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
967 if (dimextent < 0)
968 dimextent = 0;
969 size *= dimextent;
972 if (size == 0)
973 return;
975 if (may_require_tmp)
977 ptrdiff_t array_offset_sr, array_offset_dst;
978 void *tmp;
980 if (GFC_DESCRIPTOR_RANK (src) == 0)
982 tmp = malloc (src_size);
983 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
985 else
987 tmp = malloc (size*src_size);
988 array_offset_dst = 0;
989 for (i = 0; i < size; i++)
991 ptrdiff_t array_offset_sr = 0;
992 ptrdiff_t stride = 1;
993 ptrdiff_t extent = 1;
994 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
996 array_offset_sr += ((i / (extent*stride))
997 % (src->dim[j]._ubound
998 - src->dim[j].lower_bound + 1))
999 * src->dim[j]._stride;
1000 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1001 stride = src->dim[j]._stride;
1003 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1004 void *sr = (void *) ((char *) src->base_addr
1005 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1006 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
1007 array_offset_dst += src_size;
1011 array_offset_sr = 0;
1012 for (i = 0; i < size; i++)
1014 ptrdiff_t array_offset_dst = 0;
1015 ptrdiff_t stride = 1;
1016 ptrdiff_t extent = 1;
1017 for (j = 0; j < rank-1; j++)
1019 array_offset_dst += ((i / (extent*stride))
1020 % (dest->dim[j]._ubound
1021 - dest->dim[j].lower_bound + 1))
1022 * dest->dim[j]._stride;
1023 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1024 stride = dest->dim[j]._stride;
1026 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
1027 void *dst = (void *)((char *) MEMTOK (token) + offset
1028 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1029 void *sr = tmp + array_offset_sr;
1030 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1031 && dst_kind == src_kind)
1033 memmove (dst, sr,
1034 dst_size > src_size ? src_size : dst_size);
1035 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
1036 && dst_size > src_size)
1038 if (dst_kind == 1)
1039 memset ((void*)(char*) dst + src_size, ' ',
1040 dst_size-src_size);
1041 else /* dst_kind == 4. */
1042 for (k = src_size/4; k < dst_size/4; k++)
1043 ((int32_t*) dst)[k] = (int32_t) ' ';
1046 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1047 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1048 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1049 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1050 else
1051 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
1052 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
1053 if (GFC_DESCRIPTOR_RANK (src))
1054 array_offset_sr += src_size;
1056 free (tmp);
1057 return;
1060 for (i = 0; i < size; i++)
1062 ptrdiff_t array_offset_dst = 0;
1063 ptrdiff_t stride = 1;
1064 ptrdiff_t extent = 1;
1065 for (j = 0; j < rank-1; j++)
1067 array_offset_dst += ((i / (extent*stride))
1068 % (dest->dim[j]._ubound
1069 - dest->dim[j].lower_bound + 1))
1070 * dest->dim[j]._stride;
1071 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1072 stride = dest->dim[j]._stride;
1074 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
1075 void *dst = (void *)((char *) MEMTOK (token) + offset
1076 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1077 void *sr;
1078 if (GFC_DESCRIPTOR_RANK (src) != 0)
1080 ptrdiff_t array_offset_sr = 0;
1081 stride = 1;
1082 extent = 1;
1083 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1085 array_offset_sr += ((i / (extent*stride))
1086 % (src->dim[j]._ubound
1087 - src->dim[j].lower_bound + 1))
1088 * src->dim[j]._stride;
1089 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1090 stride = src->dim[j]._stride;
1092 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1093 sr = (void *)((char *) src->base_addr
1094 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1096 else
1097 sr = src->base_addr;
1099 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1100 && dst_kind == src_kind)
1102 memmove (dst, sr,
1103 dst_size > src_size ? src_size : dst_size);
1104 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
1106 if (dst_kind == 1)
1107 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
1108 else /* dst_kind == 4. */
1109 for (k = src_size/4; k < dst_size/4; k++)
1110 ((int32_t*) dst)[k] = (int32_t) ' ';
1113 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1114 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1115 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1116 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1117 else
1118 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
1119 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
1124 void
1125 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
1126 int dst_image_index, gfc_descriptor_t *dest,
1127 caf_vector_t *dst_vector, caf_token_t src_token,
1128 size_t src_offset,
1129 int src_image_index __attribute__ ((unused)),
1130 gfc_descriptor_t *src,
1131 caf_vector_t *src_vector __attribute__ ((unused)),
1132 int dst_kind, int src_kind, bool may_require_tmp)
1134 /* FIXME: Handle vector subscript of 'src_vector'. */
1135 /* For a single image, src->base_addr should be the same as src_token + offset
1136 but to play save, we do it properly. */
1137 void *src_base = GFC_DESCRIPTOR_DATA (src);
1138 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
1139 + src_offset);
1140 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
1141 src, dst_kind, src_kind, may_require_tmp, NULL);
1142 GFC_DESCRIPTOR_DATA (src) = src_base;
1146 /* Emitted when a theorectically unreachable part is reached. */
1147 const char unreachable[] = "Fatal error: unreachable alternative found.\n";
1150 static void
1151 copy_data (void *ds, void *sr, int dst_type, int src_type,
1152 int dst_kind, int src_kind, size_t dst_size, size_t src_size,
1153 size_t num, int *stat)
1155 size_t k;
1156 if (dst_type == src_type && dst_kind == src_kind)
1158 memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
1159 if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
1160 && dst_size > src_size)
1162 if (dst_kind == 1)
1163 memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
1164 else /* dst_kind == 4. */
1165 for (k = src_size/4; k < dst_size/4; k++)
1166 ((int32_t*) ds)[k] = (int32_t) ' ';
1169 else if (dst_type == BT_CHARACTER && dst_kind == 1)
1170 assign_char1_from_char4 (dst_size, src_size, ds, sr);
1171 else if (dst_type == BT_CHARACTER)
1172 assign_char4_from_char1 (dst_size, src_size, ds, sr);
1173 else
1174 for (k = 0; k < num; ++k)
1176 convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
1177 ds += dst_size;
1178 sr += src_size;
1183 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1184 do { \
1185 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1186 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1187 if (num <= 0 || abs_stride < 1) return; \
1188 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1189 } while (0)
1192 static void
1193 get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
1194 caf_single_token_t single_token, gfc_descriptor_t *dst,
1195 gfc_descriptor_t *src, void *ds, void *sr,
1196 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
1197 size_t num, int *stat)
1199 ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
1200 size_t next_dst_dim;
1202 if (unlikely (ref == NULL))
1203 /* May be we should issue an error here, because this case should not
1204 occur. */
1205 return;
1207 if (ref->next == NULL)
1209 size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
1210 ptrdiff_t array_offset_dst = 0;;
1211 size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
1212 int src_type = -1;
1214 switch (ref->type)
1216 case CAF_REF_COMPONENT:
1217 /* Because the token is always registered after the component, its
1218 offset is always greater zeor. */
1219 if (ref->u.c.caf_token_offset > 0)
1220 copy_data (ds, *(void **)(sr + ref->u.c.offset),
1221 GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
1222 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1223 else
1224 copy_data (ds, sr + ref->u.c.offset,
1225 GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
1226 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1227 ++(*i);
1228 return;
1229 case CAF_REF_STATIC_ARRAY:
1230 src_type = ref->u.a.static_array_type;
1231 /* Intentionally fall through. */
1232 case CAF_REF_ARRAY:
1233 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1235 for (size_t d = 0; d < dst_rank; ++d)
1236 array_offset_dst += dst_index[d];
1237 copy_data (ds + array_offset_dst * dst_size, sr,
1238 GFC_DESCRIPTOR_TYPE (dst),
1239 src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
1240 dst_kind, src_kind, dst_size, ref->item_size, num,
1241 stat);
1242 *i += num;
1243 return;
1245 break;
1246 default:
1247 caf_runtime_error (unreachable);
1251 switch (ref->type)
1253 case CAF_REF_COMPONENT:
1254 if (ref->u.c.caf_token_offset > 0)
1255 get_for_ref (ref->next, i, dst_index,
1256 *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst,
1257 (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc,
1258 ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0,
1259 1, stat);
1260 else
1261 get_for_ref (ref->next, i, dst_index, single_token, dst,
1262 (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
1263 sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
1264 stat);
1265 return;
1266 case CAF_REF_ARRAY:
1267 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1269 get_for_ref (ref->next, i, dst_index, single_token, dst,
1270 src, ds, sr, dst_kind, src_kind,
1271 dst_dim, 0, 1, stat);
1272 return;
1274 /* Only when on the left most index switch the data pointer to
1275 the array's data pointer. */
1276 if (src_dim == 0)
1277 sr = GFC_DESCRIPTOR_DATA (src);
1278 switch (ref->u.a.mode[src_dim])
1280 case CAF_ARR_REF_VECTOR:
1281 extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
1282 array_offset_src = 0;
1283 dst_index[dst_dim] = 0;
1284 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1285 ++idx)
1287 #define KINDCASE(kind, type) case kind: \
1288 array_offset_src = (((index_type) \
1289 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1290 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1291 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1292 break
1294 switch (ref->u.a.dim[src_dim].v.kind)
1296 KINDCASE (1, GFC_INTEGER_1);
1297 KINDCASE (2, GFC_INTEGER_2);
1298 KINDCASE (4, GFC_INTEGER_4);
1299 #ifdef HAVE_GFC_INTEGER_8
1300 KINDCASE (8, GFC_INTEGER_8);
1301 #endif
1302 #ifdef HAVE_GFC_INTEGER_16
1303 KINDCASE (16, GFC_INTEGER_16);
1304 #endif
1305 default:
1306 caf_runtime_error (unreachable);
1307 return;
1309 #undef KINDCASE
1311 get_for_ref (ref, i, dst_index, single_token, dst, src,
1312 ds, sr + array_offset_src * ref->item_size,
1313 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1314 1, stat);
1315 dst_index[dst_dim]
1316 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1318 return;
1319 case CAF_ARR_REF_FULL:
1320 COMPUTE_NUM_ITEMS (extent_src,
1321 ref->u.a.dim[src_dim].s.stride,
1322 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1323 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1324 stride_src = src->dim[src_dim]._stride
1325 * ref->u.a.dim[src_dim].s.stride;
1326 array_offset_src = 0;
1327 dst_index[dst_dim] = 0;
1328 for (index_type idx = 0; idx < extent_src;
1329 ++idx, array_offset_src += stride_src)
1331 get_for_ref (ref, i, dst_index, single_token, dst, src,
1332 ds, sr + array_offset_src * ref->item_size,
1333 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1334 1, stat);
1335 dst_index[dst_dim]
1336 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1338 return;
1339 case CAF_ARR_REF_RANGE:
1340 COMPUTE_NUM_ITEMS (extent_src,
1341 ref->u.a.dim[src_dim].s.stride,
1342 ref->u.a.dim[src_dim].s.start,
1343 ref->u.a.dim[src_dim].s.end);
1344 array_offset_src = (ref->u.a.dim[src_dim].s.start
1345 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1346 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1347 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1348 * ref->u.a.dim[src_dim].s.stride;
1349 dst_index[dst_dim] = 0;
1350 /* Increase the dst_dim only, when the src_extent is greater one
1351 or src and dst extent are both one. Don't increase when the scalar
1352 source is not present in the dst. */
1353 next_dst_dim = extent_src > 1
1354 || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
1355 && extent_src == 1) ? (dst_dim + 1) : dst_dim;
1356 for (index_type idx = 0; idx < extent_src; ++idx)
1358 get_for_ref (ref, i, dst_index, single_token, dst, src,
1359 ds, sr + array_offset_src * ref->item_size,
1360 dst_kind, src_kind, next_dst_dim, src_dim + 1,
1361 1, stat);
1362 dst_index[dst_dim]
1363 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1364 array_offset_src += stride_src;
1366 return;
1367 case CAF_ARR_REF_SINGLE:
1368 array_offset_src = (ref->u.a.dim[src_dim].s.start
1369 - src->dim[src_dim].lower_bound)
1370 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1371 dst_index[dst_dim] = 0;
1372 get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
1373 sr + array_offset_src * ref->item_size,
1374 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1375 stat);
1376 return;
1377 case CAF_ARR_REF_OPEN_END:
1378 COMPUTE_NUM_ITEMS (extent_src,
1379 ref->u.a.dim[src_dim].s.stride,
1380 ref->u.a.dim[src_dim].s.start,
1381 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1382 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1383 * ref->u.a.dim[src_dim].s.stride;
1384 array_offset_src = (ref->u.a.dim[src_dim].s.start
1385 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1386 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1387 dst_index[dst_dim] = 0;
1388 for (index_type idx = 0; idx < extent_src; ++idx)
1390 get_for_ref (ref, i, dst_index, single_token, dst, src,
1391 ds, sr + array_offset_src * ref->item_size,
1392 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1393 1, stat);
1394 dst_index[dst_dim]
1395 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1396 array_offset_src += stride_src;
1398 return;
1399 case CAF_ARR_REF_OPEN_START:
1400 COMPUTE_NUM_ITEMS (extent_src,
1401 ref->u.a.dim[src_dim].s.stride,
1402 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1403 ref->u.a.dim[src_dim].s.end);
1404 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1405 * ref->u.a.dim[src_dim].s.stride;
1406 array_offset_src = 0;
1407 dst_index[dst_dim] = 0;
1408 for (index_type idx = 0; idx < extent_src; ++idx)
1410 get_for_ref (ref, i, dst_index, single_token, dst, src,
1411 ds, sr + array_offset_src * ref->item_size,
1412 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1413 1, stat);
1414 dst_index[dst_dim]
1415 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1416 array_offset_src += stride_src;
1418 return;
1419 default:
1420 caf_runtime_error (unreachable);
1422 return;
1423 case CAF_REF_STATIC_ARRAY:
1424 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1426 get_for_ref (ref->next, i, dst_index, single_token, dst,
1427 NULL, ds, sr, dst_kind, src_kind,
1428 dst_dim, 0, 1, stat);
1429 return;
1431 switch (ref->u.a.mode[src_dim])
1433 case CAF_ARR_REF_VECTOR:
1434 array_offset_src = 0;
1435 dst_index[dst_dim] = 0;
1436 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1437 ++idx)
1439 #define KINDCASE(kind, type) case kind: \
1440 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1441 break
1443 switch (ref->u.a.dim[src_dim].v.kind)
1445 KINDCASE (1, GFC_INTEGER_1);
1446 KINDCASE (2, GFC_INTEGER_2);
1447 KINDCASE (4, GFC_INTEGER_4);
1448 #ifdef HAVE_GFC_INTEGER_8
1449 KINDCASE (8, GFC_INTEGER_8);
1450 #endif
1451 #ifdef HAVE_GFC_INTEGER_16
1452 KINDCASE (16, GFC_INTEGER_16);
1453 #endif
1454 default:
1455 caf_runtime_error (unreachable);
1456 return;
1458 #undef KINDCASE
1460 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1461 ds, sr + array_offset_src * ref->item_size,
1462 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1463 1, stat);
1464 dst_index[dst_dim]
1465 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1467 return;
1468 case CAF_ARR_REF_FULL:
1469 dst_index[dst_dim] = 0;
1470 for (array_offset_src = 0 ;
1471 array_offset_src <= ref->u.a.dim[src_dim].s.end;
1472 array_offset_src += ref->u.a.dim[src_dim].s.stride)
1474 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1475 ds, sr + array_offset_src * ref->item_size,
1476 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1477 1, stat);
1478 dst_index[dst_dim]
1479 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1481 return;
1482 case CAF_ARR_REF_RANGE:
1483 COMPUTE_NUM_ITEMS (extent_src,
1484 ref->u.a.dim[src_dim].s.stride,
1485 ref->u.a.dim[src_dim].s.start,
1486 ref->u.a.dim[src_dim].s.end);
1487 array_offset_src = ref->u.a.dim[src_dim].s.start;
1488 dst_index[dst_dim] = 0;
1489 for (index_type idx = 0; idx < extent_src; ++idx)
1491 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1492 ds, sr + array_offset_src * ref->item_size,
1493 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1494 1, stat);
1495 dst_index[dst_dim]
1496 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1497 array_offset_src += ref->u.a.dim[src_dim].s.stride;
1499 return;
1500 case CAF_ARR_REF_SINGLE:
1501 array_offset_src = ref->u.a.dim[src_dim].s.start;
1502 get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
1503 sr + array_offset_src * ref->item_size,
1504 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1505 stat);
1506 return;
1507 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
1508 case CAF_ARR_REF_OPEN_END:
1509 case CAF_ARR_REF_OPEN_START:
1510 default:
1511 caf_runtime_error (unreachable);
1513 return;
1514 default:
1515 caf_runtime_error (unreachable);
1520 void
1521 _gfortran_caf_get_by_ref (caf_token_t token,
1522 int image_index __attribute__ ((unused)),
1523 gfc_descriptor_t *dst, caf_reference_t *refs,
1524 int dst_kind, int src_kind,
1525 bool may_require_tmp __attribute__ ((unused)),
1526 bool dst_reallocatable, int *stat)
1528 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
1529 "unknown kind in vector-ref.\n";
1530 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
1531 "unknown reference type.\n";
1532 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
1533 "unknown array reference type.\n";
1534 const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1535 "rank out of range.\n";
1536 const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1537 "extent out of range.\n";
1538 const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
1539 "can not allocate memory.\n";
1540 const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
1541 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1542 const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
1543 "two or more array part references are not supported.\n";
1544 size_t size, i;
1545 size_t dst_index[GFC_MAX_DIMENSIONS];
1546 int dst_rank = GFC_DESCRIPTOR_RANK (dst);
1547 int dst_cur_dim = 0;
1548 size_t src_size = 0;
1549 caf_single_token_t single_token = TOKEN (token);
1550 void *memptr = single_token->memptr;
1551 gfc_descriptor_t *src = single_token->desc;
1552 caf_reference_t *riter = refs;
1553 long delta;
1554 /* Reallocation of dst.data is needed (e.g., array to small). */
1555 bool realloc_needed;
1556 /* Reallocation of dst.data is required, because data is not alloced at
1557 all. */
1558 bool realloc_required;
1559 bool extent_mismatch = false;
1560 /* Set when the first non-scalar array reference is encountered. */
1561 bool in_array_ref = false;
1562 bool array_extent_fixed = false;
1563 realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
1565 assert (!realloc_needed || dst_reallocatable);
1567 if (stat)
1568 *stat = 0;
1570 /* Compute the size of the result. In the beginning size just counts the
1571 number of elements. */
1572 size = 1;
1573 while (riter)
1575 switch (riter->type)
1577 case CAF_REF_COMPONENT:
1578 if (riter->u.c.caf_token_offset)
1580 single_token = *(caf_single_token_t*)
1581 (memptr + riter->u.c.caf_token_offset);
1582 memptr = single_token->memptr;
1583 src = single_token->desc;
1585 else
1587 memptr += riter->u.c.offset;
1588 src = (gfc_descriptor_t *)memptr;
1590 break;
1591 case CAF_REF_ARRAY:
1592 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1594 switch (riter->u.a.mode[i])
1596 case CAF_ARR_REF_VECTOR:
1597 delta = riter->u.a.dim[i].v.nvec;
1598 #define KINDCASE(kind, type) case kind: \
1599 memptr += (((index_type) \
1600 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1601 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1602 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1603 * riter->item_size; \
1604 break
1606 switch (riter->u.a.dim[i].v.kind)
1608 KINDCASE (1, GFC_INTEGER_1);
1609 KINDCASE (2, GFC_INTEGER_2);
1610 KINDCASE (4, GFC_INTEGER_4);
1611 #ifdef HAVE_GFC_INTEGER_8
1612 KINDCASE (8, GFC_INTEGER_8);
1613 #endif
1614 #ifdef HAVE_GFC_INTEGER_16
1615 KINDCASE (16, GFC_INTEGER_16);
1616 #endif
1617 default:
1618 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1619 return;
1621 #undef KINDCASE
1622 break;
1623 case CAF_ARR_REF_FULL:
1624 COMPUTE_NUM_ITEMS (delta,
1625 riter->u.a.dim[i].s.stride,
1626 GFC_DIMENSION_LBOUND (src->dim[i]),
1627 GFC_DIMENSION_UBOUND (src->dim[i]));
1628 /* The memptr stays unchanged when ref'ing the first element
1629 in a dimension. */
1630 break;
1631 case CAF_ARR_REF_RANGE:
1632 COMPUTE_NUM_ITEMS (delta,
1633 riter->u.a.dim[i].s.stride,
1634 riter->u.a.dim[i].s.start,
1635 riter->u.a.dim[i].s.end);
1636 memptr += (riter->u.a.dim[i].s.start
1637 - GFC_DIMENSION_LBOUND (src->dim[i]))
1638 * GFC_DIMENSION_STRIDE (src->dim[i])
1639 * riter->item_size;
1640 break;
1641 case CAF_ARR_REF_SINGLE:
1642 delta = 1;
1643 memptr += (riter->u.a.dim[i].s.start
1644 - GFC_DIMENSION_LBOUND (src->dim[i]))
1645 * GFC_DIMENSION_STRIDE (src->dim[i])
1646 * riter->item_size;
1647 break;
1648 case CAF_ARR_REF_OPEN_END:
1649 COMPUTE_NUM_ITEMS (delta,
1650 riter->u.a.dim[i].s.stride,
1651 riter->u.a.dim[i].s.start,
1652 GFC_DIMENSION_UBOUND (src->dim[i]));
1653 memptr += (riter->u.a.dim[i].s.start
1654 - GFC_DIMENSION_LBOUND (src->dim[i]))
1655 * GFC_DIMENSION_STRIDE (src->dim[i])
1656 * riter->item_size;
1657 break;
1658 case CAF_ARR_REF_OPEN_START:
1659 COMPUTE_NUM_ITEMS (delta,
1660 riter->u.a.dim[i].s.stride,
1661 GFC_DIMENSION_LBOUND (src->dim[i]),
1662 riter->u.a.dim[i].s.end);
1663 /* The memptr stays unchanged when ref'ing the first element
1664 in a dimension. */
1665 break;
1666 default:
1667 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1668 return;
1670 if (delta <= 0)
1671 return;
1672 /* Check the various properties of the destination array.
1673 Is an array expected and present? */
1674 if (delta > 1 && dst_rank == 0)
1676 /* No, an array is required, but not provided. */
1677 caf_internal_error (extentoutofrange, stat, NULL, 0);
1678 return;
1680 /* When dst is an array. */
1681 if (dst_rank > 0)
1683 /* Check that dst_cur_dim is valid for dst. Can be
1684 superceeded only by scalar data. */
1685 if (dst_cur_dim >= dst_rank && delta != 1)
1687 caf_internal_error (rankoutofrange, stat, NULL, 0);
1688 return;
1690 /* Do further checks, when the source is not scalar. */
1691 else if (delta != 1)
1693 /* Check that the extent is not scalar and we are not in
1694 an array ref for the dst side. */
1695 if (!in_array_ref)
1697 /* Check that this is the non-scalar extent. */
1698 if (!array_extent_fixed)
1700 /* In an array extent now. */
1701 in_array_ref = true;
1702 /* Check that we haven't skipped any scalar
1703 dimensions yet and that the dst is
1704 compatible. */
1705 if (i > 0
1706 && dst_rank == GFC_DESCRIPTOR_RANK (src))
1708 if (dst_reallocatable)
1710 /* Dst is reallocatable, which means that
1711 the bounds are not set. Set them. */
1712 for (dst_cur_dim= 0; dst_cur_dim < (int)i;
1713 ++dst_cur_dim)
1714 GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
1715 1, 1, 1);
1717 else
1718 dst_cur_dim = i;
1720 /* Else press thumbs, that there are enough
1721 dimensional refs to come. Checked below. */
1723 else
1725 caf_internal_error (doublearrayref, stat, NULL,
1727 return;
1730 /* When the realloc is required, then no extent may have
1731 been set. */
1732 extent_mismatch = realloc_required
1733 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1734 /* When it already known, that a realloc is needed or
1735 the extent does not match the needed one. */
1736 if (realloc_required || realloc_needed
1737 || extent_mismatch)
1739 /* Check whether dst is reallocatable. */
1740 if (unlikely (!dst_reallocatable))
1742 caf_internal_error (nonallocextentmismatch, stat,
1743 NULL, 0, delta,
1744 GFC_DESCRIPTOR_EXTENT (dst,
1745 dst_cur_dim));
1746 return;
1748 /* Only report an error, when the extent needs to be
1749 modified, which is not allowed. */
1750 else if (!dst_reallocatable && extent_mismatch)
1752 caf_internal_error (extentoutofrange, stat, NULL,
1754 return;
1756 realloc_needed = true;
1758 /* Only change the extent when it does not match. This is
1759 to prevent resetting given array bounds. */
1760 if (extent_mismatch)
1761 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1762 size);
1765 /* Only increase the dim counter, when in an array ref. */
1766 if (in_array_ref && dst_cur_dim < dst_rank)
1767 ++dst_cur_dim;
1769 size *= (index_type)delta;
1771 if (in_array_ref)
1773 array_extent_fixed = true;
1774 in_array_ref = false;
1775 /* Check, if we got less dimensional refs than the rank of dst
1776 expects. */
1777 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1779 break;
1780 case CAF_REF_STATIC_ARRAY:
1781 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1783 switch (riter->u.a.mode[i])
1785 case CAF_ARR_REF_VECTOR:
1786 delta = riter->u.a.dim[i].v.nvec;
1787 #define KINDCASE(kind, type) case kind: \
1788 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1789 * riter->item_size; \
1790 break
1792 switch (riter->u.a.dim[i].v.kind)
1794 KINDCASE (1, GFC_INTEGER_1);
1795 KINDCASE (2, GFC_INTEGER_2);
1796 KINDCASE (4, GFC_INTEGER_4);
1797 #ifdef HAVE_GFC_INTEGER_8
1798 KINDCASE (8, GFC_INTEGER_8);
1799 #endif
1800 #ifdef HAVE_GFC_INTEGER_16
1801 KINDCASE (16, GFC_INTEGER_16);
1802 #endif
1803 default:
1804 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1805 return;
1807 #undef KINDCASE
1808 break;
1809 case CAF_ARR_REF_FULL:
1810 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
1811 + 1;
1812 /* The memptr stays unchanged when ref'ing the first element
1813 in a dimension. */
1814 break;
1815 case CAF_ARR_REF_RANGE:
1816 COMPUTE_NUM_ITEMS (delta,
1817 riter->u.a.dim[i].s.stride,
1818 riter->u.a.dim[i].s.start,
1819 riter->u.a.dim[i].s.end);
1820 memptr += riter->u.a.dim[i].s.start
1821 * riter->u.a.dim[i].s.stride
1822 * riter->item_size;
1823 break;
1824 case CAF_ARR_REF_SINGLE:
1825 delta = 1;
1826 memptr += riter->u.a.dim[i].s.start
1827 * riter->u.a.dim[i].s.stride
1828 * riter->item_size;
1829 break;
1830 case CAF_ARR_REF_OPEN_END:
1831 /* This and OPEN_START are mapped to a RANGE and therefore
1832 can not occur here. */
1833 case CAF_ARR_REF_OPEN_START:
1834 default:
1835 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1836 return;
1838 if (delta <= 0)
1839 return;
1840 /* Check the various properties of the destination array.
1841 Is an array expected and present? */
1842 if (delta > 1 && dst_rank == 0)
1844 /* No, an array is required, but not provided. */
1845 caf_internal_error (extentoutofrange, stat, NULL, 0);
1846 return;
1848 /* When dst is an array. */
1849 if (dst_rank > 0)
1851 /* Check that dst_cur_dim is valid for dst. Can be
1852 superceeded only by scalar data. */
1853 if (dst_cur_dim >= dst_rank && delta != 1)
1855 caf_internal_error (rankoutofrange, stat, NULL, 0);
1856 return;
1858 /* Do further checks, when the source is not scalar. */
1859 else if (delta != 1)
1861 /* Check that the extent is not scalar and we are not in
1862 an array ref for the dst side. */
1863 if (!in_array_ref)
1865 /* Check that this is the non-scalar extent. */
1866 if (!array_extent_fixed)
1868 /* In an array extent now. */
1869 in_array_ref = true;
1870 /* The dst is not reallocatable, so nothing more
1871 to do, then correct the dim counter. */
1872 dst_cur_dim = i;
1874 else
1876 caf_internal_error (doublearrayref, stat, NULL,
1878 return;
1881 /* When the realloc is required, then no extent may have
1882 been set. */
1883 extent_mismatch = realloc_required
1884 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1885 /* When it is already known, that a realloc is needed or
1886 the extent does not match the needed one. */
1887 if (realloc_required || realloc_needed
1888 || extent_mismatch)
1890 /* Check whether dst is reallocatable. */
1891 if (unlikely (!dst_reallocatable))
1893 caf_internal_error (nonallocextentmismatch, stat,
1894 NULL, 0, delta,
1895 GFC_DESCRIPTOR_EXTENT (dst,
1896 dst_cur_dim));
1897 return;
1899 /* Only report an error, when the extent needs to be
1900 modified, which is not allowed. */
1901 else if (!dst_reallocatable && extent_mismatch)
1903 caf_internal_error (extentoutofrange, stat, NULL,
1905 return;
1907 realloc_needed = true;
1909 /* Only change the extent when it does not match. This is
1910 to prevent resetting given array bounds. */
1911 if (extent_mismatch)
1912 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1913 size);
1915 /* Only increase the dim counter, when in an array ref. */
1916 if (in_array_ref && dst_cur_dim < dst_rank)
1917 ++dst_cur_dim;
1919 size *= (index_type)delta;
1921 if (in_array_ref)
1923 array_extent_fixed = true;
1924 in_array_ref = false;
1925 /* Check, if we got less dimensional refs than the rank of dst
1926 expects. */
1927 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1929 break;
1930 default:
1931 caf_internal_error (unknownreftype, stat, NULL, 0);
1932 return;
1934 src_size = riter->item_size;
1935 riter = riter->next;
1937 if (size == 0 || src_size == 0)
1938 return;
1939 /* Postcondition:
1940 - size contains the number of elements to store in the destination array,
1941 - src_size gives the size in bytes of each item in the destination array.
1944 if (realloc_needed)
1946 if (!array_extent_fixed)
1948 assert (size == 1);
1949 /* This can happen only, when the result is scalar. */
1950 for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
1951 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
1954 GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
1955 if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
1957 caf_internal_error (cannotallocdst, stat, NULL, 0);
1958 return;
1962 /* Reset the token. */
1963 single_token = TOKEN (token);
1964 memptr = single_token->memptr;
1965 src = single_token->desc;
1966 memset(dst_index, 0, sizeof (dst_index));
1967 i = 0;
1968 get_for_ref (refs, &i, dst_index, single_token, dst, src,
1969 GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
1970 1, stat);
1974 static void
1975 send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
1976 caf_single_token_t single_token, gfc_descriptor_t *dst,
1977 gfc_descriptor_t *src, void *ds, void *sr,
1978 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
1979 size_t num, size_t size, int *stat)
1981 const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
1982 "unknown kind in vector-ref.\n";
1983 ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
1984 const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
1986 if (unlikely (ref == NULL))
1987 /* May be we should issue an error here, because this case should not
1988 occur. */
1989 return;
1991 if (ref->next == NULL)
1993 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
1994 ptrdiff_t array_offset_src = 0;;
1995 int dst_type = -1;
1997 switch (ref->type)
1999 case CAF_REF_COMPONENT:
2000 if (ref->u.c.caf_token_offset > 0)
2002 if (*(void**)(ds + ref->u.c.offset) == NULL)
2004 /* Create a scalar temporary array descriptor. */
2005 gfc_descriptor_t static_dst;
2006 GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
2007 GFC_DESCRIPTOR_DTYPE (&static_dst)
2008 = GFC_DESCRIPTOR_DTYPE (src);
2009 /* The component can be allocated now, because it is a
2010 scalar. */
2011 _gfortran_caf_register (ref->item_size,
2012 CAF_REGTYPE_COARRAY_ALLOC,
2013 ds + ref->u.c.caf_token_offset,
2014 &static_dst, stat, NULL, 0);
2015 single_token = *(caf_single_token_t *)
2016 (ds + ref->u.c.caf_token_offset);
2017 /* In case of an error in allocation return. When stat is
2018 NULL, then register_component() terminates on error. */
2019 if (stat != NULL && *stat)
2020 return;
2021 /* Publish the allocated memory. */
2022 *((void **)(ds + ref->u.c.offset))
2023 = GFC_DESCRIPTOR_DATA (&static_dst);
2024 ds = GFC_DESCRIPTOR_DATA (&static_dst);
2025 /* Set the type from the src. */
2026 dst_type = GFC_DESCRIPTOR_TYPE (src);
2028 else
2030 single_token = *(caf_single_token_t *)
2031 (ds + ref->u.c.caf_token_offset);
2032 dst = single_token->desc;
2033 if (dst)
2035 ds = GFC_DESCRIPTOR_DATA (dst);
2036 dst_type = GFC_DESCRIPTOR_TYPE (dst);
2038 else
2040 /* When no destination descriptor is present, assume that
2041 source and dest type are identical. */
2042 dst_type = GFC_DESCRIPTOR_TYPE (src);
2043 ds = *(void **)(ds + ref->u.c.offset);
2046 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
2047 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
2049 else
2050 copy_data (ds + ref->u.c.offset, sr,
2051 dst != NULL ? GFC_DESCRIPTOR_TYPE (dst)
2052 : GFC_DESCRIPTOR_TYPE (src),
2053 GFC_DESCRIPTOR_TYPE (src),
2054 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
2055 ++(*i);
2056 return;
2057 case CAF_REF_STATIC_ARRAY:
2058 dst_type = ref->u.a.static_array_type;
2059 /* Intentionally fall through. */
2060 case CAF_REF_ARRAY:
2061 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2063 if (src_rank > 0)
2065 for (size_t d = 0; d < src_rank; ++d)
2066 array_offset_src += src_index[d];
2067 copy_data (ds, sr + array_offset_src * ref->item_size,
2068 dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
2069 : dst_type,
2070 GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
2071 ref->item_size, src_size, num, stat);
2073 else
2074 copy_data (ds, sr,
2075 dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
2076 : dst_type,
2077 GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
2078 ref->item_size, src_size, num, stat);
2079 *i += num;
2080 return;
2082 break;
2083 default:
2084 caf_runtime_error (unreachable);
2088 switch (ref->type)
2090 case CAF_REF_COMPONENT:
2091 if (ref->u.c.caf_token_offset > 0)
2093 if (*(void**)(ds + ref->u.c.offset) == NULL)
2095 /* This component refs an unallocated array. Non-arrays are
2096 caught in the if (!ref->next) above. */
2097 dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
2098 /* Assume that the rank and the dimensions fit for copying src
2099 to dst. */
2100 GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
2101 dst->offset = 0;
2102 stride_dst = 1;
2103 for (size_t d = 0; d < src_rank; ++d)
2105 extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
2106 GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
2107 GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
2108 GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
2109 stride_dst *= extent_dst;
2111 /* Null the data-pointer to make register_component allocate
2112 its own memory. */
2113 GFC_DESCRIPTOR_DATA (dst) = NULL;
2115 /* The size of the array is given by size. */
2116 _gfortran_caf_register (size * ref->item_size,
2117 CAF_REGTYPE_COARRAY_ALLOC,
2118 ds + ref->u.c.caf_token_offset,
2119 dst, stat, NULL, 0);
2120 /* In case of an error in allocation return. When stat is
2121 NULL, then register_component() terminates on error. */
2122 if (stat != NULL && *stat)
2123 return;
2125 single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
2126 send_by_ref (ref->next, i, src_index, single_token,
2127 single_token->desc, src, ds + ref->u.c.offset, sr,
2128 dst_kind, src_kind, 0, src_dim, 1, size, stat);
2130 else
2131 send_by_ref (ref->next, i, src_index, single_token,
2132 (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
2133 ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
2134 1, size, stat);
2135 return;
2136 case CAF_REF_ARRAY:
2137 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2139 send_by_ref (ref->next, i, src_index, single_token,
2140 (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
2141 0, src_dim, 1, size, stat);
2142 return;
2144 /* Only when on the left most index switch the data pointer to
2145 the array's data pointer. And only for non-static arrays. */
2146 if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
2147 ds = GFC_DESCRIPTOR_DATA (dst);
2148 switch (ref->u.a.mode[dst_dim])
2150 case CAF_ARR_REF_VECTOR:
2151 array_offset_dst = 0;
2152 src_index[src_dim] = 0;
2153 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2154 ++idx)
2156 #define KINDCASE(kind, type) case kind: \
2157 array_offset_dst = (((index_type) \
2158 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2159 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2160 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2161 break
2163 switch (ref->u.a.dim[dst_dim].v.kind)
2165 KINDCASE (1, GFC_INTEGER_1);
2166 KINDCASE (2, GFC_INTEGER_2);
2167 KINDCASE (4, GFC_INTEGER_4);
2168 #ifdef HAVE_GFC_INTEGER_8
2169 KINDCASE (8, GFC_INTEGER_8);
2170 #endif
2171 #ifdef HAVE_GFC_INTEGER_16
2172 KINDCASE (16, GFC_INTEGER_16);
2173 #endif
2174 default:
2175 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2176 return;
2178 #undef KINDCASE
2180 send_by_ref (ref, i, src_index, single_token, dst, src,
2181 ds + array_offset_dst * ref->item_size, sr,
2182 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2183 1, size, stat);
2184 if (src_rank > 0)
2185 src_index[src_dim]
2186 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2188 return;
2189 case CAF_ARR_REF_FULL:
2190 COMPUTE_NUM_ITEMS (extent_dst,
2191 ref->u.a.dim[dst_dim].s.stride,
2192 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2193 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2194 array_offset_dst = 0;
2195 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2196 * ref->u.a.dim[dst_dim].s.stride;
2197 src_index[src_dim] = 0;
2198 for (index_type idx = 0; idx < extent_dst;
2199 ++idx, array_offset_dst += stride_dst)
2201 send_by_ref (ref, i, src_index, single_token, dst, src,
2202 ds + array_offset_dst * ref->item_size, sr,
2203 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2204 1, size, stat);
2205 if (src_rank > 0)
2206 src_index[src_dim]
2207 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2209 return;
2210 case CAF_ARR_REF_RANGE:
2211 COMPUTE_NUM_ITEMS (extent_dst,
2212 ref->u.a.dim[dst_dim].s.stride,
2213 ref->u.a.dim[dst_dim].s.start,
2214 ref->u.a.dim[dst_dim].s.end);
2215 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2216 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2217 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2218 * ref->u.a.dim[dst_dim].s.stride;
2219 src_index[src_dim] = 0;
2220 for (index_type idx = 0; idx < extent_dst; ++idx)
2222 send_by_ref (ref, i, src_index, single_token, dst, src,
2223 ds + array_offset_dst * ref->item_size, sr,
2224 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2225 1, size, stat);
2226 if (src_rank > 0)
2227 src_index[src_dim]
2228 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2229 array_offset_dst += stride_dst;
2231 return;
2232 case CAF_ARR_REF_SINGLE:
2233 array_offset_dst = (ref->u.a.dim[dst_dim].s.start
2234 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
2235 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
2236 send_by_ref (ref, i, src_index, single_token, dst, src, ds
2237 + array_offset_dst * ref->item_size, sr,
2238 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
2239 size, stat);
2240 return;
2241 case CAF_ARR_REF_OPEN_END:
2242 COMPUTE_NUM_ITEMS (extent_dst,
2243 ref->u.a.dim[dst_dim].s.stride,
2244 ref->u.a.dim[dst_dim].s.start,
2245 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2246 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2247 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2248 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2249 * ref->u.a.dim[dst_dim].s.stride;
2250 src_index[src_dim] = 0;
2251 for (index_type idx = 0; idx < extent_dst; ++idx)
2253 send_by_ref (ref, i, src_index, single_token, dst, src,
2254 ds + array_offset_dst * ref->item_size, sr,
2255 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2256 1, size, stat);
2257 if (src_rank > 0)
2258 src_index[src_dim]
2259 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2260 array_offset_dst += stride_dst;
2262 return;
2263 case CAF_ARR_REF_OPEN_START:
2264 COMPUTE_NUM_ITEMS (extent_dst,
2265 ref->u.a.dim[dst_dim].s.stride,
2266 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2267 ref->u.a.dim[dst_dim].s.end);
2268 array_offset_dst = 0;
2269 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2270 * ref->u.a.dim[dst_dim].s.stride;
2271 src_index[src_dim] = 0;
2272 for (index_type idx = 0; idx < extent_dst; ++idx)
2274 send_by_ref (ref, i, src_index, single_token, dst, src,
2275 ds + array_offset_dst * ref->item_size, sr,
2276 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2277 1, size, stat);
2278 if (src_rank > 0)
2279 src_index[src_dim]
2280 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2281 array_offset_dst += stride_dst;
2283 return;
2284 default:
2285 caf_runtime_error (unreachable);
2287 return;
2288 case CAF_REF_STATIC_ARRAY:
2289 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2291 send_by_ref (ref->next, i, src_index, single_token, NULL,
2292 src, ds, sr, dst_kind, src_kind,
2293 0, src_dim, 1, size, stat);
2294 return;
2296 switch (ref->u.a.mode[dst_dim])
2298 case CAF_ARR_REF_VECTOR:
2299 array_offset_dst = 0;
2300 src_index[src_dim] = 0;
2301 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2302 ++idx)
2304 #define KINDCASE(kind, type) case kind: \
2305 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2306 break
2308 switch (ref->u.a.dim[dst_dim].v.kind)
2310 KINDCASE (1, GFC_INTEGER_1);
2311 KINDCASE (2, GFC_INTEGER_2);
2312 KINDCASE (4, GFC_INTEGER_4);
2313 #ifdef HAVE_GFC_INTEGER_8
2314 KINDCASE (8, GFC_INTEGER_8);
2315 #endif
2316 #ifdef HAVE_GFC_INTEGER_16
2317 KINDCASE (16, GFC_INTEGER_16);
2318 #endif
2319 default:
2320 caf_runtime_error (unreachable);
2321 return;
2323 #undef KINDCASE
2325 send_by_ref (ref, i, src_index, single_token, NULL, src,
2326 ds + array_offset_dst * ref->item_size, sr,
2327 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2328 1, size, stat);
2329 src_index[src_dim]
2330 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2332 return;
2333 case CAF_ARR_REF_FULL:
2334 src_index[src_dim] = 0;
2335 for (array_offset_dst = 0 ;
2336 array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
2337 array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
2339 send_by_ref (ref, i, src_index, single_token, NULL, src,
2340 ds + array_offset_dst * ref->item_size, sr,
2341 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2342 1, size, stat);
2343 if (src_rank > 0)
2344 src_index[src_dim]
2345 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2347 return;
2348 case CAF_ARR_REF_RANGE:
2349 COMPUTE_NUM_ITEMS (extent_dst,
2350 ref->u.a.dim[dst_dim].s.stride,
2351 ref->u.a.dim[dst_dim].s.start,
2352 ref->u.a.dim[dst_dim].s.end);
2353 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2354 src_index[src_dim] = 0;
2355 for (index_type idx = 0; idx < extent_dst; ++idx)
2357 send_by_ref (ref, i, src_index, single_token, NULL, src,
2358 ds + array_offset_dst * ref->item_size, sr,
2359 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2360 1, size, stat);
2361 if (src_rank > 0)
2362 src_index[src_dim]
2363 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2364 array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
2366 return;
2367 case CAF_ARR_REF_SINGLE:
2368 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
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 size, stat);
2373 return;
2374 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
2375 case CAF_ARR_REF_OPEN_END:
2376 case CAF_ARR_REF_OPEN_START:
2377 default:
2378 caf_runtime_error (unreachable);
2380 return;
2381 default:
2382 caf_runtime_error (unreachable);
2387 void
2388 _gfortran_caf_send_by_ref (caf_token_t token,
2389 int image_index __attribute__ ((unused)),
2390 gfc_descriptor_t *src, caf_reference_t *refs,
2391 int dst_kind, int src_kind,
2392 bool may_require_tmp __attribute__ ((unused)),
2393 bool dst_reallocatable, int *stat)
2395 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
2396 "unknown kind in vector-ref.\n";
2397 const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
2398 "unknown reference type.\n";
2399 const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
2400 "unknown array reference type.\n";
2401 const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
2402 "rank out of range.\n";
2403 const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
2404 "reallocation of array followed by component ref not allowed.\n";
2405 const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
2406 "can not allocate memory.\n";
2407 const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
2408 "extent of non-allocatable array mismatch.\n";
2409 const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
2410 "inner unallocated component detected.\n";
2411 size_t size, i;
2412 size_t dst_index[GFC_MAX_DIMENSIONS];
2413 int src_rank = GFC_DESCRIPTOR_RANK (src);
2414 int src_cur_dim = 0;
2415 size_t src_size = 0;
2416 caf_single_token_t single_token = TOKEN (token);
2417 void *memptr = single_token->memptr;
2418 gfc_descriptor_t *dst = single_token->desc;
2419 caf_reference_t *riter = refs;
2420 long delta;
2421 bool extent_mismatch;
2422 /* Note that the component is not allocated yet. */
2423 index_type new_component_idx = -1;
2425 if (stat)
2426 *stat = 0;
2428 /* Compute the size of the result. In the beginning size just counts the
2429 number of elements. */
2430 size = 1;
2431 while (riter)
2433 switch (riter->type)
2435 case CAF_REF_COMPONENT:
2436 if (unlikely (new_component_idx != -1))
2438 /* Allocating a component in the middle of a component ref is not
2439 support. We don't know the type to allocate. */
2440 caf_internal_error (innercompref, stat, NULL, 0);
2441 return;
2443 if (riter->u.c.caf_token_offset > 0)
2445 /* Check whether the allocatable component is zero, then no
2446 token is present, too. The token's pointer is not cleared
2447 when the structure is initialized. */
2448 if (*(void**)(memptr + riter->u.c.offset) == NULL)
2450 /* This component is not yet allocated. Check that it is
2451 allocatable here. */
2452 if (!dst_reallocatable)
2454 caf_internal_error (cannotallocdst, stat, NULL, 0);
2455 return;
2457 single_token = NULL;
2458 memptr = NULL;
2459 dst = NULL;
2460 break;
2462 single_token = *(caf_single_token_t*)
2463 (memptr + riter->u.c.caf_token_offset);
2464 memptr += riter->u.c.offset;
2465 dst = single_token->desc;
2467 else
2469 /* Regular component. */
2470 memptr += riter->u.c.offset;
2471 dst = (gfc_descriptor_t *)memptr;
2473 break;
2474 case CAF_REF_ARRAY:
2475 if (dst != NULL)
2476 memptr = GFC_DESCRIPTOR_DATA (dst);
2477 else
2478 dst = src;
2479 /* When the dst array needs to be allocated, then look at the
2480 extent of the source array in the dimension dst_cur_dim. */
2481 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2483 switch (riter->u.a.mode[i])
2485 case CAF_ARR_REF_VECTOR:
2486 delta = riter->u.a.dim[i].v.nvec;
2487 #define KINDCASE(kind, type) case kind: \
2488 memptr += (((index_type) \
2489 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2490 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2491 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2492 * riter->item_size; \
2493 break
2495 switch (riter->u.a.dim[i].v.kind)
2497 KINDCASE (1, GFC_INTEGER_1);
2498 KINDCASE (2, GFC_INTEGER_2);
2499 KINDCASE (4, GFC_INTEGER_4);
2500 #ifdef HAVE_GFC_INTEGER_8
2501 KINDCASE (8, GFC_INTEGER_8);
2502 #endif
2503 #ifdef HAVE_GFC_INTEGER_16
2504 KINDCASE (16, GFC_INTEGER_16);
2505 #endif
2506 default:
2507 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2508 return;
2510 #undef KINDCASE
2511 break;
2512 case CAF_ARR_REF_FULL:
2513 if (dst)
2514 COMPUTE_NUM_ITEMS (delta,
2515 riter->u.a.dim[i].s.stride,
2516 GFC_DIMENSION_LBOUND (dst->dim[i]),
2517 GFC_DIMENSION_UBOUND (dst->dim[i]));
2518 else
2519 COMPUTE_NUM_ITEMS (delta,
2520 riter->u.a.dim[i].s.stride,
2521 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2522 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2523 break;
2524 case CAF_ARR_REF_RANGE:
2525 COMPUTE_NUM_ITEMS (delta,
2526 riter->u.a.dim[i].s.stride,
2527 riter->u.a.dim[i].s.start,
2528 riter->u.a.dim[i].s.end);
2529 memptr += (riter->u.a.dim[i].s.start
2530 - dst->dim[i].lower_bound)
2531 * GFC_DIMENSION_STRIDE (dst->dim[i])
2532 * riter->item_size;
2533 break;
2534 case CAF_ARR_REF_SINGLE:
2535 delta = 1;
2536 memptr += (riter->u.a.dim[i].s.start
2537 - dst->dim[i].lower_bound)
2538 * GFC_DIMENSION_STRIDE (dst->dim[i])
2539 * riter->item_size;
2540 break;
2541 case CAF_ARR_REF_OPEN_END:
2542 if (dst)
2543 COMPUTE_NUM_ITEMS (delta,
2544 riter->u.a.dim[i].s.stride,
2545 riter->u.a.dim[i].s.start,
2546 GFC_DIMENSION_UBOUND (dst->dim[i]));
2547 else
2548 COMPUTE_NUM_ITEMS (delta,
2549 riter->u.a.dim[i].s.stride,
2550 riter->u.a.dim[i].s.start,
2551 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2552 memptr += (riter->u.a.dim[i].s.start
2553 - dst->dim[i].lower_bound)
2554 * GFC_DIMENSION_STRIDE (dst->dim[i])
2555 * riter->item_size;
2556 break;
2557 case CAF_ARR_REF_OPEN_START:
2558 if (dst)
2559 COMPUTE_NUM_ITEMS (delta,
2560 riter->u.a.dim[i].s.stride,
2561 GFC_DIMENSION_LBOUND (dst->dim[i]),
2562 riter->u.a.dim[i].s.end);
2563 else
2564 COMPUTE_NUM_ITEMS (delta,
2565 riter->u.a.dim[i].s.stride,
2566 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2567 riter->u.a.dim[i].s.end);
2568 /* The memptr stays unchanged when ref'ing the first element
2569 in a dimension. */
2570 break;
2571 default:
2572 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2573 return;
2576 if (delta <= 0)
2577 return;
2578 /* Check the various properties of the source array.
2579 When src is an array. */
2580 if (delta > 1 && src_rank > 0)
2582 /* Check that src_cur_dim is valid for src. Can be
2583 superceeded only by scalar data. */
2584 if (src_cur_dim >= src_rank)
2586 caf_internal_error (rankoutofrange, stat, NULL, 0);
2587 return;
2589 /* Do further checks, when the source is not scalar. */
2590 else
2592 /* When the realloc is required, then no extent may have
2593 been set. */
2594 extent_mismatch = memptr == NULL
2595 || (dst
2596 && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
2597 != delta);
2598 /* When it already known, that a realloc is needed or
2599 the extent does not match the needed one. */
2600 if (extent_mismatch)
2602 /* Check whether dst is reallocatable. */
2603 if (unlikely (!dst_reallocatable))
2605 caf_internal_error (nonallocextentmismatch, stat,
2606 NULL, 0, delta,
2607 GFC_DESCRIPTOR_EXTENT (dst,
2608 src_cur_dim));
2609 return;
2611 /* Report error on allocatable but missing inner
2612 ref. */
2613 else if (riter->next != NULL)
2615 caf_internal_error (realloconinnerref, stat, NULL,
2617 return;
2620 /* Only change the extent when it does not match. This is
2621 to prevent resetting given array bounds. */
2622 if (extent_mismatch)
2623 GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
2624 size);
2626 /* Increase the dim-counter of the src only when the extent
2627 matches. */
2628 if (src_cur_dim < src_rank
2629 && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
2630 ++src_cur_dim;
2632 size *= (index_type)delta;
2634 break;
2635 case CAF_REF_STATIC_ARRAY:
2636 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2638 switch (riter->u.a.mode[i])
2640 case CAF_ARR_REF_VECTOR:
2641 delta = riter->u.a.dim[i].v.nvec;
2642 #define KINDCASE(kind, type) case kind: \
2643 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2644 * riter->item_size; \
2645 break
2647 switch (riter->u.a.dim[i].v.kind)
2649 KINDCASE (1, GFC_INTEGER_1);
2650 KINDCASE (2, GFC_INTEGER_2);
2651 KINDCASE (4, GFC_INTEGER_4);
2652 #ifdef HAVE_GFC_INTEGER_8
2653 KINDCASE (8, GFC_INTEGER_8);
2654 #endif
2655 #ifdef HAVE_GFC_INTEGER_16
2656 KINDCASE (16, GFC_INTEGER_16);
2657 #endif
2658 default:
2659 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2660 return;
2662 #undef KINDCASE
2663 break;
2664 case CAF_ARR_REF_FULL:
2665 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
2666 + 1;
2667 /* The memptr stays unchanged when ref'ing the first element
2668 in a dimension. */
2669 break;
2670 case CAF_ARR_REF_RANGE:
2671 COMPUTE_NUM_ITEMS (delta,
2672 riter->u.a.dim[i].s.stride,
2673 riter->u.a.dim[i].s.start,
2674 riter->u.a.dim[i].s.end);
2675 memptr += riter->u.a.dim[i].s.start
2676 * riter->u.a.dim[i].s.stride
2677 * riter->item_size;
2678 break;
2679 case CAF_ARR_REF_SINGLE:
2680 delta = 1;
2681 memptr += riter->u.a.dim[i].s.start
2682 * riter->u.a.dim[i].s.stride
2683 * riter->item_size;
2684 break;
2685 case CAF_ARR_REF_OPEN_END:
2686 /* This and OPEN_START are mapped to a RANGE and therefore
2687 can not occur here. */
2688 case CAF_ARR_REF_OPEN_START:
2689 default:
2690 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2691 return;
2693 if (delta <= 0)
2694 return;
2695 /* Check the various properties of the source array.
2696 Only when the source array is not scalar examine its
2697 properties. */
2698 if (delta > 1 && src_rank > 0)
2700 /* Check that src_cur_dim is valid for src. Can be
2701 superceeded only by scalar data. */
2702 if (src_cur_dim >= src_rank)
2704 caf_internal_error (rankoutofrange, stat, NULL, 0);
2705 return;
2707 else
2709 /* We will not be able to realloc the dst, because that's
2710 a fixed size array. */
2711 extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
2712 != delta;
2713 /* When the extent does not match the needed one we can
2714 only stop here. */
2715 if (extent_mismatch)
2717 caf_internal_error (nonallocextentmismatch, stat,
2718 NULL, 0, delta,
2719 GFC_DESCRIPTOR_EXTENT (src,
2720 src_cur_dim));
2721 return;
2724 ++src_cur_dim;
2726 size *= (index_type)delta;
2728 break;
2729 default:
2730 caf_internal_error (unknownreftype, stat, NULL, 0);
2731 return;
2733 src_size = riter->item_size;
2734 riter = riter->next;
2736 if (size == 0 || src_size == 0)
2737 return;
2738 /* Postcondition:
2739 - size contains the number of elements to store in the destination array,
2740 - src_size gives the size in bytes of each item in the destination array.
2743 /* Reset the token. */
2744 single_token = TOKEN (token);
2745 memptr = single_token->memptr;
2746 dst = single_token->desc;
2747 memset (dst_index, 0, sizeof (dst_index));
2748 i = 0;
2749 send_by_ref (refs, &i, dst_index, single_token, dst, src,
2750 memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
2751 1, size, stat);
2752 assert (i == size);
2756 void
2757 _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
2758 caf_reference_t *dst_refs, caf_token_t src_token,
2759 int src_image_index,
2760 caf_reference_t *src_refs, int dst_kind,
2761 int src_kind, bool may_require_tmp, int *dst_stat,
2762 int *src_stat)
2764 gfc_array_void temp;
2766 _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
2767 dst_kind, src_kind, may_require_tmp, true,
2768 src_stat);
2770 if (src_stat && *src_stat != 0)
2771 return;
2773 _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
2774 dst_kind, src_kind, may_require_tmp, true,
2775 dst_stat);
2776 if (GFC_DESCRIPTOR_DATA (&temp))
2777 free (GFC_DESCRIPTOR_DATA (&temp));
2781 void
2782 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
2783 int image_index __attribute__ ((unused)),
2784 void *value, int *stat,
2785 int type __attribute__ ((unused)), int kind)
2787 assert(kind == 4);
2789 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2791 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2793 if (stat)
2794 *stat = 0;
2797 void
2798 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
2799 int image_index __attribute__ ((unused)),
2800 void *value, int *stat,
2801 int type __attribute__ ((unused)), int kind)
2803 assert(kind == 4);
2805 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2807 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2809 if (stat)
2810 *stat = 0;
2814 void
2815 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
2816 int image_index __attribute__ ((unused)),
2817 void *old, void *compare, void *new_val, int *stat,
2818 int type __attribute__ ((unused)), int kind)
2820 assert(kind == 4);
2822 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2824 *(uint32_t *) old = *(uint32_t *) compare;
2825 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
2826 *(uint32_t *) new_val, false,
2827 __ATOMIC_RELAXED, __ATOMIC_RELAXED);
2828 if (stat)
2829 *stat = 0;
2833 void
2834 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
2835 int image_index __attribute__ ((unused)),
2836 void *value, void *old, int *stat,
2837 int type __attribute__ ((unused)), int kind)
2839 assert(kind == 4);
2841 uint32_t res;
2842 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2844 switch (op)
2846 case GFC_CAF_ATOMIC_ADD:
2847 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2848 break;
2849 case GFC_CAF_ATOMIC_AND:
2850 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2851 break;
2852 case GFC_CAF_ATOMIC_OR:
2853 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2854 break;
2855 case GFC_CAF_ATOMIC_XOR:
2856 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2857 break;
2858 default:
2859 __builtin_unreachable();
2862 if (old)
2863 *(uint32_t *) old = res;
2865 if (stat)
2866 *stat = 0;
2869 void
2870 _gfortran_caf_event_post (caf_token_t token, size_t index,
2871 int image_index __attribute__ ((unused)),
2872 int *stat, char *errmsg __attribute__ ((unused)),
2873 int errmsg_len __attribute__ ((unused)))
2875 uint32_t value = 1;
2876 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2877 * sizeof (uint32_t));
2878 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2880 if(stat)
2881 *stat = 0;
2884 void
2885 _gfortran_caf_event_wait (caf_token_t token, size_t index,
2886 int until_count, int *stat,
2887 char *errmsg __attribute__ ((unused)),
2888 int errmsg_len __attribute__ ((unused)))
2890 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2891 * sizeof (uint32_t));
2892 uint32_t value = (uint32_t)-until_count;
2893 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2895 if(stat)
2896 *stat = 0;
2899 void
2900 _gfortran_caf_event_query (caf_token_t token, size_t index,
2901 int image_index __attribute__ ((unused)),
2902 int *count, int *stat)
2904 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2905 * sizeof (uint32_t));
2906 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
2908 if(stat)
2909 *stat = 0;
2912 void
2913 _gfortran_caf_lock (caf_token_t token, size_t index,
2914 int image_index __attribute__ ((unused)),
2915 int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
2917 const char *msg = "Already locked";
2918 bool *lock = &((bool *) MEMTOK (token))[index];
2920 if (!*lock)
2922 *lock = true;
2923 if (aquired_lock)
2924 *aquired_lock = (int) true;
2925 if (stat)
2926 *stat = 0;
2927 return;
2930 if (aquired_lock)
2932 *aquired_lock = (int) false;
2933 if (stat)
2934 *stat = 0;
2935 return;
2939 if (stat)
2941 *stat = 1;
2942 if (errmsg_len > 0)
2944 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
2945 : (int) sizeof (msg);
2946 memcpy (errmsg, msg, len);
2947 if (errmsg_len > len)
2948 memset (&errmsg[len], ' ', errmsg_len-len);
2950 return;
2952 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
2956 void
2957 _gfortran_caf_unlock (caf_token_t token, size_t index,
2958 int image_index __attribute__ ((unused)),
2959 int *stat, char *errmsg, int errmsg_len)
2961 const char *msg = "Variable is not locked";
2962 bool *lock = &((bool *) MEMTOK (token))[index];
2964 if (*lock)
2966 *lock = false;
2967 if (stat)
2968 *stat = 0;
2969 return;
2972 if (stat)
2974 *stat = 1;
2975 if (errmsg_len > 0)
2977 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
2978 : (int) sizeof (msg);
2979 memcpy (errmsg, msg, len);
2980 if (errmsg_len > len)
2981 memset (&errmsg[len], ' ', errmsg_len-len);
2983 return;
2985 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
2989 _gfortran_caf_is_present (caf_token_t token,
2990 int image_index __attribute__ ((unused)),
2991 caf_reference_t *refs)
2993 const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
2994 "only scalar indexes allowed.\n";
2995 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
2996 "unknown reference type.\n";
2997 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
2998 "unknown array reference type.\n";
2999 size_t i;
3000 caf_single_token_t single_token = TOKEN (token);
3001 void *memptr = single_token->memptr;
3002 gfc_descriptor_t *src = single_token->desc;
3003 caf_reference_t *riter = refs;
3005 while (riter)
3007 switch (riter->type)
3009 case CAF_REF_COMPONENT:
3010 if (riter->u.c.caf_token_offset)
3012 single_token = *(caf_single_token_t*)
3013 (memptr + riter->u.c.caf_token_offset);
3014 memptr = single_token->memptr;
3015 src = single_token->desc;
3017 else
3019 memptr += riter->u.c.offset;
3020 src = (gfc_descriptor_t *)memptr;
3022 break;
3023 case CAF_REF_ARRAY:
3024 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3026 switch (riter->u.a.mode[i])
3028 case CAF_ARR_REF_SINGLE:
3029 memptr += (riter->u.a.dim[i].s.start
3030 - GFC_DIMENSION_LBOUND (src->dim[i]))
3031 * GFC_DIMENSION_STRIDE (src->dim[i])
3032 * riter->item_size;
3033 break;
3034 case CAF_ARR_REF_FULL:
3035 /* A full array ref is allowed on the last reference only. */
3036 if (riter->next == NULL)
3037 break;
3038 /* else fall through reporting an error. */
3039 /* FALLTHROUGH */
3040 case CAF_ARR_REF_VECTOR:
3041 case CAF_ARR_REF_RANGE:
3042 case CAF_ARR_REF_OPEN_END:
3043 case CAF_ARR_REF_OPEN_START:
3044 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3045 return 0;
3046 default:
3047 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3048 return 0;
3051 break;
3052 case CAF_REF_STATIC_ARRAY:
3053 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3055 switch (riter->u.a.mode[i])
3057 case CAF_ARR_REF_SINGLE:
3058 memptr += riter->u.a.dim[i].s.start
3059 * riter->u.a.dim[i].s.stride
3060 * riter->item_size;
3061 break;
3062 case CAF_ARR_REF_FULL:
3063 /* A full array ref is allowed on the last reference only. */
3064 if (riter->next == NULL)
3065 break;
3066 /* else fall through reporting an error. */
3067 /* FALLTHROUGH */
3068 case CAF_ARR_REF_VECTOR:
3069 case CAF_ARR_REF_RANGE:
3070 case CAF_ARR_REF_OPEN_END:
3071 case CAF_ARR_REF_OPEN_START:
3072 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3073 return 0;
3074 default:
3075 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3076 return 0;
3079 break;
3080 default:
3081 caf_internal_error (unknownreftype, 0, NULL, 0);
3082 return 0;
3084 riter = riter->next;
3086 return memptr != NULL;