1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2022 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
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. */
34 /* Define GFC_CAF_CHECK to enable run-time checking. */
35 /* #define GFC_CAF_CHECK 1 */
37 struct caf_single_token
39 /* The pointer to the memory registered. For arrays this is the data member
40 in the descriptor. For components it's the pure data pointer. */
42 /* The descriptor when this token is associated to an allocatable array. */
43 gfc_descriptor_t
*desc
;
44 /* Set when the caf lib has allocated the memory in memptr and is responsible
45 for freeing it on deregister. */
48 typedef struct caf_single_token
*caf_single_token_t
;
50 #define TOKEN(X) ((caf_single_token_t) (X))
51 #define MEMTOK(X) ((caf_single_token_t) (X))->memptr
53 /* Single-image implementation of the CAF library.
54 Note: For performance reasons -fcoarry=single should be used
55 rather than this library. */
57 /* Global variables. */
58 caf_static_t
*caf_static_list
= NULL
;
60 /* Keep in sync with mpi.c. */
62 caf_runtime_error (const char *message
, ...)
65 fprintf (stderr
, "Fortran runtime error: ");
66 va_start (ap
, message
);
67 vfprintf (stderr
, message
, ap
);
69 fprintf (stderr
, "\n");
71 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
75 /* Error handling is similar everytime. */
77 caf_internal_error (const char *msg
, int *stat
, char *errmsg
,
78 size_t errmsg_len
, ...)
81 va_start (args
, errmsg_len
);
87 int len
= snprintf (errmsg
, errmsg_len
, msg
, args
);
88 if (len
>= 0 && errmsg_len
> (size_t) len
)
89 memset (&errmsg
[len
], ' ', errmsg_len
- len
);
95 caf_runtime_error (msg
, args
);
101 _gfortran_caf_init (int *argc
__attribute__ ((unused
)),
102 char ***argv
__attribute__ ((unused
)))
108 _gfortran_caf_finalize (void)
110 while (caf_static_list
!= NULL
)
112 caf_static_t
*tmp
= caf_static_list
->prev
;
113 free (caf_static_list
->token
);
114 free (caf_static_list
);
115 caf_static_list
= tmp
;
121 _gfortran_caf_this_image (int distance
__attribute__ ((unused
)))
128 _gfortran_caf_num_images (int distance
__attribute__ ((unused
)),
129 int failed
__attribute__ ((unused
)))
136 _gfortran_caf_register (size_t size
, caf_register_t type
, caf_token_t
*token
,
137 gfc_descriptor_t
*data
, int *stat
, char *errmsg
,
140 const char alloc_fail_msg
[] = "Failed to allocate coarray";
142 caf_single_token_t single_token
;
144 if (type
== CAF_REGTYPE_LOCK_STATIC
|| type
== CAF_REGTYPE_LOCK_ALLOC
145 || type
== CAF_REGTYPE_CRITICAL
)
146 local
= calloc (size
, sizeof (bool));
147 else if (type
== CAF_REGTYPE_EVENT_STATIC
|| type
== CAF_REGTYPE_EVENT_ALLOC
)
148 /* In the event_(wait|post) function the counter for events is a uint32,
149 so better allocate enough memory here. */
150 local
= calloc (size
, sizeof (uint32_t));
151 else if (type
== CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
)
154 local
= malloc (size
);
156 if (type
!= CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
)
157 *token
= malloc (sizeof (struct caf_single_token
));
159 if (unlikely (*token
== NULL
161 && type
!= CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
)))
163 /* Freeing the memory conditionally seems pointless, but
164 caf_internal_error () may return, when a stat is given and then the
165 memory may be lost. */
170 caf_internal_error (alloc_fail_msg
, stat
, errmsg
, errmsg_len
);
174 single_token
= TOKEN (*token
);
175 single_token
->memptr
= local
;
176 single_token
->owning_memory
= type
!= CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
;
177 single_token
->desc
= GFC_DESCRIPTOR_RANK (data
) > 0 ? data
: NULL
;
183 if (type
== CAF_REGTYPE_COARRAY_STATIC
|| type
== CAF_REGTYPE_LOCK_STATIC
184 || type
== CAF_REGTYPE_CRITICAL
|| type
== CAF_REGTYPE_EVENT_STATIC
185 || type
== CAF_REGTYPE_EVENT_ALLOC
)
187 caf_static_t
*tmp
= malloc (sizeof (caf_static_t
));
188 tmp
->prev
= caf_static_list
;
190 caf_static_list
= tmp
;
192 GFC_DESCRIPTOR_DATA (data
) = local
;
197 _gfortran_caf_deregister (caf_token_t
*token
, caf_deregister_t type
, int *stat
,
198 char *errmsg
__attribute__ ((unused
)),
199 size_t errmsg_len
__attribute__ ((unused
)))
201 caf_single_token_t single_token
= TOKEN (*token
);
203 if (single_token
->owning_memory
&& single_token
->memptr
)
204 free (single_token
->memptr
);
206 if (type
!= CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY
)
208 free (TOKEN (*token
));
213 single_token
->memptr
= NULL
;
214 single_token
->owning_memory
= false;
223 _gfortran_caf_sync_all (int *stat
,
224 char *errmsg
__attribute__ ((unused
)),
225 size_t errmsg_len
__attribute__ ((unused
)))
227 __asm__
__volatile__ ("":::"memory");
234 _gfortran_caf_sync_memory (int *stat
,
235 char *errmsg
__attribute__ ((unused
)),
236 size_t errmsg_len
__attribute__ ((unused
)))
238 __asm__
__volatile__ ("":::"memory");
245 _gfortran_caf_sync_images (int count
__attribute__ ((unused
)),
246 int images
[] __attribute__ ((unused
)),
248 char *errmsg
__attribute__ ((unused
)),
249 size_t errmsg_len
__attribute__ ((unused
)))
254 for (i
= 0; i
< count
; i
++)
257 fprintf (stderr
, "COARRAY ERROR: Invalid image index %d to SYNC "
258 "IMAGES", images
[i
]);
263 __asm__
__volatile__ ("":::"memory");
270 _gfortran_caf_stop_numeric(int stop_code
, bool quiet
)
273 fprintf (stderr
, "STOP %d\n", stop_code
);
279 _gfortran_caf_stop_str(const char *string
, size_t len
, bool quiet
)
283 fputs ("STOP ", stderr
);
285 fputc (*(string
++), stderr
);
286 fputs ("\n", stderr
);
293 _gfortran_caf_error_stop_str (const char *string
, size_t len
, bool quiet
)
297 fputs ("ERROR STOP ", stderr
);
299 fputc (*(string
++), stderr
);
300 fputs ("\n", stderr
);
306 /* Reported that the program terminated because of a fail image issued.
307 Because this is a single image library, nothing else than aborting the whole
308 program can be done. */
310 void _gfortran_caf_fail_image (void)
312 fputs ("IMAGE FAILED!\n", stderr
);
317 /* Get the status of image IMAGE. Because being the single image library all
318 other images are reported to be stopped. */
320 int _gfortran_caf_image_status (int image
,
321 caf_team_t
* team
__attribute__ ((unused
)))
326 return CAF_STAT_STOPPED_IMAGE
;
330 /* Single image library. There cannot be any failed images with only one
334 _gfortran_caf_failed_images (gfc_descriptor_t
*array
,
335 caf_team_t
* team
__attribute__ ((unused
)),
338 int local_kind
= kind
!= NULL
? *kind
: 4;
340 array
->base_addr
= NULL
;
341 array
->dtype
.type
= BT_INTEGER
;
342 array
->dtype
.elem_len
= local_kind
;
343 /* Setting lower_bound higher then upper_bound is what the compiler does to
344 indicate an empty array. */
345 array
->dim
[0].lower_bound
= 0;
346 array
->dim
[0]._ubound
= -1;
347 array
->dim
[0]._stride
= 1;
352 /* With only one image available no other images can be stopped. Therefore
353 return an empty array. */
356 _gfortran_caf_stopped_images (gfc_descriptor_t
*array
,
357 caf_team_t
* team
__attribute__ ((unused
)),
360 int local_kind
= kind
!= NULL
? *kind
: 4;
362 array
->base_addr
= NULL
;
363 array
->dtype
.type
= BT_INTEGER
;
364 array
->dtype
.elem_len
= local_kind
;
365 /* Setting lower_bound higher then upper_bound is what the compiler does to
366 indicate an empty array. */
367 array
->dim
[0].lower_bound
= 0;
368 array
->dim
[0]._ubound
= -1;
369 array
->dim
[0]._stride
= 1;
375 _gfortran_caf_error_stop (int error
, bool quiet
)
378 fprintf (stderr
, "ERROR STOP %d\n", error
);
384 _gfortran_caf_co_broadcast (gfc_descriptor_t
*a
__attribute__ ((unused
)),
385 int source_image
__attribute__ ((unused
)),
386 int *stat
, char *errmsg
__attribute__ ((unused
)),
387 size_t errmsg_len
__attribute__ ((unused
)))
394 _gfortran_caf_co_sum (gfc_descriptor_t
*a
__attribute__ ((unused
)),
395 int result_image
__attribute__ ((unused
)),
396 int *stat
, char *errmsg
__attribute__ ((unused
)),
397 size_t errmsg_len
__attribute__ ((unused
)))
404 _gfortran_caf_co_min (gfc_descriptor_t
*a
__attribute__ ((unused
)),
405 int result_image
__attribute__ ((unused
)),
406 int *stat
, char *errmsg
__attribute__ ((unused
)),
407 int a_len
__attribute__ ((unused
)),
408 size_t errmsg_len
__attribute__ ((unused
)))
415 _gfortran_caf_co_max (gfc_descriptor_t
*a
__attribute__ ((unused
)),
416 int result_image
__attribute__ ((unused
)),
417 int *stat
, char *errmsg
__attribute__ ((unused
)),
418 int a_len
__attribute__ ((unused
)),
419 size_t errmsg_len
__attribute__ ((unused
)))
427 _gfortran_caf_co_reduce (gfc_descriptor_t
*a
__attribute__ ((unused
)),
428 void * (*opr
) (void *, void *)
429 __attribute__ ((unused
)),
430 int opr_flags
__attribute__ ((unused
)),
431 int result_image
__attribute__ ((unused
)),
432 int *stat
, char *errmsg
__attribute__ ((unused
)),
433 int a_len
__attribute__ ((unused
)),
434 size_t errmsg_len
__attribute__ ((unused
)))
442 assign_char4_from_char1 (size_t dst_size
, size_t src_size
, uint32_t *dst
,
446 n
= dst_size
/4 > src_size
? src_size
: dst_size
/4;
447 for (i
= 0; i
< n
; ++i
)
448 dst
[i
] = (int32_t) src
[i
];
449 for (; i
< dst_size
/4; ++i
)
450 dst
[i
] = (int32_t) ' ';
455 assign_char1_from_char4 (size_t dst_size
, size_t src_size
, unsigned char *dst
,
459 n
= dst_size
> src_size
/4 ? src_size
/4 : dst_size
;
460 for (i
= 0; i
< n
; ++i
)
461 dst
[i
] = src
[i
] > UINT8_MAX
? (unsigned char) '?' : (unsigned char) src
[i
];
463 memset (&dst
[n
], ' ', dst_size
- n
);
468 convert_type (void *dst
, int dst_type
, int dst_kind
, void *src
, int src_type
,
469 int src_kind
, int *stat
)
471 #ifdef HAVE_GFC_INTEGER_16
472 typedef __int128 int128t
;
474 typedef int64_t int128t
;
477 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
478 typedef long double real128t
;
479 typedef _Complex
long double complex128t
;
480 #elif defined(HAVE_GFC_REAL_16)
481 typedef _Float128 real128t
;
482 typedef _Complex _Float128 complex128t
;
483 #elif defined(HAVE_GFC_REAL_10)
484 typedef long double real128t
;
485 typedef _Complex
long double complex128t
;
487 typedef double real128t
;
488 typedef _Complex
double complex128t
;
492 real128t real_val
= 0;
493 complex128t cmpx_val
= 0;
499 int_val
= *(int8_t*) src
;
500 else if (src_kind
== 2)
501 int_val
= *(int16_t*) src
;
502 else if (src_kind
== 4)
503 int_val
= *(int32_t*) src
;
504 else if (src_kind
== 8)
505 int_val
= *(int64_t*) src
;
506 #ifdef HAVE_GFC_INTEGER_16
507 else if (src_kind
== 16)
508 int_val
= *(int128t
*) src
;
515 real_val
= *(float*) src
;
516 else if (src_kind
== 8)
517 real_val
= *(double*) src
;
518 #ifdef HAVE_GFC_REAL_10
519 else if (src_kind
== 10)
520 real_val
= *(long double*) src
;
522 #ifdef HAVE_GFC_REAL_16
523 else if (src_kind
== 16)
524 real_val
= *(real128t
*) src
;
531 cmpx_val
= *(_Complex
float*) src
;
532 else if (src_kind
== 8)
533 cmpx_val
= *(_Complex
double*) src
;
534 #ifdef HAVE_GFC_REAL_10
535 else if (src_kind
== 10)
536 cmpx_val
= *(_Complex
long double*) src
;
538 #ifdef HAVE_GFC_REAL_16
539 else if (src_kind
== 16)
540 cmpx_val
= *(complex128t
*) src
;
552 if (src_type
== BT_INTEGER
)
555 *(int8_t*) dst
= (int8_t) int_val
;
556 else if (dst_kind
== 2)
557 *(int16_t*) dst
= (int16_t) int_val
;
558 else if (dst_kind
== 4)
559 *(int32_t*) dst
= (int32_t) int_val
;
560 else if (dst_kind
== 8)
561 *(int64_t*) dst
= (int64_t) int_val
;
562 #ifdef HAVE_GFC_INTEGER_16
563 else if (dst_kind
== 16)
564 *(int128t
*) dst
= (int128t
) int_val
;
569 else if (src_type
== BT_REAL
)
572 *(int8_t*) dst
= (int8_t) real_val
;
573 else if (dst_kind
== 2)
574 *(int16_t*) dst
= (int16_t) real_val
;
575 else if (dst_kind
== 4)
576 *(int32_t*) dst
= (int32_t) real_val
;
577 else if (dst_kind
== 8)
578 *(int64_t*) dst
= (int64_t) real_val
;
579 #ifdef HAVE_GFC_INTEGER_16
580 else if (dst_kind
== 16)
581 *(int128t
*) dst
= (int128t
) real_val
;
586 else if (src_type
== BT_COMPLEX
)
589 *(int8_t*) dst
= (int8_t) cmpx_val
;
590 else if (dst_kind
== 2)
591 *(int16_t*) dst
= (int16_t) cmpx_val
;
592 else if (dst_kind
== 4)
593 *(int32_t*) dst
= (int32_t) cmpx_val
;
594 else if (dst_kind
== 8)
595 *(int64_t*) dst
= (int64_t) cmpx_val
;
596 #ifdef HAVE_GFC_INTEGER_16
597 else if (dst_kind
== 16)
598 *(int128t
*) dst
= (int128t
) cmpx_val
;
607 if (src_type
== BT_INTEGER
)
610 *(float*) dst
= (float) int_val
;
611 else if (dst_kind
== 8)
612 *(double*) dst
= (double) int_val
;
613 #ifdef HAVE_GFC_REAL_10
614 else if (dst_kind
== 10)
615 *(long double*) dst
= (long double) int_val
;
617 #ifdef HAVE_GFC_REAL_16
618 else if (dst_kind
== 16)
619 *(real128t
*) dst
= (real128t
) int_val
;
624 else if (src_type
== BT_REAL
)
627 *(float*) dst
= (float) real_val
;
628 else if (dst_kind
== 8)
629 *(double*) dst
= (double) real_val
;
630 #ifdef HAVE_GFC_REAL_10
631 else if (dst_kind
== 10)
632 *(long double*) dst
= (long double) real_val
;
634 #ifdef HAVE_GFC_REAL_16
635 else if (dst_kind
== 16)
636 *(real128t
*) dst
= (real128t
) real_val
;
641 else if (src_type
== BT_COMPLEX
)
644 *(float*) dst
= (float) cmpx_val
;
645 else if (dst_kind
== 8)
646 *(double*) dst
= (double) cmpx_val
;
647 #ifdef HAVE_GFC_REAL_10
648 else if (dst_kind
== 10)
649 *(long double*) dst
= (long double) cmpx_val
;
651 #ifdef HAVE_GFC_REAL_16
652 else if (dst_kind
== 16)
653 *(real128t
*) dst
= (real128t
) cmpx_val
;
660 if (src_type
== BT_INTEGER
)
663 *(_Complex
float*) dst
= (_Complex
float) int_val
;
664 else if (dst_kind
== 8)
665 *(_Complex
double*) dst
= (_Complex
double) int_val
;
666 #ifdef HAVE_GFC_REAL_10
667 else if (dst_kind
== 10)
668 *(_Complex
long double*) dst
= (_Complex
long double) int_val
;
670 #ifdef HAVE_GFC_REAL_16
671 else if (dst_kind
== 16)
672 *(complex128t
*) dst
= (complex128t
) int_val
;
677 else if (src_type
== BT_REAL
)
680 *(_Complex
float*) dst
= (_Complex
float) real_val
;
681 else if (dst_kind
== 8)
682 *(_Complex
double*) dst
= (_Complex
double) real_val
;
683 #ifdef HAVE_GFC_REAL_10
684 else if (dst_kind
== 10)
685 *(_Complex
long double*) dst
= (_Complex
long double) real_val
;
687 #ifdef HAVE_GFC_REAL_16
688 else if (dst_kind
== 16)
689 *(complex128t
*) dst
= (complex128t
) real_val
;
694 else if (src_type
== BT_COMPLEX
)
697 *(_Complex
float*) dst
= (_Complex
float) cmpx_val
;
698 else if (dst_kind
== 8)
699 *(_Complex
double*) dst
= (_Complex
double) cmpx_val
;
700 #ifdef HAVE_GFC_REAL_10
701 else if (dst_kind
== 10)
702 *(_Complex
long double*) dst
= (_Complex
long double) cmpx_val
;
704 #ifdef HAVE_GFC_REAL_16
705 else if (dst_kind
== 16)
706 *(complex128t
*) dst
= (complex128t
) cmpx_val
;
719 fprintf (stderr
, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
720 "%d to type %d kind %d\n", src_type
, src_kind
, dst_type
, dst_kind
);
729 _gfortran_caf_get (caf_token_t token
, size_t offset
,
730 int image_index
__attribute__ ((unused
)),
731 gfc_descriptor_t
*src
,
732 caf_vector_t
*src_vector
__attribute__ ((unused
)),
733 gfc_descriptor_t
*dest
, int src_kind
, int dst_kind
,
734 bool may_require_tmp
, int *stat
)
736 /* FIXME: Handle vector subscripts. */
739 int rank
= GFC_DESCRIPTOR_RANK (dest
);
740 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
741 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
748 void *sr
= (void *) ((char *) MEMTOK (token
) + offset
);
749 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
750 && dst_kind
== src_kind
)
752 memmove (GFC_DESCRIPTOR_DATA (dest
), sr
,
753 dst_size
> src_size
? src_size
: dst_size
);
754 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
757 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest
) + src_size
,
758 ' ', dst_size
- src_size
);
759 else /* dst_kind == 4. */
760 for (i
= src_size
/4; i
< dst_size
/4; i
++)
761 ((int32_t*) GFC_DESCRIPTOR_DATA (dest
))[i
] = (int32_t) ' ';
764 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
765 assign_char1_from_char4 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
767 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
768 assign_char4_from_char1 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
771 convert_type (GFC_DESCRIPTOR_DATA (dest
), GFC_DESCRIPTOR_TYPE (dest
),
772 dst_kind
, sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
777 for (j
= 0; j
< rank
; j
++)
779 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
790 ptrdiff_t array_offset_sr
, array_offset_dst
;
791 void *tmp
= malloc (size
*src_size
);
793 array_offset_dst
= 0;
794 for (i
= 0; i
< size
; i
++)
796 ptrdiff_t array_offset_sr
= 0;
797 ptrdiff_t stride
= 1;
798 ptrdiff_t extent
= 1;
799 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
801 array_offset_sr
+= ((i
/ (extent
*stride
))
802 % (src
->dim
[j
]._ubound
803 - src
->dim
[j
].lower_bound
+ 1))
804 * src
->dim
[j
]._stride
;
805 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
806 stride
= src
->dim
[j
]._stride
;
808 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
809 void *sr
= (void *)((char *) MEMTOK (token
) + offset
810 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
811 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
812 array_offset_dst
+= src_size
;
816 for (i
= 0; i
< size
; i
++)
818 ptrdiff_t array_offset_dst
= 0;
819 ptrdiff_t stride
= 1;
820 ptrdiff_t extent
= 1;
821 for (j
= 0; j
< rank
-1; j
++)
823 array_offset_dst
+= ((i
/ (extent
*stride
))
824 % (dest
->dim
[j
]._ubound
825 - dest
->dim
[j
].lower_bound
+ 1))
826 * dest
->dim
[j
]._stride
;
827 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
828 stride
= dest
->dim
[j
]._stride
;
830 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
831 void *dst
= dest
->base_addr
832 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
833 void *sr
= tmp
+ array_offset_sr
;
835 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
836 && dst_kind
== src_kind
)
838 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
839 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
840 && dst_size
> src_size
)
843 memset ((void*)(char*) dst
+ src_size
, ' ',
845 else /* dst_kind == 4. */
846 for (k
= src_size
/4; k
< dst_size
/4; k
++)
847 ((int32_t*) dst
)[k
] = (int32_t) ' ';
850 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
851 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
852 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
853 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
855 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
856 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
857 array_offset_sr
+= src_size
;
864 for (i
= 0; i
< size
; i
++)
866 ptrdiff_t array_offset_dst
= 0;
867 ptrdiff_t stride
= 1;
868 ptrdiff_t extent
= 1;
869 for (j
= 0; j
< rank
-1; j
++)
871 array_offset_dst
+= ((i
/ (extent
*stride
))
872 % (dest
->dim
[j
]._ubound
873 - dest
->dim
[j
].lower_bound
+ 1))
874 * dest
->dim
[j
]._stride
;
875 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
876 stride
= dest
->dim
[j
]._stride
;
878 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
879 void *dst
= dest
->base_addr
+ array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
881 ptrdiff_t array_offset_sr
= 0;
884 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
886 array_offset_sr
+= ((i
/ (extent
*stride
))
887 % (src
->dim
[j
]._ubound
888 - src
->dim
[j
].lower_bound
+ 1))
889 * src
->dim
[j
]._stride
;
890 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
891 stride
= src
->dim
[j
]._stride
;
893 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
894 void *sr
= (void *)((char *) MEMTOK (token
) + offset
895 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
897 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
898 && dst_kind
== src_kind
)
900 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
901 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
904 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
905 else /* dst_kind == 4. */
906 for (k
= src_size
/4; k
< dst_size
/4; k
++)
907 ((int32_t*) dst
)[k
] = (int32_t) ' ';
910 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
911 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
912 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
913 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
915 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
916 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
922 _gfortran_caf_send (caf_token_t token
, size_t offset
,
923 int image_index
__attribute__ ((unused
)),
924 gfc_descriptor_t
*dest
,
925 caf_vector_t
*dst_vector
__attribute__ ((unused
)),
926 gfc_descriptor_t
*src
, int dst_kind
, int src_kind
,
927 bool may_require_tmp
, int *stat
)
929 /* FIXME: Handle vector subscripts. */
932 int rank
= GFC_DESCRIPTOR_RANK (dest
);
933 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
934 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
941 void *dst
= (void *) ((char *) MEMTOK (token
) + offset
);
942 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
943 && dst_kind
== src_kind
)
945 memmove (dst
, GFC_DESCRIPTOR_DATA (src
),
946 dst_size
> src_size
? src_size
: dst_size
);
947 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
950 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
951 else /* dst_kind == 4. */
952 for (i
= src_size
/4; i
< dst_size
/4; i
++)
953 ((int32_t*) dst
)[i
] = (int32_t) ' ';
956 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
957 assign_char1_from_char4 (dst_size
, src_size
, dst
,
958 GFC_DESCRIPTOR_DATA (src
));
959 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
960 assign_char4_from_char1 (dst_size
, src_size
, dst
,
961 GFC_DESCRIPTOR_DATA (src
));
963 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
964 GFC_DESCRIPTOR_DATA (src
), GFC_DESCRIPTOR_TYPE (src
),
970 for (j
= 0; j
< rank
; j
++)
972 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
983 ptrdiff_t array_offset_sr
, array_offset_dst
;
986 if (GFC_DESCRIPTOR_RANK (src
) == 0)
988 tmp
= malloc (src_size
);
989 memcpy (tmp
, GFC_DESCRIPTOR_DATA (src
), src_size
);
993 tmp
= malloc (size
*src_size
);
994 array_offset_dst
= 0;
995 for (i
= 0; i
< size
; i
++)
997 ptrdiff_t array_offset_sr
= 0;
998 ptrdiff_t stride
= 1;
999 ptrdiff_t extent
= 1;
1000 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
1002 array_offset_sr
+= ((i
/ (extent
*stride
))
1003 % (src
->dim
[j
]._ubound
1004 - src
->dim
[j
].lower_bound
+ 1))
1005 * src
->dim
[j
]._stride
;
1006 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
1007 stride
= src
->dim
[j
]._stride
;
1009 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
1010 void *sr
= (void *) ((char *) src
->base_addr
1011 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
1012 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
1013 array_offset_dst
+= src_size
;
1017 array_offset_sr
= 0;
1018 for (i
= 0; i
< size
; i
++)
1020 ptrdiff_t array_offset_dst
= 0;
1021 ptrdiff_t stride
= 1;
1022 ptrdiff_t extent
= 1;
1023 for (j
= 0; j
< rank
-1; j
++)
1025 array_offset_dst
+= ((i
/ (extent
*stride
))
1026 % (dest
->dim
[j
]._ubound
1027 - dest
->dim
[j
].lower_bound
+ 1))
1028 * dest
->dim
[j
]._stride
;
1029 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
1030 stride
= dest
->dim
[j
]._stride
;
1032 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
1033 void *dst
= (void *)((char *) MEMTOK (token
) + offset
1034 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
1035 void *sr
= tmp
+ array_offset_sr
;
1036 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
1037 && dst_kind
== src_kind
)
1040 dst_size
> src_size
? src_size
: dst_size
);
1041 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
1042 && dst_size
> src_size
)
1045 memset ((void*)(char*) dst
+ src_size
, ' ',
1047 else /* dst_kind == 4. */
1048 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1049 ((int32_t*) dst
)[k
] = (int32_t) ' ';
1052 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
1053 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
1054 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
1055 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
1057 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
1058 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
1059 if (GFC_DESCRIPTOR_RANK (src
))
1060 array_offset_sr
+= src_size
;
1066 for (i
= 0; i
< size
; i
++)
1068 ptrdiff_t array_offset_dst
= 0;
1069 ptrdiff_t stride
= 1;
1070 ptrdiff_t extent
= 1;
1071 for (j
= 0; j
< rank
-1; j
++)
1073 array_offset_dst
+= ((i
/ (extent
*stride
))
1074 % (dest
->dim
[j
]._ubound
1075 - dest
->dim
[j
].lower_bound
+ 1))
1076 * dest
->dim
[j
]._stride
;
1077 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
1078 stride
= dest
->dim
[j
]._stride
;
1080 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
1081 void *dst
= (void *)((char *) MEMTOK (token
) + offset
1082 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
1084 if (GFC_DESCRIPTOR_RANK (src
) != 0)
1086 ptrdiff_t array_offset_sr
= 0;
1089 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
1091 array_offset_sr
+= ((i
/ (extent
*stride
))
1092 % (src
->dim
[j
]._ubound
1093 - src
->dim
[j
].lower_bound
+ 1))
1094 * src
->dim
[j
]._stride
;
1095 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
1096 stride
= src
->dim
[j
]._stride
;
1098 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
1099 sr
= (void *)((char *) src
->base_addr
1100 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
1103 sr
= src
->base_addr
;
1105 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
1106 && dst_kind
== src_kind
)
1109 dst_size
> src_size
? src_size
: dst_size
);
1110 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
1113 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
1114 else /* dst_kind == 4. */
1115 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1116 ((int32_t*) dst
)[k
] = (int32_t) ' ';
1119 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
1120 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
1121 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
1122 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
1124 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
1125 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
1131 _gfortran_caf_sendget (caf_token_t dst_token
, size_t dst_offset
,
1132 int dst_image_index
, gfc_descriptor_t
*dest
,
1133 caf_vector_t
*dst_vector
, caf_token_t src_token
,
1135 int src_image_index
__attribute__ ((unused
)),
1136 gfc_descriptor_t
*src
,
1137 caf_vector_t
*src_vector
__attribute__ ((unused
)),
1138 int dst_kind
, int src_kind
, bool may_require_tmp
)
1140 /* FIXME: Handle vector subscript of 'src_vector'. */
1141 /* For a single image, src->base_addr should be the same as src_token + offset
1142 but to play save, we do it properly. */
1143 void *src_base
= GFC_DESCRIPTOR_DATA (src
);
1144 GFC_DESCRIPTOR_DATA (src
) = (void *) ((char *) MEMTOK (src_token
)
1146 _gfortran_caf_send (dst_token
, dst_offset
, dst_image_index
, dest
, dst_vector
,
1147 src
, dst_kind
, src_kind
, may_require_tmp
, NULL
);
1148 GFC_DESCRIPTOR_DATA (src
) = src_base
;
1152 /* Emitted when a theorectically unreachable part is reached. */
1153 const char unreachable
[] = "Fatal error: unreachable alternative found.\n";
1157 copy_data (void *ds
, void *sr
, int dst_type
, int src_type
,
1158 int dst_kind
, int src_kind
, size_t dst_size
, size_t src_size
,
1159 size_t num
, int *stat
)
1162 if (dst_type
== src_type
&& dst_kind
== src_kind
)
1164 memmove (ds
, sr
, (dst_size
> src_size
? src_size
: dst_size
) * num
);
1165 if ((dst_type
== BT_CHARACTER
|| src_type
== BT_CHARACTER
)
1166 && dst_size
> src_size
)
1169 memset ((void*)(char*) ds
+ src_size
, ' ', dst_size
-src_size
);
1170 else /* dst_kind == 4. */
1171 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1172 ((int32_t*) ds
)[k
] = (int32_t) ' ';
1175 else if (dst_type
== BT_CHARACTER
&& dst_kind
== 1)
1176 assign_char1_from_char4 (dst_size
, src_size
, ds
, sr
);
1177 else if (dst_type
== BT_CHARACTER
)
1178 assign_char4_from_char1 (dst_size
, src_size
, ds
, sr
);
1180 for (k
= 0; k
< num
; ++k
)
1182 convert_type (ds
, dst_type
, dst_kind
, sr
, src_type
, src_kind
, stat
);
1189 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1191 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1192 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1193 if (num <= 0 || abs_stride < 1) return; \
1194 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1199 get_for_ref (caf_reference_t
*ref
, size_t *i
, size_t *dst_index
,
1200 caf_single_token_t single_token
, gfc_descriptor_t
*dst
,
1201 gfc_descriptor_t
*src
, void *ds
, void *sr
,
1202 int dst_kind
, int src_kind
, size_t dst_dim
, size_t src_dim
,
1203 size_t num
, int *stat
, int src_type
)
1205 ptrdiff_t extent_src
= 1, array_offset_src
= 0, stride_src
;
1206 size_t next_dst_dim
;
1208 if (unlikely (ref
== NULL
))
1209 /* May be we should issue an error here, because this case should not
1213 if (ref
->next
== NULL
)
1215 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dst
);
1216 ptrdiff_t array_offset_dst
= 0;;
1217 size_t dst_rank
= GFC_DESCRIPTOR_RANK (dst
);
1221 case CAF_REF_COMPONENT
:
1222 /* Because the token is always registered after the component, its
1223 offset is always greater zero. */
1224 if (ref
->u
.c
.caf_token_offset
> 0)
1225 /* Note, that sr is dereffed here. */
1226 copy_data (ds
, *(void **)(sr
+ ref
->u
.c
.offset
),
1227 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1228 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1230 copy_data (ds
, sr
+ ref
->u
.c
.offset
,
1231 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1232 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1235 case CAF_REF_STATIC_ARRAY
:
1236 /* Intentionally fall through. */
1238 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1240 for (size_t d
= 0; d
< dst_rank
; ++d
)
1241 array_offset_dst
+= dst_index
[d
];
1242 copy_data (ds
+ array_offset_dst
* dst_size
, sr
,
1243 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1244 dst_kind
, src_kind
, dst_size
, ref
->item_size
, num
,
1251 caf_runtime_error (unreachable
);
1257 case CAF_REF_COMPONENT
:
1258 if (ref
->u
.c
.caf_token_offset
> 0)
1260 single_token
= *(caf_single_token_t
*)(sr
+ ref
->u
.c
.caf_token_offset
);
1262 if (ref
->next
&& ref
->next
->type
== CAF_REF_ARRAY
)
1263 src
= single_token
->desc
;
1267 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
1268 /* The currently ref'ed component was allocatabe (caf_token_offset
1269 > 0) and the next ref is a component, too, then the new sr has to
1270 be dereffed. (static arrays cannot be allocatable or they
1271 become an array with descriptor. */
1272 sr
= *(void **)(sr
+ ref
->u
.c
.offset
);
1274 sr
+= ref
->u
.c
.offset
;
1276 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
, src
,
1277 ds
, sr
, dst_kind
, src_kind
, dst_dim
, 0,
1281 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1282 (gfc_descriptor_t
*)(sr
+ ref
->u
.c
.offset
), ds
,
1283 sr
+ ref
->u
.c
.offset
, dst_kind
, src_kind
, dst_dim
, 0, 1,
1287 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1289 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1290 src
, ds
, sr
, dst_kind
, src_kind
,
1291 dst_dim
, 0, 1, stat
, src_type
);
1294 /* Only when on the left most index switch the data pointer to
1295 the array's data pointer. */
1297 sr
= GFC_DESCRIPTOR_DATA (src
);
1298 switch (ref
->u
.a
.mode
[src_dim
])
1300 case CAF_ARR_REF_VECTOR
:
1301 extent_src
= GFC_DIMENSION_EXTENT (src
->dim
[src_dim
]);
1302 array_offset_src
= 0;
1303 dst_index
[dst_dim
] = 0;
1304 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1307 #define KINDCASE(kind, type) case kind: \
1308 array_offset_src = (((index_type) \
1309 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1310 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1311 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1314 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1316 KINDCASE (1, GFC_INTEGER_1
);
1317 KINDCASE (2, GFC_INTEGER_2
);
1318 KINDCASE (4, GFC_INTEGER_4
);
1319 #ifdef HAVE_GFC_INTEGER_8
1320 KINDCASE (8, GFC_INTEGER_8
);
1322 #ifdef HAVE_GFC_INTEGER_16
1323 KINDCASE (16, GFC_INTEGER_16
);
1326 caf_runtime_error (unreachable
);
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,
1336 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1339 case CAF_ARR_REF_FULL
:
1340 COMPUTE_NUM_ITEMS (extent_src
,
1341 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1342 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1343 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1344 stride_src
= src
->dim
[src_dim
]._stride
1345 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1346 array_offset_src
= 0;
1347 dst_index
[dst_dim
] = 0;
1348 for (index_type idx
= 0; idx
< extent_src
;
1349 ++idx
, array_offset_src
+= stride_src
)
1351 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1352 ds
, sr
+ array_offset_src
* ref
->item_size
,
1353 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1356 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1359 case CAF_ARR_REF_RANGE
:
1360 COMPUTE_NUM_ITEMS (extent_src
,
1361 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1362 ref
->u
.a
.dim
[src_dim
].s
.start
,
1363 ref
->u
.a
.dim
[src_dim
].s
.end
);
1364 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1365 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1366 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1367 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1368 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1369 dst_index
[dst_dim
] = 0;
1370 /* Increase the dst_dim only, when the src_extent is greater one
1371 or src and dst extent are both one. Don't increase when the scalar
1372 source is not present in the dst. */
1373 next_dst_dim
= extent_src
> 1
1374 || (GFC_DIMENSION_EXTENT (dst
->dim
[dst_dim
]) == 1
1375 && extent_src
== 1) ? (dst_dim
+ 1) : dst_dim
;
1376 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1378 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1379 ds
, sr
+ array_offset_src
* ref
->item_size
,
1380 dst_kind
, src_kind
, next_dst_dim
, src_dim
+ 1,
1383 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1384 array_offset_src
+= stride_src
;
1387 case CAF_ARR_REF_SINGLE
:
1388 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1389 - src
->dim
[src_dim
].lower_bound
)
1390 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1391 dst_index
[dst_dim
] = 0;
1392 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
, ds
,
1393 sr
+ array_offset_src
* ref
->item_size
,
1394 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1397 case CAF_ARR_REF_OPEN_END
:
1398 COMPUTE_NUM_ITEMS (extent_src
,
1399 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1400 ref
->u
.a
.dim
[src_dim
].s
.start
,
1401 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1402 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1403 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1404 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1405 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1406 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
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,
1415 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1416 array_offset_src
+= stride_src
;
1419 case CAF_ARR_REF_OPEN_START
:
1420 COMPUTE_NUM_ITEMS (extent_src
,
1421 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1422 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1423 ref
->u
.a
.dim
[src_dim
].s
.end
);
1424 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1425 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1426 array_offset_src
= 0;
1427 dst_index
[dst_dim
] = 0;
1428 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1430 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1431 ds
, sr
+ array_offset_src
* ref
->item_size
,
1432 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1435 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1436 array_offset_src
+= stride_src
;
1440 caf_runtime_error (unreachable
);
1443 case CAF_REF_STATIC_ARRAY
:
1444 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1446 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1447 NULL
, ds
, sr
, dst_kind
, src_kind
,
1448 dst_dim
, 0, 1, stat
, src_type
);
1451 switch (ref
->u
.a
.mode
[src_dim
])
1453 case CAF_ARR_REF_VECTOR
:
1454 array_offset_src
= 0;
1455 dst_index
[dst_dim
] = 0;
1456 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1459 #define KINDCASE(kind, type) case kind: \
1460 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1463 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1465 KINDCASE (1, GFC_INTEGER_1
);
1466 KINDCASE (2, GFC_INTEGER_2
);
1467 KINDCASE (4, GFC_INTEGER_4
);
1468 #ifdef HAVE_GFC_INTEGER_8
1469 KINDCASE (8, GFC_INTEGER_8
);
1471 #ifdef HAVE_GFC_INTEGER_16
1472 KINDCASE (16, GFC_INTEGER_16
);
1475 caf_runtime_error (unreachable
);
1480 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1481 ds
, sr
+ array_offset_src
* ref
->item_size
,
1482 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1485 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1488 case CAF_ARR_REF_FULL
:
1489 dst_index
[dst_dim
] = 0;
1490 for (array_offset_src
= 0 ;
1491 array_offset_src
<= ref
->u
.a
.dim
[src_dim
].s
.end
;
1492 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
)
1494 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1495 ds
, sr
+ array_offset_src
* ref
->item_size
,
1496 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1499 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1502 case CAF_ARR_REF_RANGE
:
1503 COMPUTE_NUM_ITEMS (extent_src
,
1504 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1505 ref
->u
.a
.dim
[src_dim
].s
.start
,
1506 ref
->u
.a
.dim
[src_dim
].s
.end
);
1507 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1508 dst_index
[dst_dim
] = 0;
1509 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1511 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1512 ds
, sr
+ array_offset_src
* ref
->item_size
,
1513 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1516 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1517 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
;
1520 case CAF_ARR_REF_SINGLE
:
1521 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1522 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
, ds
,
1523 sr
+ array_offset_src
* ref
->item_size
,
1524 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1527 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
1528 case CAF_ARR_REF_OPEN_END
:
1529 case CAF_ARR_REF_OPEN_START
:
1531 caf_runtime_error (unreachable
);
1535 caf_runtime_error (unreachable
);
1541 _gfortran_caf_get_by_ref (caf_token_t token
,
1542 int image_index
__attribute__ ((unused
)),
1543 gfc_descriptor_t
*dst
, caf_reference_t
*refs
,
1544 int dst_kind
, int src_kind
,
1545 bool may_require_tmp
__attribute__ ((unused
)),
1546 bool dst_reallocatable
, int *stat
,
1549 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
1550 "unknown kind in vector-ref.\n";
1551 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
1552 "unknown reference type.\n";
1553 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
1554 "unknown array reference type.\n";
1555 const char rankoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1556 "rank out of range.\n";
1557 const char extentoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1558 "extent out of range.\n";
1559 const char cannotallocdst
[] = "libcaf_single::caf_get_by_ref(): "
1560 "cannot allocate memory.\n";
1561 const char nonallocextentmismatch
[] = "libcaf_single::caf_get_by_ref(): "
1562 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1563 const char doublearrayref
[] = "libcaf_single::caf_get_by_ref(): "
1564 "two or more array part references are not supported.\n";
1566 size_t dst_index
[GFC_MAX_DIMENSIONS
];
1567 int dst_rank
= GFC_DESCRIPTOR_RANK (dst
);
1568 int dst_cur_dim
= 0;
1569 size_t src_size
= 0;
1570 caf_single_token_t single_token
= TOKEN (token
);
1571 void *memptr
= single_token
->memptr
;
1572 gfc_descriptor_t
*src
= single_token
->desc
;
1573 caf_reference_t
*riter
= refs
;
1575 /* Reallocation of dst.data is needed (e.g., array to small). */
1576 bool realloc_needed
;
1577 /* Reallocation of dst.data is required, because data is not alloced at
1579 bool realloc_required
;
1580 bool extent_mismatch
= false;
1581 /* Set when the first non-scalar array reference is encountered. */
1582 bool in_array_ref
= false;
1583 bool array_extent_fixed
= false;
1584 realloc_needed
= realloc_required
= GFC_DESCRIPTOR_DATA (dst
) == NULL
;
1586 assert (!realloc_needed
|| dst_reallocatable
);
1591 /* Compute the size of the result. In the beginning size just counts the
1592 number of elements. */
1596 switch (riter
->type
)
1598 case CAF_REF_COMPONENT
:
1599 if (riter
->u
.c
.caf_token_offset
)
1601 single_token
= *(caf_single_token_t
*)
1602 (memptr
+ riter
->u
.c
.caf_token_offset
);
1603 memptr
= single_token
->memptr
;
1604 src
= single_token
->desc
;
1608 memptr
+= riter
->u
.c
.offset
;
1609 /* When the next ref is an array ref, assume there is an
1610 array descriptor at memptr. Note, static arrays do not have
1612 if (riter
->next
&& riter
->next
->type
== CAF_REF_ARRAY
)
1613 src
= (gfc_descriptor_t
*)memptr
;
1619 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1621 switch (riter
->u
.a
.mode
[i
])
1623 case CAF_ARR_REF_VECTOR
:
1624 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1625 #define KINDCASE(kind, type) case kind: \
1626 memptr += (((index_type) \
1627 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1628 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1629 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1630 * riter->item_size; \
1633 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1635 KINDCASE (1, GFC_INTEGER_1
);
1636 KINDCASE (2, GFC_INTEGER_2
);
1637 KINDCASE (4, GFC_INTEGER_4
);
1638 #ifdef HAVE_GFC_INTEGER_8
1639 KINDCASE (8, GFC_INTEGER_8
);
1641 #ifdef HAVE_GFC_INTEGER_16
1642 KINDCASE (16, GFC_INTEGER_16
);
1645 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1650 case CAF_ARR_REF_FULL
:
1651 COMPUTE_NUM_ITEMS (delta
,
1652 riter
->u
.a
.dim
[i
].s
.stride
,
1653 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1654 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1655 /* The memptr stays unchanged when ref'ing the first element
1658 case CAF_ARR_REF_RANGE
:
1659 COMPUTE_NUM_ITEMS (delta
,
1660 riter
->u
.a
.dim
[i
].s
.stride
,
1661 riter
->u
.a
.dim
[i
].s
.start
,
1662 riter
->u
.a
.dim
[i
].s
.end
);
1663 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1664 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1665 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1668 case CAF_ARR_REF_SINGLE
:
1670 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1671 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1672 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1675 case CAF_ARR_REF_OPEN_END
:
1676 COMPUTE_NUM_ITEMS (delta
,
1677 riter
->u
.a
.dim
[i
].s
.stride
,
1678 riter
->u
.a
.dim
[i
].s
.start
,
1679 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1680 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1681 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1682 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1685 case CAF_ARR_REF_OPEN_START
:
1686 COMPUTE_NUM_ITEMS (delta
,
1687 riter
->u
.a
.dim
[i
].s
.stride
,
1688 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1689 riter
->u
.a
.dim
[i
].s
.end
);
1690 /* The memptr stays unchanged when ref'ing the first element
1694 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1699 /* Check the various properties of the destination array.
1700 Is an array expected and present? */
1701 if (delta
> 1 && dst_rank
== 0)
1703 /* No, an array is required, but not provided. */
1704 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1707 /* Special mode when called by __caf_sendget_by_ref (). */
1708 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1710 dst_rank
= dst_cur_dim
+ 1;
1711 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1712 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1714 /* When dst is an array. */
1717 /* Check that dst_cur_dim is valid for dst. Can be
1718 superceeded only by scalar data. */
1719 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1721 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1724 /* Do further checks, when the source is not scalar. */
1725 else if (delta
!= 1)
1727 /* Check that the extent is not scalar and we are not in
1728 an array ref for the dst side. */
1731 /* Check that this is the non-scalar extent. */
1732 if (!array_extent_fixed
)
1734 /* In an array extent now. */
1735 in_array_ref
= true;
1736 /* Check that we haven't skipped any scalar
1737 dimensions yet and that the dst is
1740 && dst_rank
== GFC_DESCRIPTOR_RANK (src
))
1742 if (dst_reallocatable
)
1744 /* Dst is reallocatable, which means that
1745 the bounds are not set. Set them. */
1746 for (dst_cur_dim
= 0; dst_cur_dim
< (int)i
;
1748 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
],
1754 /* Else press thumbs, that there are enough
1755 dimensional refs to come. Checked below. */
1759 caf_internal_error (doublearrayref
, stat
, NULL
,
1764 /* When the realloc is required, then no extent may have
1766 extent_mismatch
= realloc_required
1767 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1768 /* When it already known, that a realloc is needed or
1769 the extent does not match the needed one. */
1770 if (realloc_required
|| realloc_needed
1773 /* Check whether dst is reallocatable. */
1774 if (unlikely (!dst_reallocatable
))
1776 caf_internal_error (nonallocextentmismatch
, stat
,
1778 GFC_DESCRIPTOR_EXTENT (dst
,
1782 /* Only report an error, when the extent needs to be
1783 modified, which is not allowed. */
1784 else if (!dst_reallocatable
&& extent_mismatch
)
1786 caf_internal_error (extentoutofrange
, stat
, NULL
,
1790 realloc_needed
= true;
1792 /* Only change the extent when it does not match. This is
1793 to prevent resetting given array bounds. */
1794 if (extent_mismatch
)
1795 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1799 /* Only increase the dim counter, when in an array ref. */
1800 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1803 size
*= (index_type
)delta
;
1807 array_extent_fixed
= true;
1808 in_array_ref
= false;
1809 /* Check, if we got less dimensional refs than the rank of dst
1811 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1814 case CAF_REF_STATIC_ARRAY
:
1815 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1817 switch (riter
->u
.a
.mode
[i
])
1819 case CAF_ARR_REF_VECTOR
:
1820 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1821 #define KINDCASE(kind, type) case kind: \
1822 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1823 * riter->item_size; \
1826 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1828 KINDCASE (1, GFC_INTEGER_1
);
1829 KINDCASE (2, GFC_INTEGER_2
);
1830 KINDCASE (4, GFC_INTEGER_4
);
1831 #ifdef HAVE_GFC_INTEGER_8
1832 KINDCASE (8, GFC_INTEGER_8
);
1834 #ifdef HAVE_GFC_INTEGER_16
1835 KINDCASE (16, GFC_INTEGER_16
);
1838 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1843 case CAF_ARR_REF_FULL
:
1844 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
1846 /* The memptr stays unchanged when ref'ing the first element
1849 case CAF_ARR_REF_RANGE
:
1850 COMPUTE_NUM_ITEMS (delta
,
1851 riter
->u
.a
.dim
[i
].s
.stride
,
1852 riter
->u
.a
.dim
[i
].s
.start
,
1853 riter
->u
.a
.dim
[i
].s
.end
);
1854 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1855 * riter
->u
.a
.dim
[i
].s
.stride
1858 case CAF_ARR_REF_SINGLE
:
1860 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1861 * riter
->u
.a
.dim
[i
].s
.stride
1864 case CAF_ARR_REF_OPEN_END
:
1865 /* This and OPEN_START are mapped to a RANGE and therefore
1866 cannot occur here. */
1867 case CAF_ARR_REF_OPEN_START
:
1869 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1874 /* Check the various properties of the destination array.
1875 Is an array expected and present? */
1876 if (delta
> 1 && dst_rank
== 0)
1878 /* No, an array is required, but not provided. */
1879 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1882 /* Special mode when called by __caf_sendget_by_ref (). */
1883 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1885 dst_rank
= dst_cur_dim
+ 1;
1886 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1887 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1889 /* When dst is an array. */
1892 /* Check that dst_cur_dim is valid for dst. Can be
1893 superceeded only by scalar data. */
1894 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1896 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1899 /* Do further checks, when the source is not scalar. */
1900 else if (delta
!= 1)
1902 /* Check that the extent is not scalar and we are not in
1903 an array ref for the dst side. */
1906 /* Check that this is the non-scalar extent. */
1907 if (!array_extent_fixed
)
1909 /* In an array extent now. */
1910 in_array_ref
= true;
1911 /* The dst is not reallocatable, so nothing more
1912 to do, then correct the dim counter. */
1917 caf_internal_error (doublearrayref
, stat
, NULL
,
1922 /* When the realloc is required, then no extent may have
1924 extent_mismatch
= realloc_required
1925 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1926 /* When it is already known, that a realloc is needed or
1927 the extent does not match the needed one. */
1928 if (realloc_required
|| realloc_needed
1931 /* Check whether dst is reallocatable. */
1932 if (unlikely (!dst_reallocatable
))
1934 caf_internal_error (nonallocextentmismatch
, stat
,
1936 GFC_DESCRIPTOR_EXTENT (dst
,
1940 /* Only report an error, when the extent needs to be
1941 modified, which is not allowed. */
1942 else if (!dst_reallocatable
&& extent_mismatch
)
1944 caf_internal_error (extentoutofrange
, stat
, NULL
,
1948 realloc_needed
= true;
1950 /* Only change the extent when it does not match. This is
1951 to prevent resetting given array bounds. */
1952 if (extent_mismatch
)
1953 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1956 /* Only increase the dim counter, when in an array ref. */
1957 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1960 size
*= (index_type
)delta
;
1964 array_extent_fixed
= true;
1965 in_array_ref
= false;
1966 /* Check, if we got less dimensional refs than the rank of dst
1968 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1972 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
1975 src_size
= riter
->item_size
;
1976 riter
= riter
->next
;
1978 if (size
== 0 || src_size
== 0)
1981 - size contains the number of elements to store in the destination array,
1982 - src_size gives the size in bytes of each item in the destination array.
1987 if (!array_extent_fixed
)
1990 /* Special mode when called by __caf_sendget_by_ref (). */
1991 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1993 dst_rank
= dst_cur_dim
+ 1;
1994 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1995 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1997 /* This can happen only, when the result is scalar. */
1998 for (dst_cur_dim
= 0; dst_cur_dim
< dst_rank
; ++dst_cur_dim
)
1999 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, 1, 1);
2002 GFC_DESCRIPTOR_DATA (dst
) = malloc (size
* GFC_DESCRIPTOR_SIZE (dst
));
2003 if (unlikely (GFC_DESCRIPTOR_DATA (dst
) == NULL
))
2005 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2010 /* Reset the token. */
2011 single_token
= TOKEN (token
);
2012 memptr
= single_token
->memptr
;
2013 src
= single_token
->desc
;
2014 memset(dst_index
, 0, sizeof (dst_index
));
2016 get_for_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2017 GFC_DESCRIPTOR_DATA (dst
), memptr
, dst_kind
, src_kind
, 0, 0,
2023 send_by_ref (caf_reference_t
*ref
, size_t *i
, size_t *src_index
,
2024 caf_single_token_t single_token
, gfc_descriptor_t
*dst
,
2025 gfc_descriptor_t
*src
, void *ds
, void *sr
,
2026 int dst_kind
, int src_kind
, size_t dst_dim
, size_t src_dim
,
2027 size_t num
, size_t size
, int *stat
, int dst_type
)
2029 const char vecrefunknownkind
[] = "libcaf_single::caf_send_by_ref(): "
2030 "unknown kind in vector-ref.\n";
2031 ptrdiff_t extent_dst
= 1, array_offset_dst
= 0, stride_dst
;
2032 const size_t src_rank
= GFC_DESCRIPTOR_RANK (src
);
2034 if (unlikely (ref
== NULL
))
2035 /* May be we should issue an error here, because this case should not
2039 if (ref
->next
== NULL
)
2041 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
2042 ptrdiff_t array_offset_src
= 0;;
2046 case CAF_REF_COMPONENT
:
2047 if (ref
->u
.c
.caf_token_offset
> 0)
2049 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2051 /* Create a scalar temporary array descriptor. */
2052 gfc_descriptor_t static_dst
;
2053 GFC_DESCRIPTOR_DATA (&static_dst
) = NULL
;
2054 GFC_DESCRIPTOR_DTYPE (&static_dst
)
2055 = GFC_DESCRIPTOR_DTYPE (src
);
2056 /* The component can be allocated now, because it is a
2058 _gfortran_caf_register (ref
->item_size
,
2059 CAF_REGTYPE_COARRAY_ALLOC
,
2060 ds
+ ref
->u
.c
.caf_token_offset
,
2061 &static_dst
, stat
, NULL
, 0);
2062 single_token
= *(caf_single_token_t
*)
2063 (ds
+ ref
->u
.c
.caf_token_offset
);
2064 /* In case of an error in allocation return. When stat is
2065 NULL, then register_component() terminates on error. */
2066 if (stat
!= NULL
&& *stat
)
2068 /* Publish the allocated memory. */
2069 *((void **)(ds
+ ref
->u
.c
.offset
))
2070 = GFC_DESCRIPTOR_DATA (&static_dst
);
2071 ds
= GFC_DESCRIPTOR_DATA (&static_dst
);
2072 /* Set the type from the src. */
2073 dst_type
= GFC_DESCRIPTOR_TYPE (src
);
2077 single_token
= *(caf_single_token_t
*)
2078 (ds
+ ref
->u
.c
.caf_token_offset
);
2079 dst
= single_token
->desc
;
2082 ds
= GFC_DESCRIPTOR_DATA (dst
);
2083 dst_type
= GFC_DESCRIPTOR_TYPE (dst
);
2086 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2088 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2089 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2092 copy_data (ds
+ ref
->u
.c
.offset
, sr
, dst_type
,
2093 GFC_DESCRIPTOR_TYPE (src
),
2094 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2097 case CAF_REF_STATIC_ARRAY
:
2098 /* Intentionally fall through. */
2100 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2104 for (size_t d
= 0; d
< src_rank
; ++d
)
2105 array_offset_src
+= src_index
[d
];
2106 copy_data (ds
, sr
+ array_offset_src
* src_size
,
2107 dst_type
, GFC_DESCRIPTOR_TYPE (src
), dst_kind
,
2108 src_kind
, ref
->item_size
, src_size
, num
, stat
);
2111 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2112 dst_kind
, src_kind
, ref
->item_size
, src_size
, num
,
2119 caf_runtime_error (unreachable
);
2125 case CAF_REF_COMPONENT
:
2126 if (ref
->u
.c
.caf_token_offset
> 0)
2128 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2130 /* This component refs an unallocated array. Non-arrays are
2131 caught in the if (!ref->next) above. */
2132 dst
= (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
);
2133 /* Assume that the rank and the dimensions fit for copying src
2135 GFC_DESCRIPTOR_DTYPE (dst
) = GFC_DESCRIPTOR_DTYPE (src
);
2138 for (size_t d
= 0; d
< src_rank
; ++d
)
2140 extent_dst
= GFC_DIMENSION_EXTENT (src
->dim
[d
]);
2141 GFC_DIMENSION_LBOUND (dst
->dim
[d
]) = 0;
2142 GFC_DIMENSION_UBOUND (dst
->dim
[d
]) = extent_dst
- 1;
2143 GFC_DIMENSION_STRIDE (dst
->dim
[d
]) = stride_dst
;
2144 stride_dst
*= extent_dst
;
2146 /* Null the data-pointer to make register_component allocate
2148 GFC_DESCRIPTOR_DATA (dst
) = NULL
;
2150 /* The size of the array is given by size. */
2151 _gfortran_caf_register (size
* ref
->item_size
,
2152 CAF_REGTYPE_COARRAY_ALLOC
,
2153 ds
+ ref
->u
.c
.caf_token_offset
,
2154 dst
, stat
, NULL
, 0);
2155 /* In case of an error in allocation return. When stat is
2156 NULL, then register_component() terminates on error. */
2157 if (stat
!= NULL
&& *stat
)
2160 single_token
= *(caf_single_token_t
*)(ds
+ ref
->u
.c
.caf_token_offset
);
2161 /* When a component is allocatable (caf_token_offset != 0) and not an
2162 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
2164 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
2165 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2167 ds
+= ref
->u
.c
.offset
;
2169 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2170 single_token
->desc
, src
, ds
, sr
,
2171 dst_kind
, src_kind
, 0, src_dim
, 1, size
, stat
, dst_type
);
2174 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2175 (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
), src
,
2176 ds
+ ref
->u
.c
.offset
, sr
, dst_kind
, src_kind
, 0, src_dim
,
2177 1, size
, stat
, dst_type
);
2180 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2182 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2183 (gfc_descriptor_t
*)ds
, src
, ds
, sr
, dst_kind
, src_kind
,
2184 0, src_dim
, 1, size
, stat
, dst_type
);
2187 /* Only when on the left most index switch the data pointer to
2188 the array's data pointer. And only for non-static arrays. */
2189 if (dst_dim
== 0 && ref
->type
!= CAF_REF_STATIC_ARRAY
)
2190 ds
= GFC_DESCRIPTOR_DATA (dst
);
2191 switch (ref
->u
.a
.mode
[dst_dim
])
2193 case CAF_ARR_REF_VECTOR
:
2194 array_offset_dst
= 0;
2195 src_index
[src_dim
] = 0;
2196 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2199 #define KINDCASE(kind, type) case kind: \
2200 array_offset_dst = (((index_type) \
2201 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2202 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2203 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2206 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2208 KINDCASE (1, GFC_INTEGER_1
);
2209 KINDCASE (2, GFC_INTEGER_2
);
2210 KINDCASE (4, GFC_INTEGER_4
);
2211 #ifdef HAVE_GFC_INTEGER_8
2212 KINDCASE (8, GFC_INTEGER_8
);
2214 #ifdef HAVE_GFC_INTEGER_16
2215 KINDCASE (16, GFC_INTEGER_16
);
2218 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2223 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2224 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2225 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2226 1, size
, stat
, dst_type
);
2229 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2232 case CAF_ARR_REF_FULL
:
2233 COMPUTE_NUM_ITEMS (extent_dst
,
2234 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2235 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2236 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2237 array_offset_dst
= 0;
2238 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2239 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2240 src_index
[src_dim
] = 0;
2241 for (index_type idx
= 0; idx
< extent_dst
;
2242 ++idx
, array_offset_dst
+= stride_dst
)
2244 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2245 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2246 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2247 1, size
, stat
, dst_type
);
2250 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2253 case CAF_ARR_REF_RANGE
:
2254 COMPUTE_NUM_ITEMS (extent_dst
,
2255 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2256 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2257 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2258 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2259 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2260 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2261 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2262 src_index
[src_dim
] = 0;
2263 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2265 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2266 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2267 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2268 1, size
, stat
, dst_type
);
2271 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2272 array_offset_dst
+= stride_dst
;
2275 case CAF_ARR_REF_SINGLE
:
2276 array_offset_dst
= (ref
->u
.a
.dim
[dst_dim
].s
.start
2277 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]))
2278 * GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
2279 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
, ds
2280 + array_offset_dst
* ref
->item_size
, sr
,
2281 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2282 size
, stat
, dst_type
);
2284 case CAF_ARR_REF_OPEN_END
:
2285 COMPUTE_NUM_ITEMS (extent_dst
,
2286 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2287 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2288 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2289 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2290 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2291 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2292 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2293 src_index
[src_dim
] = 0;
2294 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2296 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2297 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2298 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2299 1, size
, stat
, dst_type
);
2302 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2303 array_offset_dst
+= stride_dst
;
2306 case CAF_ARR_REF_OPEN_START
:
2307 COMPUTE_NUM_ITEMS (extent_dst
,
2308 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2309 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2310 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2311 array_offset_dst
= 0;
2312 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2313 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2314 src_index
[src_dim
] = 0;
2315 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2317 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2318 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2319 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2320 1, size
, stat
, dst_type
);
2323 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2324 array_offset_dst
+= stride_dst
;
2328 caf_runtime_error (unreachable
);
2331 case CAF_REF_STATIC_ARRAY
:
2332 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2334 send_by_ref (ref
->next
, i
, src_index
, single_token
, NULL
,
2335 src
, ds
, sr
, dst_kind
, src_kind
,
2336 0, src_dim
, 1, size
, stat
, dst_type
);
2339 switch (ref
->u
.a
.mode
[dst_dim
])
2341 case CAF_ARR_REF_VECTOR
:
2342 array_offset_dst
= 0;
2343 src_index
[src_dim
] = 0;
2344 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2347 #define KINDCASE(kind, type) case kind: \
2348 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2351 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2353 KINDCASE (1, GFC_INTEGER_1
);
2354 KINDCASE (2, GFC_INTEGER_2
);
2355 KINDCASE (4, GFC_INTEGER_4
);
2356 #ifdef HAVE_GFC_INTEGER_8
2357 KINDCASE (8, GFC_INTEGER_8
);
2359 #ifdef HAVE_GFC_INTEGER_16
2360 KINDCASE (16, GFC_INTEGER_16
);
2363 caf_runtime_error (unreachable
);
2368 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2369 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2370 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2371 1, size
, stat
, dst_type
);
2373 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2376 case CAF_ARR_REF_FULL
:
2377 src_index
[src_dim
] = 0;
2378 for (array_offset_dst
= 0 ;
2379 array_offset_dst
<= ref
->u
.a
.dim
[dst_dim
].s
.end
;
2380 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
)
2382 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2383 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2384 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2385 1, size
, stat
, dst_type
);
2388 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2391 case CAF_ARR_REF_RANGE
:
2392 COMPUTE_NUM_ITEMS (extent_dst
,
2393 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2394 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2395 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2396 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2397 src_index
[src_dim
] = 0;
2398 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2400 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2401 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2402 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2403 1, size
, stat
, dst_type
);
2406 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2407 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2410 case CAF_ARR_REF_SINGLE
:
2411 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2412 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2413 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2414 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2415 size
, stat
, dst_type
);
2417 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
2418 case CAF_ARR_REF_OPEN_END
:
2419 case CAF_ARR_REF_OPEN_START
:
2421 caf_runtime_error (unreachable
);
2425 caf_runtime_error (unreachable
);
2431 _gfortran_caf_send_by_ref (caf_token_t token
,
2432 int image_index
__attribute__ ((unused
)),
2433 gfc_descriptor_t
*src
, caf_reference_t
*refs
,
2434 int dst_kind
, int src_kind
,
2435 bool may_require_tmp
__attribute__ ((unused
)),
2436 bool dst_reallocatable
, int *stat
, int dst_type
)
2438 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
2439 "unknown kind in vector-ref.\n";
2440 const char unknownreftype
[] = "libcaf_single::caf_send_by_ref(): "
2441 "unknown reference type.\n";
2442 const char unknownarrreftype
[] = "libcaf_single::caf_send_by_ref(): "
2443 "unknown array reference type.\n";
2444 const char rankoutofrange
[] = "libcaf_single::caf_send_by_ref(): "
2445 "rank out of range.\n";
2446 const char realloconinnerref
[] = "libcaf_single::caf_send_by_ref(): "
2447 "reallocation of array followed by component ref not allowed.\n";
2448 const char cannotallocdst
[] = "libcaf_single::caf_send_by_ref(): "
2449 "cannot allocate memory.\n";
2450 const char nonallocextentmismatch
[] = "libcaf_single::caf_send_by_ref(): "
2451 "extent of non-allocatable array mismatch.\n";
2452 const char innercompref
[] = "libcaf_single::caf_send_by_ref(): "
2453 "inner unallocated component detected.\n";
2455 size_t dst_index
[GFC_MAX_DIMENSIONS
];
2456 int src_rank
= GFC_DESCRIPTOR_RANK (src
);
2457 int src_cur_dim
= 0;
2458 size_t src_size
= 0;
2459 caf_single_token_t single_token
= TOKEN (token
);
2460 void *memptr
= single_token
->memptr
;
2461 gfc_descriptor_t
*dst
= single_token
->desc
;
2462 caf_reference_t
*riter
= refs
;
2464 bool extent_mismatch
;
2465 /* Note that the component is not allocated yet. */
2466 index_type new_component_idx
= -1;
2471 /* Compute the size of the result. In the beginning size just counts the
2472 number of elements. */
2476 switch (riter
->type
)
2478 case CAF_REF_COMPONENT
:
2479 if (unlikely (new_component_idx
!= -1))
2481 /* Allocating a component in the middle of a component ref is not
2482 support. We don't know the type to allocate. */
2483 caf_internal_error (innercompref
, stat
, NULL
, 0);
2486 if (riter
->u
.c
.caf_token_offset
> 0)
2488 /* Check whether the allocatable component is zero, then no
2489 token is present, too. The token's pointer is not cleared
2490 when the structure is initialized. */
2491 if (*(void**)(memptr
+ riter
->u
.c
.offset
) == NULL
)
2493 /* This component is not yet allocated. Check that it is
2494 allocatable here. */
2495 if (!dst_reallocatable
)
2497 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2500 single_token
= NULL
;
2505 single_token
= *(caf_single_token_t
*)
2506 (memptr
+ riter
->u
.c
.caf_token_offset
);
2507 memptr
+= riter
->u
.c
.offset
;
2508 dst
= single_token
->desc
;
2512 /* Regular component. */
2513 memptr
+= riter
->u
.c
.offset
;
2514 dst
= (gfc_descriptor_t
*)memptr
;
2519 memptr
= GFC_DESCRIPTOR_DATA (dst
);
2522 /* When the dst array needs to be allocated, then look at the
2523 extent of the source array in the dimension dst_cur_dim. */
2524 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2526 switch (riter
->u
.a
.mode
[i
])
2528 case CAF_ARR_REF_VECTOR
:
2529 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2530 #define KINDCASE(kind, type) case kind: \
2531 memptr += (((index_type) \
2532 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2533 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2534 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2535 * riter->item_size; \
2538 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2540 KINDCASE (1, GFC_INTEGER_1
);
2541 KINDCASE (2, GFC_INTEGER_2
);
2542 KINDCASE (4, GFC_INTEGER_4
);
2543 #ifdef HAVE_GFC_INTEGER_8
2544 KINDCASE (8, GFC_INTEGER_8
);
2546 #ifdef HAVE_GFC_INTEGER_16
2547 KINDCASE (16, GFC_INTEGER_16
);
2550 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2555 case CAF_ARR_REF_FULL
:
2557 COMPUTE_NUM_ITEMS (delta
,
2558 riter
->u
.a
.dim
[i
].s
.stride
,
2559 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2560 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2562 COMPUTE_NUM_ITEMS (delta
,
2563 riter
->u
.a
.dim
[i
].s
.stride
,
2564 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2565 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2567 case CAF_ARR_REF_RANGE
:
2568 COMPUTE_NUM_ITEMS (delta
,
2569 riter
->u
.a
.dim
[i
].s
.stride
,
2570 riter
->u
.a
.dim
[i
].s
.start
,
2571 riter
->u
.a
.dim
[i
].s
.end
);
2572 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2573 - dst
->dim
[i
].lower_bound
)
2574 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2577 case CAF_ARR_REF_SINGLE
:
2579 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2580 - dst
->dim
[i
].lower_bound
)
2581 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2584 case CAF_ARR_REF_OPEN_END
:
2586 COMPUTE_NUM_ITEMS (delta
,
2587 riter
->u
.a
.dim
[i
].s
.stride
,
2588 riter
->u
.a
.dim
[i
].s
.start
,
2589 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2591 COMPUTE_NUM_ITEMS (delta
,
2592 riter
->u
.a
.dim
[i
].s
.stride
,
2593 riter
->u
.a
.dim
[i
].s
.start
,
2594 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2595 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2596 - dst
->dim
[i
].lower_bound
)
2597 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2600 case CAF_ARR_REF_OPEN_START
:
2602 COMPUTE_NUM_ITEMS (delta
,
2603 riter
->u
.a
.dim
[i
].s
.stride
,
2604 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2605 riter
->u
.a
.dim
[i
].s
.end
);
2607 COMPUTE_NUM_ITEMS (delta
,
2608 riter
->u
.a
.dim
[i
].s
.stride
,
2609 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2610 riter
->u
.a
.dim
[i
].s
.end
);
2611 /* The memptr stays unchanged when ref'ing the first element
2615 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2621 /* Check the various properties of the source array.
2622 When src is an array. */
2623 if (delta
> 1 && src_rank
> 0)
2625 /* Check that src_cur_dim is valid for src. Can be
2626 superceeded only by scalar data. */
2627 if (src_cur_dim
>= src_rank
)
2629 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2632 /* Do further checks, when the source is not scalar. */
2635 /* When the realloc is required, then no extent may have
2637 extent_mismatch
= memptr
== NULL
2639 && GFC_DESCRIPTOR_EXTENT (dst
, src_cur_dim
)
2641 /* When it already known, that a realloc is needed or
2642 the extent does not match the needed one. */
2643 if (extent_mismatch
)
2645 /* Check whether dst is reallocatable. */
2646 if (unlikely (!dst_reallocatable
))
2648 caf_internal_error (nonallocextentmismatch
, stat
,
2650 GFC_DESCRIPTOR_EXTENT (dst
,
2654 /* Report error on allocatable but missing inner
2656 else if (riter
->next
!= NULL
)
2658 caf_internal_error (realloconinnerref
, stat
, NULL
,
2663 /* Only change the extent when it does not match. This is
2664 to prevent resetting given array bounds. */
2665 if (extent_mismatch
)
2666 GFC_DIMENSION_SET (dst
->dim
[src_cur_dim
], 1, delta
,
2669 /* Increase the dim-counter of the src only when the extent
2671 if (src_cur_dim
< src_rank
2672 && GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
) == delta
)
2675 size
*= (index_type
)delta
;
2678 case CAF_REF_STATIC_ARRAY
:
2679 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2681 switch (riter
->u
.a
.mode
[i
])
2683 case CAF_ARR_REF_VECTOR
:
2684 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2685 #define KINDCASE(kind, type) case kind: \
2686 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2687 * riter->item_size; \
2690 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2692 KINDCASE (1, GFC_INTEGER_1
);
2693 KINDCASE (2, GFC_INTEGER_2
);
2694 KINDCASE (4, GFC_INTEGER_4
);
2695 #ifdef HAVE_GFC_INTEGER_8
2696 KINDCASE (8, GFC_INTEGER_8
);
2698 #ifdef HAVE_GFC_INTEGER_16
2699 KINDCASE (16, GFC_INTEGER_16
);
2702 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2707 case CAF_ARR_REF_FULL
:
2708 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
2710 /* The memptr stays unchanged when ref'ing the first element
2713 case CAF_ARR_REF_RANGE
:
2714 COMPUTE_NUM_ITEMS (delta
,
2715 riter
->u
.a
.dim
[i
].s
.stride
,
2716 riter
->u
.a
.dim
[i
].s
.start
,
2717 riter
->u
.a
.dim
[i
].s
.end
);
2718 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2719 * riter
->u
.a
.dim
[i
].s
.stride
2722 case CAF_ARR_REF_SINGLE
:
2724 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2725 * riter
->u
.a
.dim
[i
].s
.stride
2728 case CAF_ARR_REF_OPEN_END
:
2729 /* This and OPEN_START are mapped to a RANGE and therefore
2730 cannot occur here. */
2731 case CAF_ARR_REF_OPEN_START
:
2733 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2738 /* Check the various properties of the source array.
2739 Only when the source array is not scalar examine its
2741 if (delta
> 1 && src_rank
> 0)
2743 /* Check that src_cur_dim is valid for src. Can be
2744 superceeded only by scalar data. */
2745 if (src_cur_dim
>= src_rank
)
2747 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2752 /* We will not be able to realloc the dst, because that's
2753 a fixed size array. */
2754 extent_mismatch
= GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
)
2756 /* When the extent does not match the needed one we can
2758 if (extent_mismatch
)
2760 caf_internal_error (nonallocextentmismatch
, stat
,
2762 GFC_DESCRIPTOR_EXTENT (src
,
2769 size
*= (index_type
)delta
;
2773 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
2776 src_size
= riter
->item_size
;
2777 riter
= riter
->next
;
2779 if (size
== 0 || src_size
== 0)
2782 - size contains the number of elements to store in the destination array,
2783 - src_size gives the size in bytes of each item in the destination array.
2786 /* Reset the token. */
2787 single_token
= TOKEN (token
);
2788 memptr
= single_token
->memptr
;
2789 dst
= single_token
->desc
;
2790 memset (dst_index
, 0, sizeof (dst_index
));
2792 send_by_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2793 memptr
, GFC_DESCRIPTOR_DATA (src
), dst_kind
, src_kind
, 0, 0,
2794 1, size
, stat
, dst_type
);
2800 _gfortran_caf_sendget_by_ref (caf_token_t dst_token
, int dst_image_index
,
2801 caf_reference_t
*dst_refs
, caf_token_t src_token
,
2802 int src_image_index
,
2803 caf_reference_t
*src_refs
, int dst_kind
,
2804 int src_kind
, bool may_require_tmp
, int *dst_stat
,
2805 int *src_stat
, int dst_type
, int src_type
)
2807 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS
, void) temp
;
2808 GFC_DESCRIPTOR_DATA (&temp
) = NULL
;
2809 GFC_DESCRIPTOR_RANK (&temp
) = -1;
2810 GFC_DESCRIPTOR_TYPE (&temp
) = dst_type
;
2812 _gfortran_caf_get_by_ref (src_token
, src_image_index
,
2813 (gfc_descriptor_t
*) &temp
, src_refs
,
2814 dst_kind
, src_kind
, may_require_tmp
, true,
2815 src_stat
, src_type
);
2817 if (src_stat
&& *src_stat
!= 0)
2820 _gfortran_caf_send_by_ref (dst_token
, dst_image_index
,
2821 (gfc_descriptor_t
*) &temp
, dst_refs
,
2822 dst_kind
, dst_kind
, may_require_tmp
, true,
2823 dst_stat
, dst_type
);
2824 if (GFC_DESCRIPTOR_DATA (&temp
))
2825 free (GFC_DESCRIPTOR_DATA (&temp
));
2830 _gfortran_caf_atomic_define (caf_token_t token
, size_t offset
,
2831 int image_index
__attribute__ ((unused
)),
2832 void *value
, int *stat
,
2833 int type
__attribute__ ((unused
)), int kind
)
2837 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2839 __atomic_store (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2846 _gfortran_caf_atomic_ref (caf_token_t token
, size_t offset
,
2847 int image_index
__attribute__ ((unused
)),
2848 void *value
, int *stat
,
2849 int type
__attribute__ ((unused
)), int kind
)
2853 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2855 __atomic_load (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2863 _gfortran_caf_atomic_cas (caf_token_t token
, size_t offset
,
2864 int image_index
__attribute__ ((unused
)),
2865 void *old
, void *compare
, void *new_val
, int *stat
,
2866 int type
__attribute__ ((unused
)), int kind
)
2870 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2872 *(uint32_t *) old
= *(uint32_t *) compare
;
2873 (void) __atomic_compare_exchange_n (atom
, (uint32_t *) old
,
2874 *(uint32_t *) new_val
, false,
2875 __ATOMIC_RELAXED
, __ATOMIC_RELAXED
);
2882 _gfortran_caf_atomic_op (int op
, caf_token_t token
, size_t offset
,
2883 int image_index
__attribute__ ((unused
)),
2884 void *value
, void *old
, int *stat
,
2885 int type
__attribute__ ((unused
)), int kind
)
2890 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2894 case GFC_CAF_ATOMIC_ADD
:
2895 res
= __atomic_fetch_add (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2897 case GFC_CAF_ATOMIC_AND
:
2898 res
= __atomic_fetch_and (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2900 case GFC_CAF_ATOMIC_OR
:
2901 res
= __atomic_fetch_or (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2903 case GFC_CAF_ATOMIC_XOR
:
2904 res
= __atomic_fetch_xor (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2907 __builtin_unreachable();
2911 *(uint32_t *) old
= res
;
2918 _gfortran_caf_event_post (caf_token_t token
, size_t index
,
2919 int image_index
__attribute__ ((unused
)),
2920 int *stat
, char *errmsg
__attribute__ ((unused
)),
2921 size_t errmsg_len
__attribute__ ((unused
)))
2924 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2925 * sizeof (uint32_t));
2926 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2933 _gfortran_caf_event_wait (caf_token_t token
, size_t index
,
2934 int until_count
, int *stat
,
2935 char *errmsg
__attribute__ ((unused
)),
2936 size_t errmsg_len
__attribute__ ((unused
)))
2938 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2939 * sizeof (uint32_t));
2940 uint32_t value
= (uint32_t)-until_count
;
2941 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2948 _gfortran_caf_event_query (caf_token_t token
, size_t index
,
2949 int image_index
__attribute__ ((unused
)),
2950 int *count
, int *stat
)
2952 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2953 * sizeof (uint32_t));
2954 __atomic_load (event
, (uint32_t *) count
, __ATOMIC_RELAXED
);
2961 _gfortran_caf_lock (caf_token_t token
, size_t index
,
2962 int image_index
__attribute__ ((unused
)),
2963 int *acquired_lock
, int *stat
, char *errmsg
,
2966 const char *msg
= "Already locked";
2967 bool *lock
= &((bool *) MEMTOK (token
))[index
];
2973 *acquired_lock
= (int) true;
2981 *acquired_lock
= (int) false;
2993 size_t len
= (sizeof (msg
) > errmsg_len
) ? errmsg_len
2995 memcpy (errmsg
, msg
, len
);
2996 if (errmsg_len
> len
)
2997 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
3001 _gfortran_caf_error_stop_str (msg
, strlen (msg
), false);
3006 _gfortran_caf_unlock (caf_token_t token
, size_t index
,
3007 int image_index
__attribute__ ((unused
)),
3008 int *stat
, char *errmsg
, size_t errmsg_len
)
3010 const char *msg
= "Variable is not locked";
3011 bool *lock
= &((bool *) MEMTOK (token
))[index
];
3026 size_t len
= (sizeof (msg
) > errmsg_len
) ? errmsg_len
3028 memcpy (errmsg
, msg
, len
);
3029 if (errmsg_len
> len
)
3030 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
3034 _gfortran_caf_error_stop_str (msg
, strlen (msg
), false);
3038 _gfortran_caf_is_present (caf_token_t token
,
3039 int image_index
__attribute__ ((unused
)),
3040 caf_reference_t
*refs
)
3042 const char arraddressingnotallowed
[] = "libcaf_single::caf_is_present(): "
3043 "only scalar indexes allowed.\n";
3044 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
3045 "unknown reference type.\n";
3046 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
3047 "unknown array reference type.\n";
3049 caf_single_token_t single_token
= TOKEN (token
);
3050 void *memptr
= single_token
->memptr
;
3051 gfc_descriptor_t
*src
= single_token
->desc
;
3052 caf_reference_t
*riter
= refs
;
3056 switch (riter
->type
)
3058 case CAF_REF_COMPONENT
:
3059 if (riter
->u
.c
.caf_token_offset
)
3061 single_token
= *(caf_single_token_t
*)
3062 (memptr
+ riter
->u
.c
.caf_token_offset
);
3063 memptr
= single_token
->memptr
;
3064 src
= single_token
->desc
;
3068 memptr
+= riter
->u
.c
.offset
;
3069 src
= (gfc_descriptor_t
*)memptr
;
3073 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3075 switch (riter
->u
.a
.mode
[i
])
3077 case CAF_ARR_REF_SINGLE
:
3078 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
3079 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
3080 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
3083 case CAF_ARR_REF_FULL
:
3084 /* A full array ref is allowed on the last reference only. */
3085 if (riter
->next
== NULL
)
3087 /* else fall through reporting an error. */
3089 case CAF_ARR_REF_VECTOR
:
3090 case CAF_ARR_REF_RANGE
:
3091 case CAF_ARR_REF_OPEN_END
:
3092 case CAF_ARR_REF_OPEN_START
:
3093 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3096 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3101 case CAF_REF_STATIC_ARRAY
:
3102 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3104 switch (riter
->u
.a
.mode
[i
])
3106 case CAF_ARR_REF_SINGLE
:
3107 memptr
+= riter
->u
.a
.dim
[i
].s
.start
3108 * riter
->u
.a
.dim
[i
].s
.stride
3111 case CAF_ARR_REF_FULL
:
3112 /* A full array ref is allowed on the last reference only. */
3113 if (riter
->next
== NULL
)
3115 /* else fall through reporting an error. */
3117 case CAF_ARR_REF_VECTOR
:
3118 case CAF_ARR_REF_RANGE
:
3119 case CAF_ARR_REF_OPEN_END
:
3120 case CAF_ARR_REF_OPEN_START
:
3121 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3124 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3130 caf_internal_error (unknownreftype
, 0, NULL
, 0);
3133 riter
= riter
->next
;
3135 return memptr
!= NULL
;
3138 /* Reference the libraries implementation. */
3139 extern void _gfortran_random_init (int32_t, int32_t, int32_t);
3141 void _gfortran_caf_random_init (bool repeatable
, bool image_distinct
)
3143 /* In a single image implementation always forward to the gfortran
3145 _gfortran_random_init (repeatable
, image_distinct
, 1);