1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2018 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)
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/>. */
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. */
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. */
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. */
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. */
61 caf_runtime_error (const char *message
, ...)
64 fprintf (stderr
, "Fortran runtime error: ");
65 va_start (ap
, message
);
66 vfprintf (stderr
, message
, ap
);
68 fprintf (stderr
, "\n");
70 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
74 /* Error handling is similar everytime. */
76 caf_internal_error (const char *msg
, int *stat
, char *errmsg
,
80 va_start (args
, errmsg_len
);
86 size_t len
= snprintf (errmsg
, errmsg_len
, msg
, args
);
87 if ((size_t)errmsg_len
> len
)
88 memset (&errmsg
[len
], ' ', errmsg_len
- len
);
94 caf_runtime_error (msg
, args
);
100 _gfortran_caf_init (int *argc
__attribute__ ((unused
)),
101 char ***argv
__attribute__ ((unused
)))
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
)))
127 _gfortran_caf_num_images (int distance
__attribute__ ((unused
)),
128 int failed
__attribute__ ((unused
)))
135 _gfortran_caf_register (size_t size
, caf_register_t type
, caf_token_t
*token
,
136 gfc_descriptor_t
*data
, int *stat
, char *errmsg
,
139 const char alloc_fail_msg
[] = "Failed to allocate coarray";
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
)
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
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. */
169 caf_internal_error (alloc_fail_msg
, stat
, errmsg
, errmsg_len
);
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
;
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
;
189 caf_static_list
= tmp
;
191 GFC_DESCRIPTOR_DATA (data
) = local
;
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
));
212 single_token
->memptr
= NULL
;
213 single_token
->owning_memory
= false;
222 _gfortran_caf_sync_all (int *stat
,
223 char *errmsg
__attribute__ ((unused
)),
224 int errmsg_len
__attribute__ ((unused
)))
226 __asm__
__volatile__ ("":::"memory");
233 _gfortran_caf_sync_memory (int *stat
,
234 char *errmsg
__attribute__ ((unused
)),
235 int errmsg_len
__attribute__ ((unused
)))
237 __asm__
__volatile__ ("":::"memory");
244 _gfortran_caf_sync_images (int count
__attribute__ ((unused
)),
245 int images
[] __attribute__ ((unused
)),
247 char *errmsg
__attribute__ ((unused
)),
248 int errmsg_len
__attribute__ ((unused
)))
253 for (i
= 0; i
< count
; i
++)
256 fprintf (stderr
, "COARRAY ERROR: Invalid image index %d to SYNC "
257 "IMAGES", images
[i
]);
262 __asm__
__volatile__ ("":::"memory");
269 _gfortran_caf_stop_numeric(int32_t stop_code
)
271 fprintf (stderr
, "STOP %d\n", stop_code
);
277 _gfortran_caf_stop_str(const char *string
, int32_t len
)
279 fputs ("STOP ", stderr
);
281 fputc (*(string
++), stderr
);
282 fputs ("\n", stderr
);
289 _gfortran_caf_error_stop_str (const char *string
, int32_t len
)
291 fputs ("ERROR STOP ", stderr
);
293 fputc (*(string
++), stderr
);
294 fputs ("\n", stderr
);
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
);
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
)))
320 return CAF_STAT_STOPPED_IMAGE
;
324 /* Single image library. There can not be any failed images with only one
328 _gfortran_caf_failed_images (gfc_descriptor_t
*array
,
329 caf_team_t
* team
__attribute__ ((unused
)),
332 int local_kind
= kind
!= NULL
? *kind
: 4;
334 array
->base_addr
= NULL
;
335 array
->dtype
.type
= BT_INTEGER
;
336 array
->dtype
.elem_len
= local_kind
;
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;
346 /* With only one image available no other images can be stopped. Therefore
347 return an empty array. */
350 _gfortran_caf_stopped_images (gfc_descriptor_t
*array
,
351 caf_team_t
* team
__attribute__ ((unused
)),
354 int local_kind
= kind
!= NULL
? *kind
: 4;
356 array
->base_addr
= NULL
;
357 array
->dtype
.type
= BT_INTEGER
;
358 array
->dtype
.elem_len
= local_kind
;
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;
369 _gfortran_caf_error_stop (int32_t error
)
371 fprintf (stderr
, "ERROR STOP %d\n", error
);
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
)))
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
)))
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
)))
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
)))
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
)))
435 assign_char4_from_char1 (size_t dst_size
, size_t src_size
, uint32_t *dst
,
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) ' ';
448 assign_char1_from_char4 (size_t dst_size
, size_t src_size
, unsigned char *dst
,
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
];
456 memset (&dst
[n
], ' ', dst_size
- n
);
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
;
467 typedef int64_t int128t
;
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
;
481 typedef double real128t
;
482 typedef _Complex
double complex128t
;
486 real128t real_val
= 0;
487 complex128t cmpx_val
= 0;
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
;
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
;
516 #ifdef HAVE_GFC_REAL_16
517 else if (src_kind
== 16)
518 real_val
= *(real128t
*) src
;
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
;
532 #ifdef HAVE_GFC_REAL_16
533 else if (src_kind
== 16)
534 cmpx_val
= *(complex128t
*) src
;
546 if (src_type
== BT_INTEGER
)
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
;
563 else if (src_type
== BT_REAL
)
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
;
580 else if (src_type
== BT_COMPLEX
)
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
;
601 if (src_type
== BT_INTEGER
)
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
;
611 #ifdef HAVE_GFC_REAL_16
612 else if (dst_kind
== 16)
613 *(real128t
*) dst
= (real128t
) int_val
;
618 else if (src_type
== BT_REAL
)
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
;
628 #ifdef HAVE_GFC_REAL_16
629 else if (dst_kind
== 16)
630 *(real128t
*) dst
= (real128t
) real_val
;
635 else if (src_type
== BT_COMPLEX
)
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
;
645 #ifdef HAVE_GFC_REAL_16
646 else if (dst_kind
== 16)
647 *(real128t
*) dst
= (real128t
) cmpx_val
;
654 if (src_type
== BT_INTEGER
)
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
;
664 #ifdef HAVE_GFC_REAL_16
665 else if (dst_kind
== 16)
666 *(complex128t
*) dst
= (complex128t
) int_val
;
671 else if (src_type
== BT_REAL
)
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
;
681 #ifdef HAVE_GFC_REAL_16
682 else if (dst_kind
== 16)
683 *(complex128t
*) dst
= (complex128t
) real_val
;
688 else if (src_type
== BT_COMPLEX
)
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
;
698 #ifdef HAVE_GFC_REAL_16
699 else if (dst_kind
== 16)
700 *(complex128t
*) dst
= (complex128t
) cmpx_val
;
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
);
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. */
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
);
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
)
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
),
761 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
762 assign_char4_from_char1 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
765 convert_type (GFC_DESCRIPTOR_DATA (dest
), GFC_DESCRIPTOR_TYPE (dest
),
766 dst_kind
, sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
771 for (j
= 0; j
< rank
; j
++)
773 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
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
;
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
)
837 memset ((void*)(char*) dst
+ 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
);
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
;
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;
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
)
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
);
909 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
910 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
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. */
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
);
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
)
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
));
957 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
958 GFC_DESCRIPTOR_DATA (src
), GFC_DESCRIPTOR_TYPE (src
),
964 for (j
= 0; j
< rank
; j
++)
966 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
977 ptrdiff_t array_offset_sr
, array_offset_dst
;
980 if (GFC_DESCRIPTOR_RANK (src
) == 0)
982 tmp
= malloc (src_size
);
983 memcpy (tmp
, GFC_DESCRIPTOR_DATA (src
), src_size
);
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
)
1034 dst_size
> src_size
? src_size
: dst_size
);
1035 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
1036 && dst_size
> src_size
)
1039 memset ((void*)(char*) dst
+ 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
);
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
;
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
));
1078 if (GFC_DESCRIPTOR_RANK (src
) != 0)
1080 ptrdiff_t array_offset_sr
= 0;
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
));
1097 sr
= src
->base_addr
;
1099 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
1100 && dst_kind
== src_kind
)
1103 dst_size
> src_size
? src_size
: dst_size
);
1104 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
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
);
1118 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
1119 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
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
,
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
)
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";
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
)
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
)
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
);
1174 for (k
= 0; k
< num
; ++k
)
1176 convert_type (ds
, dst_type
, dst_kind
, sr
, src_type
, src_kind
, stat
);
1183 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
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; \
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
, int src_type
)
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
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
);
1215 case CAF_REF_COMPONENT
:
1216 /* Because the token is always registered after the component, its
1217 offset is always greater zero. */
1218 if (ref
->u
.c
.caf_token_offset
> 0)
1219 /* Note, that sr is dereffed here. */
1220 copy_data (ds
, *(void **)(sr
+ ref
->u
.c
.offset
),
1221 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1222 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1224 copy_data (ds
, sr
+ ref
->u
.c
.offset
,
1225 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1226 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1229 case CAF_REF_STATIC_ARRAY
:
1230 /* Intentionally fall through. */
1232 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1234 for (size_t d
= 0; d
< dst_rank
; ++d
)
1235 array_offset_dst
+= dst_index
[d
];
1236 copy_data (ds
+ array_offset_dst
* dst_size
, sr
,
1237 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1238 dst_kind
, src_kind
, dst_size
, ref
->item_size
, num
,
1245 caf_runtime_error (unreachable
);
1251 case CAF_REF_COMPONENT
:
1252 if (ref
->u
.c
.caf_token_offset
> 0)
1254 single_token
= *(caf_single_token_t
*)(sr
+ ref
->u
.c
.caf_token_offset
);
1256 if (ref
->next
&& ref
->next
->type
== CAF_REF_ARRAY
)
1257 src
= single_token
->desc
;
1261 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
1262 /* The currently ref'ed component was allocatabe (caf_token_offset
1263 > 0) and the next ref is a component, too, then the new sr has to
1264 be dereffed. (static arrays can not be allocatable or they
1265 become an array with descriptor. */
1266 sr
= *(void **)(sr
+ ref
->u
.c
.offset
);
1268 sr
+= ref
->u
.c
.offset
;
1270 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
, src
,
1271 ds
, sr
, dst_kind
, src_kind
, dst_dim
, 0,
1275 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1276 (gfc_descriptor_t
*)(sr
+ ref
->u
.c
.offset
), ds
,
1277 sr
+ ref
->u
.c
.offset
, dst_kind
, src_kind
, dst_dim
, 0, 1,
1281 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1283 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1284 src
, ds
, sr
, dst_kind
, src_kind
,
1285 dst_dim
, 0, 1, stat
, src_type
);
1288 /* Only when on the left most index switch the data pointer to
1289 the array's data pointer. */
1291 sr
= GFC_DESCRIPTOR_DATA (src
);
1292 switch (ref
->u
.a
.mode
[src_dim
])
1294 case CAF_ARR_REF_VECTOR
:
1295 extent_src
= GFC_DIMENSION_EXTENT (src
->dim
[src_dim
]);
1296 array_offset_src
= 0;
1297 dst_index
[dst_dim
] = 0;
1298 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1301 #define KINDCASE(kind, type) case kind: \
1302 array_offset_src = (((index_type) \
1303 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1304 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1305 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1308 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1310 KINDCASE (1, GFC_INTEGER_1
);
1311 KINDCASE (2, GFC_INTEGER_2
);
1312 KINDCASE (4, GFC_INTEGER_4
);
1313 #ifdef HAVE_GFC_INTEGER_8
1314 KINDCASE (8, GFC_INTEGER_8
);
1316 #ifdef HAVE_GFC_INTEGER_16
1317 KINDCASE (16, GFC_INTEGER_16
);
1320 caf_runtime_error (unreachable
);
1325 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1326 ds
, sr
+ array_offset_src
* ref
->item_size
,
1327 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1330 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1333 case CAF_ARR_REF_FULL
:
1334 COMPUTE_NUM_ITEMS (extent_src
,
1335 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1336 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1337 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1338 stride_src
= src
->dim
[src_dim
]._stride
1339 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1340 array_offset_src
= 0;
1341 dst_index
[dst_dim
] = 0;
1342 for (index_type idx
= 0; idx
< extent_src
;
1343 ++idx
, array_offset_src
+= stride_src
)
1345 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1346 ds
, sr
+ array_offset_src
* ref
->item_size
,
1347 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1350 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1353 case CAF_ARR_REF_RANGE
:
1354 COMPUTE_NUM_ITEMS (extent_src
,
1355 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1356 ref
->u
.a
.dim
[src_dim
].s
.start
,
1357 ref
->u
.a
.dim
[src_dim
].s
.end
);
1358 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1359 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1360 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1361 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1362 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1363 dst_index
[dst_dim
] = 0;
1364 /* Increase the dst_dim only, when the src_extent is greater one
1365 or src and dst extent are both one. Don't increase when the scalar
1366 source is not present in the dst. */
1367 next_dst_dim
= extent_src
> 1
1368 || (GFC_DIMENSION_EXTENT (dst
->dim
[dst_dim
]) == 1
1369 && extent_src
== 1) ? (dst_dim
+ 1) : dst_dim
;
1370 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1372 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1373 ds
, sr
+ array_offset_src
* ref
->item_size
,
1374 dst_kind
, src_kind
, next_dst_dim
, src_dim
+ 1,
1377 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1378 array_offset_src
+= stride_src
;
1381 case CAF_ARR_REF_SINGLE
:
1382 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1383 - src
->dim
[src_dim
].lower_bound
)
1384 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1385 dst_index
[dst_dim
] = 0;
1386 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
, ds
,
1387 sr
+ array_offset_src
* ref
->item_size
,
1388 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1391 case CAF_ARR_REF_OPEN_END
:
1392 COMPUTE_NUM_ITEMS (extent_src
,
1393 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1394 ref
->u
.a
.dim
[src_dim
].s
.start
,
1395 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1396 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1397 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1398 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1399 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1400 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1401 dst_index
[dst_dim
] = 0;
1402 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1404 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1405 ds
, sr
+ array_offset_src
* ref
->item_size
,
1406 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1409 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1410 array_offset_src
+= stride_src
;
1413 case CAF_ARR_REF_OPEN_START
:
1414 COMPUTE_NUM_ITEMS (extent_src
,
1415 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1416 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1417 ref
->u
.a
.dim
[src_dim
].s
.end
);
1418 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1419 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1420 array_offset_src
= 0;
1421 dst_index
[dst_dim
] = 0;
1422 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1424 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1425 ds
, sr
+ array_offset_src
* ref
->item_size
,
1426 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1429 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1430 array_offset_src
+= stride_src
;
1434 caf_runtime_error (unreachable
);
1437 case CAF_REF_STATIC_ARRAY
:
1438 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1440 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1441 NULL
, ds
, sr
, dst_kind
, src_kind
,
1442 dst_dim
, 0, 1, stat
, src_type
);
1445 switch (ref
->u
.a
.mode
[src_dim
])
1447 case CAF_ARR_REF_VECTOR
:
1448 array_offset_src
= 0;
1449 dst_index
[dst_dim
] = 0;
1450 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1453 #define KINDCASE(kind, type) case kind: \
1454 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1457 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1459 KINDCASE (1, GFC_INTEGER_1
);
1460 KINDCASE (2, GFC_INTEGER_2
);
1461 KINDCASE (4, GFC_INTEGER_4
);
1462 #ifdef HAVE_GFC_INTEGER_8
1463 KINDCASE (8, GFC_INTEGER_8
);
1465 #ifdef HAVE_GFC_INTEGER_16
1466 KINDCASE (16, GFC_INTEGER_16
);
1469 caf_runtime_error (unreachable
);
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,
1479 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1482 case CAF_ARR_REF_FULL
:
1483 dst_index
[dst_dim
] = 0;
1484 for (array_offset_src
= 0 ;
1485 array_offset_src
<= ref
->u
.a
.dim
[src_dim
].s
.end
;
1486 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
)
1488 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1489 ds
, sr
+ array_offset_src
* ref
->item_size
,
1490 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1493 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1496 case CAF_ARR_REF_RANGE
:
1497 COMPUTE_NUM_ITEMS (extent_src
,
1498 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1499 ref
->u
.a
.dim
[src_dim
].s
.start
,
1500 ref
->u
.a
.dim
[src_dim
].s
.end
);
1501 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1502 dst_index
[dst_dim
] = 0;
1503 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1505 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1506 ds
, sr
+ array_offset_src
* ref
->item_size
,
1507 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1510 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1511 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
;
1514 case CAF_ARR_REF_SINGLE
:
1515 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1516 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
, ds
,
1517 sr
+ array_offset_src
* ref
->item_size
,
1518 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1521 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
1522 case CAF_ARR_REF_OPEN_END
:
1523 case CAF_ARR_REF_OPEN_START
:
1525 caf_runtime_error (unreachable
);
1529 caf_runtime_error (unreachable
);
1535 _gfortran_caf_get_by_ref (caf_token_t token
,
1536 int image_index
__attribute__ ((unused
)),
1537 gfc_descriptor_t
*dst
, caf_reference_t
*refs
,
1538 int dst_kind
, int src_kind
,
1539 bool may_require_tmp
__attribute__ ((unused
)),
1540 bool dst_reallocatable
, int *stat
,
1543 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
1544 "unknown kind in vector-ref.\n";
1545 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
1546 "unknown reference type.\n";
1547 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
1548 "unknown array reference type.\n";
1549 const char rankoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1550 "rank out of range.\n";
1551 const char extentoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1552 "extent out of range.\n";
1553 const char cannotallocdst
[] = "libcaf_single::caf_get_by_ref(): "
1554 "can not allocate memory.\n";
1555 const char nonallocextentmismatch
[] = "libcaf_single::caf_get_by_ref(): "
1556 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1557 const char doublearrayref
[] = "libcaf_single::caf_get_by_ref(): "
1558 "two or more array part references are not supported.\n";
1560 size_t dst_index
[GFC_MAX_DIMENSIONS
];
1561 int dst_rank
= GFC_DESCRIPTOR_RANK (dst
);
1562 int dst_cur_dim
= 0;
1563 size_t src_size
= 0;
1564 caf_single_token_t single_token
= TOKEN (token
);
1565 void *memptr
= single_token
->memptr
;
1566 gfc_descriptor_t
*src
= single_token
->desc
;
1567 caf_reference_t
*riter
= refs
;
1569 /* Reallocation of dst.data is needed (e.g., array to small). */
1570 bool realloc_needed
;
1571 /* Reallocation of dst.data is required, because data is not alloced at
1573 bool realloc_required
;
1574 bool extent_mismatch
= false;
1575 /* Set when the first non-scalar array reference is encountered. */
1576 bool in_array_ref
= false;
1577 bool array_extent_fixed
= false;
1578 realloc_needed
= realloc_required
= GFC_DESCRIPTOR_DATA (dst
) == NULL
;
1580 assert (!realloc_needed
|| dst_reallocatable
);
1585 /* Compute the size of the result. In the beginning size just counts the
1586 number of elements. */
1590 switch (riter
->type
)
1592 case CAF_REF_COMPONENT
:
1593 if (riter
->u
.c
.caf_token_offset
)
1595 single_token
= *(caf_single_token_t
*)
1596 (memptr
+ riter
->u
.c
.caf_token_offset
);
1597 memptr
= single_token
->memptr
;
1598 src
= single_token
->desc
;
1602 memptr
+= riter
->u
.c
.offset
;
1603 /* When the next ref is an array ref, assume there is an
1604 array descriptor at memptr. Note, static arrays do not have
1606 if (riter
->next
&& riter
->next
->type
== CAF_REF_ARRAY
)
1607 src
= (gfc_descriptor_t
*)memptr
;
1613 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1615 switch (riter
->u
.a
.mode
[i
])
1617 case CAF_ARR_REF_VECTOR
:
1618 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1619 #define KINDCASE(kind, type) case kind: \
1620 memptr += (((index_type) \
1621 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1622 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1623 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1624 * riter->item_size; \
1627 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1629 KINDCASE (1, GFC_INTEGER_1
);
1630 KINDCASE (2, GFC_INTEGER_2
);
1631 KINDCASE (4, GFC_INTEGER_4
);
1632 #ifdef HAVE_GFC_INTEGER_8
1633 KINDCASE (8, GFC_INTEGER_8
);
1635 #ifdef HAVE_GFC_INTEGER_16
1636 KINDCASE (16, GFC_INTEGER_16
);
1639 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1644 case CAF_ARR_REF_FULL
:
1645 COMPUTE_NUM_ITEMS (delta
,
1646 riter
->u
.a
.dim
[i
].s
.stride
,
1647 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1648 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1649 /* The memptr stays unchanged when ref'ing the first element
1652 case CAF_ARR_REF_RANGE
:
1653 COMPUTE_NUM_ITEMS (delta
,
1654 riter
->u
.a
.dim
[i
].s
.stride
,
1655 riter
->u
.a
.dim
[i
].s
.start
,
1656 riter
->u
.a
.dim
[i
].s
.end
);
1657 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1658 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1659 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1662 case CAF_ARR_REF_SINGLE
:
1664 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1665 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1666 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1669 case CAF_ARR_REF_OPEN_END
:
1670 COMPUTE_NUM_ITEMS (delta
,
1671 riter
->u
.a
.dim
[i
].s
.stride
,
1672 riter
->u
.a
.dim
[i
].s
.start
,
1673 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1674 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1675 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1676 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1679 case CAF_ARR_REF_OPEN_START
:
1680 COMPUTE_NUM_ITEMS (delta
,
1681 riter
->u
.a
.dim
[i
].s
.stride
,
1682 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1683 riter
->u
.a
.dim
[i
].s
.end
);
1684 /* The memptr stays unchanged when ref'ing the first element
1688 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1693 /* Check the various properties of the destination array.
1694 Is an array expected and present? */
1695 if (delta
> 1 && dst_rank
== 0)
1697 /* No, an array is required, but not provided. */
1698 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1701 /* Special mode when called by __caf_sendget_by_ref (). */
1702 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1704 dst_rank
= dst_cur_dim
+ 1;
1705 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1706 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1708 /* When dst is an array. */
1711 /* Check that dst_cur_dim is valid for dst. Can be
1712 superceeded only by scalar data. */
1713 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1715 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1718 /* Do further checks, when the source is not scalar. */
1719 else if (delta
!= 1)
1721 /* Check that the extent is not scalar and we are not in
1722 an array ref for the dst side. */
1725 /* Check that this is the non-scalar extent. */
1726 if (!array_extent_fixed
)
1728 /* In an array extent now. */
1729 in_array_ref
= true;
1730 /* Check that we haven't skipped any scalar
1731 dimensions yet and that the dst is
1734 && dst_rank
== GFC_DESCRIPTOR_RANK (src
))
1736 if (dst_reallocatable
)
1738 /* Dst is reallocatable, which means that
1739 the bounds are not set. Set them. */
1740 for (dst_cur_dim
= 0; dst_cur_dim
< (int)i
;
1742 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
],
1748 /* Else press thumbs, that there are enough
1749 dimensional refs to come. Checked below. */
1753 caf_internal_error (doublearrayref
, stat
, NULL
,
1758 /* When the realloc is required, then no extent may have
1760 extent_mismatch
= realloc_required
1761 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1762 /* When it already known, that a realloc is needed or
1763 the extent does not match the needed one. */
1764 if (realloc_required
|| realloc_needed
1767 /* Check whether dst is reallocatable. */
1768 if (unlikely (!dst_reallocatable
))
1770 caf_internal_error (nonallocextentmismatch
, stat
,
1772 GFC_DESCRIPTOR_EXTENT (dst
,
1776 /* Only report an error, when the extent needs to be
1777 modified, which is not allowed. */
1778 else if (!dst_reallocatable
&& extent_mismatch
)
1780 caf_internal_error (extentoutofrange
, stat
, NULL
,
1784 realloc_needed
= true;
1786 /* Only change the extent when it does not match. This is
1787 to prevent resetting given array bounds. */
1788 if (extent_mismatch
)
1789 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1793 /* Only increase the dim counter, when in an array ref. */
1794 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1797 size
*= (index_type
)delta
;
1801 array_extent_fixed
= true;
1802 in_array_ref
= false;
1803 /* Check, if we got less dimensional refs than the rank of dst
1805 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1808 case CAF_REF_STATIC_ARRAY
:
1809 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1811 switch (riter
->u
.a
.mode
[i
])
1813 case CAF_ARR_REF_VECTOR
:
1814 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1815 #define KINDCASE(kind, type) case kind: \
1816 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1817 * riter->item_size; \
1820 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1822 KINDCASE (1, GFC_INTEGER_1
);
1823 KINDCASE (2, GFC_INTEGER_2
);
1824 KINDCASE (4, GFC_INTEGER_4
);
1825 #ifdef HAVE_GFC_INTEGER_8
1826 KINDCASE (8, GFC_INTEGER_8
);
1828 #ifdef HAVE_GFC_INTEGER_16
1829 KINDCASE (16, GFC_INTEGER_16
);
1832 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1837 case CAF_ARR_REF_FULL
:
1838 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
1840 /* The memptr stays unchanged when ref'ing the first element
1843 case CAF_ARR_REF_RANGE
:
1844 COMPUTE_NUM_ITEMS (delta
,
1845 riter
->u
.a
.dim
[i
].s
.stride
,
1846 riter
->u
.a
.dim
[i
].s
.start
,
1847 riter
->u
.a
.dim
[i
].s
.end
);
1848 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1849 * riter
->u
.a
.dim
[i
].s
.stride
1852 case CAF_ARR_REF_SINGLE
:
1854 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1855 * riter
->u
.a
.dim
[i
].s
.stride
1858 case CAF_ARR_REF_OPEN_END
:
1859 /* This and OPEN_START are mapped to a RANGE and therefore
1860 can not occur here. */
1861 case CAF_ARR_REF_OPEN_START
:
1863 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1868 /* Check the various properties of the destination array.
1869 Is an array expected and present? */
1870 if (delta
> 1 && dst_rank
== 0)
1872 /* No, an array is required, but not provided. */
1873 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1876 /* Special mode when called by __caf_sendget_by_ref (). */
1877 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1879 dst_rank
= dst_cur_dim
+ 1;
1880 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1881 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1883 /* When dst is an array. */
1886 /* Check that dst_cur_dim is valid for dst. Can be
1887 superceeded only by scalar data. */
1888 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1890 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1893 /* Do further checks, when the source is not scalar. */
1894 else if (delta
!= 1)
1896 /* Check that the extent is not scalar and we are not in
1897 an array ref for the dst side. */
1900 /* Check that this is the non-scalar extent. */
1901 if (!array_extent_fixed
)
1903 /* In an array extent now. */
1904 in_array_ref
= true;
1905 /* The dst is not reallocatable, so nothing more
1906 to do, then correct the dim counter. */
1911 caf_internal_error (doublearrayref
, stat
, NULL
,
1916 /* When the realloc is required, then no extent may have
1918 extent_mismatch
= realloc_required
1919 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1920 /* When it is already known, that a realloc is needed or
1921 the extent does not match the needed one. */
1922 if (realloc_required
|| realloc_needed
1925 /* Check whether dst is reallocatable. */
1926 if (unlikely (!dst_reallocatable
))
1928 caf_internal_error (nonallocextentmismatch
, stat
,
1930 GFC_DESCRIPTOR_EXTENT (dst
,
1934 /* Only report an error, when the extent needs to be
1935 modified, which is not allowed. */
1936 else if (!dst_reallocatable
&& extent_mismatch
)
1938 caf_internal_error (extentoutofrange
, stat
, NULL
,
1942 realloc_needed
= true;
1944 /* Only change the extent when it does not match. This is
1945 to prevent resetting given array bounds. */
1946 if (extent_mismatch
)
1947 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1950 /* Only increase the dim counter, when in an array ref. */
1951 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1954 size
*= (index_type
)delta
;
1958 array_extent_fixed
= true;
1959 in_array_ref
= false;
1960 /* Check, if we got less dimensional refs than the rank of dst
1962 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1966 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
1969 src_size
= riter
->item_size
;
1970 riter
= riter
->next
;
1972 if (size
== 0 || src_size
== 0)
1975 - size contains the number of elements to store in the destination array,
1976 - src_size gives the size in bytes of each item in the destination array.
1981 if (!array_extent_fixed
)
1984 /* Special mode when called by __caf_sendget_by_ref (). */
1985 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1987 dst_rank
= dst_cur_dim
+ 1;
1988 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1989 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1991 /* This can happen only, when the result is scalar. */
1992 for (dst_cur_dim
= 0; dst_cur_dim
< dst_rank
; ++dst_cur_dim
)
1993 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, 1, 1);
1996 GFC_DESCRIPTOR_DATA (dst
) = malloc (size
* GFC_DESCRIPTOR_SIZE (dst
));
1997 if (unlikely (GFC_DESCRIPTOR_DATA (dst
) == NULL
))
1999 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2004 /* Reset the token. */
2005 single_token
= TOKEN (token
);
2006 memptr
= single_token
->memptr
;
2007 src
= single_token
->desc
;
2008 memset(dst_index
, 0, sizeof (dst_index
));
2010 get_for_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2011 GFC_DESCRIPTOR_DATA (dst
), memptr
, dst_kind
, src_kind
, 0, 0,
2017 send_by_ref (caf_reference_t
*ref
, size_t *i
, size_t *src_index
,
2018 caf_single_token_t single_token
, gfc_descriptor_t
*dst
,
2019 gfc_descriptor_t
*src
, void *ds
, void *sr
,
2020 int dst_kind
, int src_kind
, size_t dst_dim
, size_t src_dim
,
2021 size_t num
, size_t size
, int *stat
, int dst_type
)
2023 const char vecrefunknownkind
[] = "libcaf_single::caf_send_by_ref(): "
2024 "unknown kind in vector-ref.\n";
2025 ptrdiff_t extent_dst
= 1, array_offset_dst
= 0, stride_dst
;
2026 const size_t src_rank
= GFC_DESCRIPTOR_RANK (src
);
2028 if (unlikely (ref
== NULL
))
2029 /* May be we should issue an error here, because this case should not
2033 if (ref
->next
== NULL
)
2035 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
2036 ptrdiff_t array_offset_src
= 0;;
2040 case CAF_REF_COMPONENT
:
2041 if (ref
->u
.c
.caf_token_offset
> 0)
2043 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2045 /* Create a scalar temporary array descriptor. */
2046 gfc_descriptor_t static_dst
;
2047 GFC_DESCRIPTOR_DATA (&static_dst
) = NULL
;
2048 GFC_DESCRIPTOR_DTYPE (&static_dst
)
2049 = GFC_DESCRIPTOR_DTYPE (src
);
2050 /* The component can be allocated now, because it is a
2052 _gfortran_caf_register (ref
->item_size
,
2053 CAF_REGTYPE_COARRAY_ALLOC
,
2054 ds
+ ref
->u
.c
.caf_token_offset
,
2055 &static_dst
, stat
, NULL
, 0);
2056 single_token
= *(caf_single_token_t
*)
2057 (ds
+ ref
->u
.c
.caf_token_offset
);
2058 /* In case of an error in allocation return. When stat is
2059 NULL, then register_component() terminates on error. */
2060 if (stat
!= NULL
&& *stat
)
2062 /* Publish the allocated memory. */
2063 *((void **)(ds
+ ref
->u
.c
.offset
))
2064 = GFC_DESCRIPTOR_DATA (&static_dst
);
2065 ds
= GFC_DESCRIPTOR_DATA (&static_dst
);
2066 /* Set the type from the src. */
2067 dst_type
= GFC_DESCRIPTOR_TYPE (src
);
2071 single_token
= *(caf_single_token_t
*)
2072 (ds
+ ref
->u
.c
.caf_token_offset
);
2073 dst
= single_token
->desc
;
2076 ds
= GFC_DESCRIPTOR_DATA (dst
);
2077 dst_type
= GFC_DESCRIPTOR_TYPE (dst
);
2080 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2082 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2083 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2086 copy_data (ds
+ ref
->u
.c
.offset
, sr
, dst_type
,
2087 GFC_DESCRIPTOR_TYPE (src
),
2088 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2091 case CAF_REF_STATIC_ARRAY
:
2092 /* Intentionally fall through. */
2094 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2098 for (size_t d
= 0; d
< src_rank
; ++d
)
2099 array_offset_src
+= src_index
[d
];
2100 copy_data (ds
, sr
+ array_offset_src
* src_size
,
2101 dst_type
, GFC_DESCRIPTOR_TYPE (src
), dst_kind
,
2102 src_kind
, ref
->item_size
, src_size
, num
, stat
);
2105 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2106 dst_kind
, src_kind
, ref
->item_size
, src_size
, num
,
2113 caf_runtime_error (unreachable
);
2119 case CAF_REF_COMPONENT
:
2120 if (ref
->u
.c
.caf_token_offset
> 0)
2122 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2124 /* This component refs an unallocated array. Non-arrays are
2125 caught in the if (!ref->next) above. */
2126 dst
= (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
);
2127 /* Assume that the rank and the dimensions fit for copying src
2129 GFC_DESCRIPTOR_DTYPE (dst
) = GFC_DESCRIPTOR_DTYPE (src
);
2132 for (size_t d
= 0; d
< src_rank
; ++d
)
2134 extent_dst
= GFC_DIMENSION_EXTENT (src
->dim
[d
]);
2135 GFC_DIMENSION_LBOUND (dst
->dim
[d
]) = 0;
2136 GFC_DIMENSION_UBOUND (dst
->dim
[d
]) = extent_dst
- 1;
2137 GFC_DIMENSION_STRIDE (dst
->dim
[d
]) = stride_dst
;
2138 stride_dst
*= extent_dst
;
2140 /* Null the data-pointer to make register_component allocate
2142 GFC_DESCRIPTOR_DATA (dst
) = NULL
;
2144 /* The size of the array is given by size. */
2145 _gfortran_caf_register (size
* ref
->item_size
,
2146 CAF_REGTYPE_COARRAY_ALLOC
,
2147 ds
+ ref
->u
.c
.caf_token_offset
,
2148 dst
, stat
, NULL
, 0);
2149 /* In case of an error in allocation return. When stat is
2150 NULL, then register_component() terminates on error. */
2151 if (stat
!= NULL
&& *stat
)
2154 single_token
= *(caf_single_token_t
*)(ds
+ ref
->u
.c
.caf_token_offset
);
2155 /* When a component is allocatable (caf_token_offset != 0) and not an
2156 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
2158 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
2159 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2161 ds
+= ref
->u
.c
.offset
;
2163 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2164 single_token
->desc
, src
, ds
, sr
,
2165 dst_kind
, src_kind
, 0, src_dim
, 1, size
, stat
, dst_type
);
2168 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2169 (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
), src
,
2170 ds
+ ref
->u
.c
.offset
, sr
, dst_kind
, src_kind
, 0, src_dim
,
2171 1, size
, stat
, dst_type
);
2174 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2176 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2177 (gfc_descriptor_t
*)ds
, src
, ds
, sr
, dst_kind
, src_kind
,
2178 0, src_dim
, 1, size
, stat
, dst_type
);
2181 /* Only when on the left most index switch the data pointer to
2182 the array's data pointer. And only for non-static arrays. */
2183 if (dst_dim
== 0 && ref
->type
!= CAF_REF_STATIC_ARRAY
)
2184 ds
= GFC_DESCRIPTOR_DATA (dst
);
2185 switch (ref
->u
.a
.mode
[dst_dim
])
2187 case CAF_ARR_REF_VECTOR
:
2188 array_offset_dst
= 0;
2189 src_index
[src_dim
] = 0;
2190 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2193 #define KINDCASE(kind, type) case kind: \
2194 array_offset_dst = (((index_type) \
2195 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2196 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2197 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2200 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2202 KINDCASE (1, GFC_INTEGER_1
);
2203 KINDCASE (2, GFC_INTEGER_2
);
2204 KINDCASE (4, GFC_INTEGER_4
);
2205 #ifdef HAVE_GFC_INTEGER_8
2206 KINDCASE (8, GFC_INTEGER_8
);
2208 #ifdef HAVE_GFC_INTEGER_16
2209 KINDCASE (16, GFC_INTEGER_16
);
2212 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2217 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2218 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2219 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2220 1, size
, stat
, dst_type
);
2223 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2226 case CAF_ARR_REF_FULL
:
2227 COMPUTE_NUM_ITEMS (extent_dst
,
2228 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2229 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2230 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2231 array_offset_dst
= 0;
2232 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2233 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2234 src_index
[src_dim
] = 0;
2235 for (index_type idx
= 0; idx
< extent_dst
;
2236 ++idx
, array_offset_dst
+= stride_dst
)
2238 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2239 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2240 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2241 1, size
, stat
, dst_type
);
2244 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2247 case CAF_ARR_REF_RANGE
:
2248 COMPUTE_NUM_ITEMS (extent_dst
,
2249 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2250 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2251 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2252 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2253 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2254 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2255 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2256 src_index
[src_dim
] = 0;
2257 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2259 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2260 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2261 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2262 1, size
, stat
, dst_type
);
2265 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2266 array_offset_dst
+= stride_dst
;
2269 case CAF_ARR_REF_SINGLE
:
2270 array_offset_dst
= (ref
->u
.a
.dim
[dst_dim
].s
.start
2271 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]))
2272 * GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
2273 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
, ds
2274 + array_offset_dst
* ref
->item_size
, sr
,
2275 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2276 size
, stat
, dst_type
);
2278 case CAF_ARR_REF_OPEN_END
:
2279 COMPUTE_NUM_ITEMS (extent_dst
,
2280 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2281 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2282 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2283 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2284 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2285 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2286 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2287 src_index
[src_dim
] = 0;
2288 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2290 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2291 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2292 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2293 1, size
, stat
, dst_type
);
2296 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2297 array_offset_dst
+= stride_dst
;
2300 case CAF_ARR_REF_OPEN_START
:
2301 COMPUTE_NUM_ITEMS (extent_dst
,
2302 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2303 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2304 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2305 array_offset_dst
= 0;
2306 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2307 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2308 src_index
[src_dim
] = 0;
2309 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2311 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2312 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2313 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2314 1, size
, stat
, dst_type
);
2317 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2318 array_offset_dst
+= stride_dst
;
2322 caf_runtime_error (unreachable
);
2325 case CAF_REF_STATIC_ARRAY
:
2326 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2328 send_by_ref (ref
->next
, i
, src_index
, single_token
, NULL
,
2329 src
, ds
, sr
, dst_kind
, src_kind
,
2330 0, src_dim
, 1, size
, stat
, dst_type
);
2333 switch (ref
->u
.a
.mode
[dst_dim
])
2335 case CAF_ARR_REF_VECTOR
:
2336 array_offset_dst
= 0;
2337 src_index
[src_dim
] = 0;
2338 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2341 #define KINDCASE(kind, type) case kind: \
2342 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2345 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2347 KINDCASE (1, GFC_INTEGER_1
);
2348 KINDCASE (2, GFC_INTEGER_2
);
2349 KINDCASE (4, GFC_INTEGER_4
);
2350 #ifdef HAVE_GFC_INTEGER_8
2351 KINDCASE (8, GFC_INTEGER_8
);
2353 #ifdef HAVE_GFC_INTEGER_16
2354 KINDCASE (16, GFC_INTEGER_16
);
2357 caf_runtime_error (unreachable
);
2362 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2363 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2364 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2365 1, size
, stat
, dst_type
);
2367 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2370 case CAF_ARR_REF_FULL
:
2371 src_index
[src_dim
] = 0;
2372 for (array_offset_dst
= 0 ;
2373 array_offset_dst
<= ref
->u
.a
.dim
[dst_dim
].s
.end
;
2374 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
)
2376 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2377 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2378 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2379 1, size
, stat
, dst_type
);
2382 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2385 case CAF_ARR_REF_RANGE
:
2386 COMPUTE_NUM_ITEMS (extent_dst
,
2387 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2388 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2389 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2390 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2391 src_index
[src_dim
] = 0;
2392 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2394 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2395 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2396 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2397 1, size
, stat
, dst_type
);
2400 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2401 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2404 case CAF_ARR_REF_SINGLE
:
2405 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2406 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2407 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2408 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2409 size
, stat
, dst_type
);
2411 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
2412 case CAF_ARR_REF_OPEN_END
:
2413 case CAF_ARR_REF_OPEN_START
:
2415 caf_runtime_error (unreachable
);
2419 caf_runtime_error (unreachable
);
2425 _gfortran_caf_send_by_ref (caf_token_t token
,
2426 int image_index
__attribute__ ((unused
)),
2427 gfc_descriptor_t
*src
, caf_reference_t
*refs
,
2428 int dst_kind
, int src_kind
,
2429 bool may_require_tmp
__attribute__ ((unused
)),
2430 bool dst_reallocatable
, int *stat
, int dst_type
)
2432 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
2433 "unknown kind in vector-ref.\n";
2434 const char unknownreftype
[] = "libcaf_single::caf_send_by_ref(): "
2435 "unknown reference type.\n";
2436 const char unknownarrreftype
[] = "libcaf_single::caf_send_by_ref(): "
2437 "unknown array reference type.\n";
2438 const char rankoutofrange
[] = "libcaf_single::caf_send_by_ref(): "
2439 "rank out of range.\n";
2440 const char realloconinnerref
[] = "libcaf_single::caf_send_by_ref(): "
2441 "reallocation of array followed by component ref not allowed.\n";
2442 const char cannotallocdst
[] = "libcaf_single::caf_send_by_ref(): "
2443 "can not allocate memory.\n";
2444 const char nonallocextentmismatch
[] = "libcaf_single::caf_send_by_ref(): "
2445 "extent of non-allocatable array mismatch.\n";
2446 const char innercompref
[] = "libcaf_single::caf_send_by_ref(): "
2447 "inner unallocated component detected.\n";
2449 size_t dst_index
[GFC_MAX_DIMENSIONS
];
2450 int src_rank
= GFC_DESCRIPTOR_RANK (src
);
2451 int src_cur_dim
= 0;
2452 size_t src_size
= 0;
2453 caf_single_token_t single_token
= TOKEN (token
);
2454 void *memptr
= single_token
->memptr
;
2455 gfc_descriptor_t
*dst
= single_token
->desc
;
2456 caf_reference_t
*riter
= refs
;
2458 bool extent_mismatch
;
2459 /* Note that the component is not allocated yet. */
2460 index_type new_component_idx
= -1;
2465 /* Compute the size of the result. In the beginning size just counts the
2466 number of elements. */
2470 switch (riter
->type
)
2472 case CAF_REF_COMPONENT
:
2473 if (unlikely (new_component_idx
!= -1))
2475 /* Allocating a component in the middle of a component ref is not
2476 support. We don't know the type to allocate. */
2477 caf_internal_error (innercompref
, stat
, NULL
, 0);
2480 if (riter
->u
.c
.caf_token_offset
> 0)
2482 /* Check whether the allocatable component is zero, then no
2483 token is present, too. The token's pointer is not cleared
2484 when the structure is initialized. */
2485 if (*(void**)(memptr
+ riter
->u
.c
.offset
) == NULL
)
2487 /* This component is not yet allocated. Check that it is
2488 allocatable here. */
2489 if (!dst_reallocatable
)
2491 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2494 single_token
= NULL
;
2499 single_token
= *(caf_single_token_t
*)
2500 (memptr
+ riter
->u
.c
.caf_token_offset
);
2501 memptr
+= riter
->u
.c
.offset
;
2502 dst
= single_token
->desc
;
2506 /* Regular component. */
2507 memptr
+= riter
->u
.c
.offset
;
2508 dst
= (gfc_descriptor_t
*)memptr
;
2513 memptr
= GFC_DESCRIPTOR_DATA (dst
);
2516 /* When the dst array needs to be allocated, then look at the
2517 extent of the source array in the dimension dst_cur_dim. */
2518 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2520 switch (riter
->u
.a
.mode
[i
])
2522 case CAF_ARR_REF_VECTOR
:
2523 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2524 #define KINDCASE(kind, type) case kind: \
2525 memptr += (((index_type) \
2526 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2527 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2528 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2529 * riter->item_size; \
2532 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2534 KINDCASE (1, GFC_INTEGER_1
);
2535 KINDCASE (2, GFC_INTEGER_2
);
2536 KINDCASE (4, GFC_INTEGER_4
);
2537 #ifdef HAVE_GFC_INTEGER_8
2538 KINDCASE (8, GFC_INTEGER_8
);
2540 #ifdef HAVE_GFC_INTEGER_16
2541 KINDCASE (16, GFC_INTEGER_16
);
2544 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2549 case CAF_ARR_REF_FULL
:
2551 COMPUTE_NUM_ITEMS (delta
,
2552 riter
->u
.a
.dim
[i
].s
.stride
,
2553 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2554 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2556 COMPUTE_NUM_ITEMS (delta
,
2557 riter
->u
.a
.dim
[i
].s
.stride
,
2558 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2559 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2561 case CAF_ARR_REF_RANGE
:
2562 COMPUTE_NUM_ITEMS (delta
,
2563 riter
->u
.a
.dim
[i
].s
.stride
,
2564 riter
->u
.a
.dim
[i
].s
.start
,
2565 riter
->u
.a
.dim
[i
].s
.end
);
2566 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2567 - dst
->dim
[i
].lower_bound
)
2568 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2571 case CAF_ARR_REF_SINGLE
:
2573 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2574 - dst
->dim
[i
].lower_bound
)
2575 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2578 case CAF_ARR_REF_OPEN_END
:
2580 COMPUTE_NUM_ITEMS (delta
,
2581 riter
->u
.a
.dim
[i
].s
.stride
,
2582 riter
->u
.a
.dim
[i
].s
.start
,
2583 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2585 COMPUTE_NUM_ITEMS (delta
,
2586 riter
->u
.a
.dim
[i
].s
.stride
,
2587 riter
->u
.a
.dim
[i
].s
.start
,
2588 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2589 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2590 - dst
->dim
[i
].lower_bound
)
2591 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2594 case CAF_ARR_REF_OPEN_START
:
2596 COMPUTE_NUM_ITEMS (delta
,
2597 riter
->u
.a
.dim
[i
].s
.stride
,
2598 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2599 riter
->u
.a
.dim
[i
].s
.end
);
2601 COMPUTE_NUM_ITEMS (delta
,
2602 riter
->u
.a
.dim
[i
].s
.stride
,
2603 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2604 riter
->u
.a
.dim
[i
].s
.end
);
2605 /* The memptr stays unchanged when ref'ing the first element
2609 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2615 /* Check the various properties of the source array.
2616 When src is an array. */
2617 if (delta
> 1 && src_rank
> 0)
2619 /* Check that src_cur_dim is valid for src. Can be
2620 superceeded only by scalar data. */
2621 if (src_cur_dim
>= src_rank
)
2623 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2626 /* Do further checks, when the source is not scalar. */
2629 /* When the realloc is required, then no extent may have
2631 extent_mismatch
= memptr
== NULL
2633 && GFC_DESCRIPTOR_EXTENT (dst
, src_cur_dim
)
2635 /* When it already known, that a realloc is needed or
2636 the extent does not match the needed one. */
2637 if (extent_mismatch
)
2639 /* Check whether dst is reallocatable. */
2640 if (unlikely (!dst_reallocatable
))
2642 caf_internal_error (nonallocextentmismatch
, stat
,
2644 GFC_DESCRIPTOR_EXTENT (dst
,
2648 /* Report error on allocatable but missing inner
2650 else if (riter
->next
!= NULL
)
2652 caf_internal_error (realloconinnerref
, stat
, NULL
,
2657 /* Only change the extent when it does not match. This is
2658 to prevent resetting given array bounds. */
2659 if (extent_mismatch
)
2660 GFC_DIMENSION_SET (dst
->dim
[src_cur_dim
], 1, delta
,
2663 /* Increase the dim-counter of the src only when the extent
2665 if (src_cur_dim
< src_rank
2666 && GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
) == delta
)
2669 size
*= (index_type
)delta
;
2672 case CAF_REF_STATIC_ARRAY
:
2673 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2675 switch (riter
->u
.a
.mode
[i
])
2677 case CAF_ARR_REF_VECTOR
:
2678 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2679 #define KINDCASE(kind, type) case kind: \
2680 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2681 * riter->item_size; \
2684 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2686 KINDCASE (1, GFC_INTEGER_1
);
2687 KINDCASE (2, GFC_INTEGER_2
);
2688 KINDCASE (4, GFC_INTEGER_4
);
2689 #ifdef HAVE_GFC_INTEGER_8
2690 KINDCASE (8, GFC_INTEGER_8
);
2692 #ifdef HAVE_GFC_INTEGER_16
2693 KINDCASE (16, GFC_INTEGER_16
);
2696 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2701 case CAF_ARR_REF_FULL
:
2702 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
2704 /* The memptr stays unchanged when ref'ing the first element
2707 case CAF_ARR_REF_RANGE
:
2708 COMPUTE_NUM_ITEMS (delta
,
2709 riter
->u
.a
.dim
[i
].s
.stride
,
2710 riter
->u
.a
.dim
[i
].s
.start
,
2711 riter
->u
.a
.dim
[i
].s
.end
);
2712 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2713 * riter
->u
.a
.dim
[i
].s
.stride
2716 case CAF_ARR_REF_SINGLE
:
2718 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2719 * riter
->u
.a
.dim
[i
].s
.stride
2722 case CAF_ARR_REF_OPEN_END
:
2723 /* This and OPEN_START are mapped to a RANGE and therefore
2724 can not occur here. */
2725 case CAF_ARR_REF_OPEN_START
:
2727 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2732 /* Check the various properties of the source array.
2733 Only when the source array is not scalar examine its
2735 if (delta
> 1 && src_rank
> 0)
2737 /* Check that src_cur_dim is valid for src. Can be
2738 superceeded only by scalar data. */
2739 if (src_cur_dim
>= src_rank
)
2741 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2746 /* We will not be able to realloc the dst, because that's
2747 a fixed size array. */
2748 extent_mismatch
= GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
)
2750 /* When the extent does not match the needed one we can
2752 if (extent_mismatch
)
2754 caf_internal_error (nonallocextentmismatch
, stat
,
2756 GFC_DESCRIPTOR_EXTENT (src
,
2763 size
*= (index_type
)delta
;
2767 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
2770 src_size
= riter
->item_size
;
2771 riter
= riter
->next
;
2773 if (size
== 0 || src_size
== 0)
2776 - size contains the number of elements to store in the destination array,
2777 - src_size gives the size in bytes of each item in the destination array.
2780 /* Reset the token. */
2781 single_token
= TOKEN (token
);
2782 memptr
= single_token
->memptr
;
2783 dst
= single_token
->desc
;
2784 memset (dst_index
, 0, sizeof (dst_index
));
2786 send_by_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2787 memptr
, GFC_DESCRIPTOR_DATA (src
), dst_kind
, src_kind
, 0, 0,
2788 1, size
, stat
, dst_type
);
2794 _gfortran_caf_sendget_by_ref (caf_token_t dst_token
, int dst_image_index
,
2795 caf_reference_t
*dst_refs
, caf_token_t src_token
,
2796 int src_image_index
,
2797 caf_reference_t
*src_refs
, int dst_kind
,
2798 int src_kind
, bool may_require_tmp
, int *dst_stat
,
2799 int *src_stat
, int dst_type
, int src_type
)
2801 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS
, void) temp
;
2802 GFC_DESCRIPTOR_DATA (&temp
) = NULL
;
2803 GFC_DESCRIPTOR_RANK (&temp
) = -1;
2804 GFC_DESCRIPTOR_TYPE (&temp
) = dst_type
;
2806 _gfortran_caf_get_by_ref (src_token
, src_image_index
, &temp
, src_refs
,
2807 dst_kind
, src_kind
, may_require_tmp
, true,
2808 src_stat
, src_type
);
2810 if (src_stat
&& *src_stat
!= 0)
2813 _gfortran_caf_send_by_ref (dst_token
, dst_image_index
, &temp
, dst_refs
,
2814 dst_kind
, dst_kind
, may_require_tmp
, true,
2815 dst_stat
, dst_type
);
2816 if (GFC_DESCRIPTOR_DATA (&temp
))
2817 free (GFC_DESCRIPTOR_DATA (&temp
));
2822 _gfortran_caf_atomic_define (caf_token_t token
, size_t offset
,
2823 int image_index
__attribute__ ((unused
)),
2824 void *value
, int *stat
,
2825 int type
__attribute__ ((unused
)), int kind
)
2829 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2831 __atomic_store (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2838 _gfortran_caf_atomic_ref (caf_token_t token
, size_t offset
,
2839 int image_index
__attribute__ ((unused
)),
2840 void *value
, int *stat
,
2841 int type
__attribute__ ((unused
)), int kind
)
2845 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2847 __atomic_load (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2855 _gfortran_caf_atomic_cas (caf_token_t token
, size_t offset
,
2856 int image_index
__attribute__ ((unused
)),
2857 void *old
, void *compare
, void *new_val
, int *stat
,
2858 int type
__attribute__ ((unused
)), int kind
)
2862 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2864 *(uint32_t *) old
= *(uint32_t *) compare
;
2865 (void) __atomic_compare_exchange_n (atom
, (uint32_t *) old
,
2866 *(uint32_t *) new_val
, false,
2867 __ATOMIC_RELAXED
, __ATOMIC_RELAXED
);
2874 _gfortran_caf_atomic_op (int op
, caf_token_t token
, size_t offset
,
2875 int image_index
__attribute__ ((unused
)),
2876 void *value
, void *old
, int *stat
,
2877 int type
__attribute__ ((unused
)), int kind
)
2882 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2886 case GFC_CAF_ATOMIC_ADD
:
2887 res
= __atomic_fetch_add (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2889 case GFC_CAF_ATOMIC_AND
:
2890 res
= __atomic_fetch_and (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2892 case GFC_CAF_ATOMIC_OR
:
2893 res
= __atomic_fetch_or (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2895 case GFC_CAF_ATOMIC_XOR
:
2896 res
= __atomic_fetch_xor (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2899 __builtin_unreachable();
2903 *(uint32_t *) old
= res
;
2910 _gfortran_caf_event_post (caf_token_t token
, size_t index
,
2911 int image_index
__attribute__ ((unused
)),
2912 int *stat
, char *errmsg
__attribute__ ((unused
)),
2913 int errmsg_len
__attribute__ ((unused
)))
2916 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2917 * sizeof (uint32_t));
2918 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2925 _gfortran_caf_event_wait (caf_token_t token
, size_t index
,
2926 int until_count
, int *stat
,
2927 char *errmsg
__attribute__ ((unused
)),
2928 int errmsg_len
__attribute__ ((unused
)))
2930 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2931 * sizeof (uint32_t));
2932 uint32_t value
= (uint32_t)-until_count
;
2933 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2940 _gfortran_caf_event_query (caf_token_t token
, size_t index
,
2941 int image_index
__attribute__ ((unused
)),
2942 int *count
, int *stat
)
2944 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2945 * sizeof (uint32_t));
2946 __atomic_load (event
, (uint32_t *) count
, __ATOMIC_RELAXED
);
2953 _gfortran_caf_lock (caf_token_t token
, size_t index
,
2954 int image_index
__attribute__ ((unused
)),
2955 int *aquired_lock
, int *stat
, char *errmsg
, int errmsg_len
)
2957 const char *msg
= "Already locked";
2958 bool *lock
= &((bool *) MEMTOK (token
))[index
];
2964 *aquired_lock
= (int) true;
2972 *aquired_lock
= (int) false;
2984 int len
= ((int) sizeof (msg
) > errmsg_len
) ? errmsg_len
2985 : (int) sizeof (msg
);
2986 memcpy (errmsg
, msg
, len
);
2987 if (errmsg_len
> len
)
2988 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
2992 _gfortran_caf_error_stop_str (msg
, (int32_t) strlen (msg
));
2997 _gfortran_caf_unlock (caf_token_t token
, size_t index
,
2998 int image_index
__attribute__ ((unused
)),
2999 int *stat
, char *errmsg
, int errmsg_len
)
3001 const char *msg
= "Variable is not locked";
3002 bool *lock
= &((bool *) MEMTOK (token
))[index
];
3017 int len
= ((int) sizeof (msg
) > errmsg_len
) ? errmsg_len
3018 : (int) sizeof (msg
);
3019 memcpy (errmsg
, msg
, len
);
3020 if (errmsg_len
> len
)
3021 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
3025 _gfortran_caf_error_stop_str (msg
, (int32_t) strlen (msg
));
3029 _gfortran_caf_is_present (caf_token_t token
,
3030 int image_index
__attribute__ ((unused
)),
3031 caf_reference_t
*refs
)
3033 const char arraddressingnotallowed
[] = "libcaf_single::caf_is_present(): "
3034 "only scalar indexes allowed.\n";
3035 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
3036 "unknown reference type.\n";
3037 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
3038 "unknown array reference type.\n";
3040 caf_single_token_t single_token
= TOKEN (token
);
3041 void *memptr
= single_token
->memptr
;
3042 gfc_descriptor_t
*src
= single_token
->desc
;
3043 caf_reference_t
*riter
= refs
;
3047 switch (riter
->type
)
3049 case CAF_REF_COMPONENT
:
3050 if (riter
->u
.c
.caf_token_offset
)
3052 single_token
= *(caf_single_token_t
*)
3053 (memptr
+ riter
->u
.c
.caf_token_offset
);
3054 memptr
= single_token
->memptr
;
3055 src
= single_token
->desc
;
3059 memptr
+= riter
->u
.c
.offset
;
3060 src
= (gfc_descriptor_t
*)memptr
;
3064 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3066 switch (riter
->u
.a
.mode
[i
])
3068 case CAF_ARR_REF_SINGLE
:
3069 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
3070 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
3071 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
3074 case CAF_ARR_REF_FULL
:
3075 /* A full array ref is allowed on the last reference only. */
3076 if (riter
->next
== NULL
)
3078 /* else fall through reporting an error. */
3080 case CAF_ARR_REF_VECTOR
:
3081 case CAF_ARR_REF_RANGE
:
3082 case CAF_ARR_REF_OPEN_END
:
3083 case CAF_ARR_REF_OPEN_START
:
3084 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3087 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3092 case CAF_REF_STATIC_ARRAY
:
3093 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3095 switch (riter
->u
.a
.mode
[i
])
3097 case CAF_ARR_REF_SINGLE
:
3098 memptr
+= riter
->u
.a
.dim
[i
].s
.start
3099 * riter
->u
.a
.dim
[i
].s
.stride
3102 case CAF_ARR_REF_FULL
:
3103 /* A full array ref is allowed on the last reference only. */
3104 if (riter
->next
== NULL
)
3106 /* else fall through reporting an error. */
3108 case CAF_ARR_REF_VECTOR
:
3109 case CAF_ARR_REF_RANGE
:
3110 case CAF_ARR_REF_OPEN_END
:
3111 case CAF_ARR_REF_OPEN_START
:
3112 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3115 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3121 caf_internal_error (unknownreftype
, 0, NULL
, 0);
3124 riter
= riter
->next
;
3126 return memptr
!= NULL
;