1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2024 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
7 Libcaf is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
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. */
168 caf_internal_error (alloc_fail_msg
, stat
, errmsg
, errmsg_len
);
172 single_token
= TOKEN (*token
);
173 single_token
->memptr
= local
;
174 single_token
->owning_memory
= type
!= CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
;
175 single_token
->desc
= GFC_DESCRIPTOR_RANK (data
) > 0 ? data
: NULL
;
181 if (type
== CAF_REGTYPE_COARRAY_STATIC
|| type
== CAF_REGTYPE_LOCK_STATIC
182 || type
== CAF_REGTYPE_CRITICAL
|| type
== CAF_REGTYPE_EVENT_STATIC
183 || type
== CAF_REGTYPE_EVENT_ALLOC
)
185 caf_static_t
*tmp
= malloc (sizeof (caf_static_t
));
186 tmp
->prev
= caf_static_list
;
188 caf_static_list
= tmp
;
190 GFC_DESCRIPTOR_DATA (data
) = local
;
195 _gfortran_caf_deregister (caf_token_t
*token
, caf_deregister_t type
, int *stat
,
196 char *errmsg
__attribute__ ((unused
)),
197 size_t errmsg_len
__attribute__ ((unused
)))
199 caf_single_token_t single_token
= TOKEN (*token
);
201 if (single_token
->owning_memory
&& single_token
->memptr
)
202 free (single_token
->memptr
);
204 if (type
!= CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY
)
206 free (TOKEN (*token
));
211 single_token
->memptr
= NULL
;
212 single_token
->owning_memory
= false;
221 _gfortran_caf_sync_all (int *stat
,
222 char *errmsg
__attribute__ ((unused
)),
223 size_t errmsg_len
__attribute__ ((unused
)))
225 __asm__
__volatile__ ("":::"memory");
232 _gfortran_caf_sync_memory (int *stat
,
233 char *errmsg
__attribute__ ((unused
)),
234 size_t errmsg_len
__attribute__ ((unused
)))
236 __asm__
__volatile__ ("":::"memory");
243 _gfortran_caf_sync_images (int count
__attribute__ ((unused
)),
244 int images
[] __attribute__ ((unused
)),
246 char *errmsg
__attribute__ ((unused
)),
247 size_t errmsg_len
__attribute__ ((unused
)))
252 for (i
= 0; i
< count
; i
++)
255 fprintf (stderr
, "COARRAY ERROR: Invalid image index %d to SYNC "
256 "IMAGES", images
[i
]);
261 __asm__
__volatile__ ("":::"memory");
268 _gfortran_caf_stop_numeric(int stop_code
, bool quiet
)
271 fprintf (stderr
, "STOP %d\n", stop_code
);
277 _gfortran_caf_stop_str(const char *string
, size_t len
, bool quiet
)
281 fputs ("STOP ", stderr
);
283 fputc (*(string
++), stderr
);
284 fputs ("\n", stderr
);
291 _gfortran_caf_error_stop_str (const char *string
, size_t len
, bool quiet
)
295 fputs ("ERROR STOP ", stderr
);
297 fputc (*(string
++), stderr
);
298 fputs ("\n", stderr
);
304 /* Reported that the program terminated because of a fail image issued.
305 Because this is a single image library, nothing else than aborting the whole
306 program can be done. */
308 void _gfortran_caf_fail_image (void)
310 fputs ("IMAGE FAILED!\n", stderr
);
315 /* Get the status of image IMAGE. Because being the single image library all
316 other images are reported to be stopped. */
318 int _gfortran_caf_image_status (int image
,
319 caf_team_t
* team
__attribute__ ((unused
)))
324 return CAF_STAT_STOPPED_IMAGE
;
328 /* Single image library. There cannot be any failed images with only one
332 _gfortran_caf_failed_images (gfc_descriptor_t
*array
,
333 caf_team_t
* team
__attribute__ ((unused
)),
336 int local_kind
= kind
!= NULL
? *kind
: 4;
338 array
->base_addr
= NULL
;
339 array
->dtype
.type
= BT_INTEGER
;
340 array
->dtype
.elem_len
= local_kind
;
341 /* Setting lower_bound higher then upper_bound is what the compiler does to
342 indicate an empty array. */
343 array
->dim
[0].lower_bound
= 0;
344 array
->dim
[0]._ubound
= -1;
345 array
->dim
[0]._stride
= 1;
350 /* With only one image available no other images can be stopped. Therefore
351 return an empty array. */
354 _gfortran_caf_stopped_images (gfc_descriptor_t
*array
,
355 caf_team_t
* team
__attribute__ ((unused
)),
358 int local_kind
= kind
!= NULL
? *kind
: 4;
360 array
->base_addr
= NULL
;
361 array
->dtype
.type
= BT_INTEGER
;
362 array
->dtype
.elem_len
= local_kind
;
363 /* Setting lower_bound higher then upper_bound is what the compiler does to
364 indicate an empty array. */
365 array
->dim
[0].lower_bound
= 0;
366 array
->dim
[0]._ubound
= -1;
367 array
->dim
[0]._stride
= 1;
373 _gfortran_caf_error_stop (int error
, bool quiet
)
376 fprintf (stderr
, "ERROR STOP %d\n", error
);
382 _gfortran_caf_co_broadcast (gfc_descriptor_t
*a
__attribute__ ((unused
)),
383 int source_image
__attribute__ ((unused
)),
384 int *stat
, char *errmsg
__attribute__ ((unused
)),
385 size_t errmsg_len
__attribute__ ((unused
)))
392 _gfortran_caf_co_sum (gfc_descriptor_t
*a
__attribute__ ((unused
)),
393 int result_image
__attribute__ ((unused
)),
394 int *stat
, char *errmsg
__attribute__ ((unused
)),
395 size_t errmsg_len
__attribute__ ((unused
)))
402 _gfortran_caf_co_min (gfc_descriptor_t
*a
__attribute__ ((unused
)),
403 int result_image
__attribute__ ((unused
)),
404 int *stat
, char *errmsg
__attribute__ ((unused
)),
405 int a_len
__attribute__ ((unused
)),
406 size_t errmsg_len
__attribute__ ((unused
)))
413 _gfortran_caf_co_max (gfc_descriptor_t
*a
__attribute__ ((unused
)),
414 int result_image
__attribute__ ((unused
)),
415 int *stat
, char *errmsg
__attribute__ ((unused
)),
416 int a_len
__attribute__ ((unused
)),
417 size_t errmsg_len
__attribute__ ((unused
)))
425 _gfortran_caf_co_reduce (gfc_descriptor_t
*a
__attribute__ ((unused
)),
426 void * (*opr
) (void *, void *)
427 __attribute__ ((unused
)),
428 int opr_flags
__attribute__ ((unused
)),
429 int result_image
__attribute__ ((unused
)),
430 int *stat
, char *errmsg
__attribute__ ((unused
)),
431 int a_len
__attribute__ ((unused
)),
432 size_t errmsg_len
__attribute__ ((unused
)))
440 assign_char4_from_char1 (size_t dst_size
, size_t src_size
, uint32_t *dst
,
444 n
= dst_size
/4 > src_size
? src_size
: dst_size
/4;
445 for (i
= 0; i
< n
; ++i
)
446 dst
[i
] = (int32_t) src
[i
];
447 for (; i
< dst_size
/4; ++i
)
448 dst
[i
] = (int32_t) ' ';
453 assign_char1_from_char4 (size_t dst_size
, size_t src_size
, unsigned char *dst
,
457 n
= dst_size
> src_size
/4 ? src_size
/4 : dst_size
;
458 for (i
= 0; i
< n
; ++i
)
459 dst
[i
] = src
[i
] > UINT8_MAX
? (unsigned char) '?' : (unsigned char) src
[i
];
461 memset (&dst
[n
], ' ', dst_size
- n
);
466 convert_type (void *dst
, int dst_type
, int dst_kind
, void *src
, int src_type
,
467 int src_kind
, int *stat
)
469 #ifdef HAVE_GFC_INTEGER_16
470 typedef __int128 int128t
;
472 typedef int64_t int128t
;
475 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
476 typedef long double real128t
;
477 typedef _Complex
long double complex128t
;
478 #elif defined(HAVE_GFC_REAL_16)
479 typedef _Float128 real128t
;
480 typedef _Complex _Float128 complex128t
;
481 #elif defined(HAVE_GFC_REAL_10)
482 typedef long double real128t
;
483 typedef _Complex
long double complex128t
;
485 typedef double real128t
;
486 typedef _Complex
double complex128t
;
490 real128t real_val
= 0;
491 complex128t cmpx_val
= 0;
497 int_val
= *(int8_t*) src
;
498 else if (src_kind
== 2)
499 int_val
= *(int16_t*) src
;
500 else if (src_kind
== 4)
501 int_val
= *(int32_t*) src
;
502 else if (src_kind
== 8)
503 int_val
= *(int64_t*) src
;
504 #ifdef HAVE_GFC_INTEGER_16
505 else if (src_kind
== 16)
506 int_val
= *(int128t
*) src
;
513 real_val
= *(float*) src
;
514 else if (src_kind
== 8)
515 real_val
= *(double*) src
;
516 #ifdef HAVE_GFC_REAL_10
517 else if (src_kind
== 10)
518 real_val
= *(long double*) src
;
520 #ifdef HAVE_GFC_REAL_16
521 else if (src_kind
== 16)
522 real_val
= *(real128t
*) src
;
529 cmpx_val
= *(_Complex
float*) src
;
530 else if (src_kind
== 8)
531 cmpx_val
= *(_Complex
double*) src
;
532 #ifdef HAVE_GFC_REAL_10
533 else if (src_kind
== 10)
534 cmpx_val
= *(_Complex
long double*) src
;
536 #ifdef HAVE_GFC_REAL_16
537 else if (src_kind
== 16)
538 cmpx_val
= *(complex128t
*) src
;
550 if (src_type
== BT_INTEGER
)
553 *(int8_t*) dst
= (int8_t) int_val
;
554 else if (dst_kind
== 2)
555 *(int16_t*) dst
= (int16_t) int_val
;
556 else if (dst_kind
== 4)
557 *(int32_t*) dst
= (int32_t) int_val
;
558 else if (dst_kind
== 8)
559 *(int64_t*) dst
= (int64_t) int_val
;
560 #ifdef HAVE_GFC_INTEGER_16
561 else if (dst_kind
== 16)
562 *(int128t
*) dst
= (int128t
) int_val
;
567 else if (src_type
== BT_REAL
)
570 *(int8_t*) dst
= (int8_t) real_val
;
571 else if (dst_kind
== 2)
572 *(int16_t*) dst
= (int16_t) real_val
;
573 else if (dst_kind
== 4)
574 *(int32_t*) dst
= (int32_t) real_val
;
575 else if (dst_kind
== 8)
576 *(int64_t*) dst
= (int64_t) real_val
;
577 #ifdef HAVE_GFC_INTEGER_16
578 else if (dst_kind
== 16)
579 *(int128t
*) dst
= (int128t
) real_val
;
584 else if (src_type
== BT_COMPLEX
)
587 *(int8_t*) dst
= (int8_t) cmpx_val
;
588 else if (dst_kind
== 2)
589 *(int16_t*) dst
= (int16_t) cmpx_val
;
590 else if (dst_kind
== 4)
591 *(int32_t*) dst
= (int32_t) cmpx_val
;
592 else if (dst_kind
== 8)
593 *(int64_t*) dst
= (int64_t) cmpx_val
;
594 #ifdef HAVE_GFC_INTEGER_16
595 else if (dst_kind
== 16)
596 *(int128t
*) dst
= (int128t
) cmpx_val
;
605 if (src_type
== BT_INTEGER
)
608 *(float*) dst
= (float) int_val
;
609 else if (dst_kind
== 8)
610 *(double*) dst
= (double) int_val
;
611 #ifdef HAVE_GFC_REAL_10
612 else if (dst_kind
== 10)
613 *(long double*) dst
= (long double) int_val
;
615 #ifdef HAVE_GFC_REAL_16
616 else if (dst_kind
== 16)
617 *(real128t
*) dst
= (real128t
) int_val
;
622 else if (src_type
== BT_REAL
)
625 *(float*) dst
= (float) real_val
;
626 else if (dst_kind
== 8)
627 *(double*) dst
= (double) real_val
;
628 #ifdef HAVE_GFC_REAL_10
629 else if (dst_kind
== 10)
630 *(long double*) dst
= (long double) real_val
;
632 #ifdef HAVE_GFC_REAL_16
633 else if (dst_kind
== 16)
634 *(real128t
*) dst
= (real128t
) real_val
;
639 else if (src_type
== BT_COMPLEX
)
642 *(float*) dst
= (float) cmpx_val
;
643 else if (dst_kind
== 8)
644 *(double*) dst
= (double) cmpx_val
;
645 #ifdef HAVE_GFC_REAL_10
646 else if (dst_kind
== 10)
647 *(long double*) dst
= (long double) cmpx_val
;
649 #ifdef HAVE_GFC_REAL_16
650 else if (dst_kind
== 16)
651 *(real128t
*) dst
= (real128t
) cmpx_val
;
658 if (src_type
== BT_INTEGER
)
661 *(_Complex
float*) dst
= (_Complex
float) int_val
;
662 else if (dst_kind
== 8)
663 *(_Complex
double*) dst
= (_Complex
double) int_val
;
664 #ifdef HAVE_GFC_REAL_10
665 else if (dst_kind
== 10)
666 *(_Complex
long double*) dst
= (_Complex
long double) int_val
;
668 #ifdef HAVE_GFC_REAL_16
669 else if (dst_kind
== 16)
670 *(complex128t
*) dst
= (complex128t
) int_val
;
675 else if (src_type
== BT_REAL
)
678 *(_Complex
float*) dst
= (_Complex
float) real_val
;
679 else if (dst_kind
== 8)
680 *(_Complex
double*) dst
= (_Complex
double) real_val
;
681 #ifdef HAVE_GFC_REAL_10
682 else if (dst_kind
== 10)
683 *(_Complex
long double*) dst
= (_Complex
long double) real_val
;
685 #ifdef HAVE_GFC_REAL_16
686 else if (dst_kind
== 16)
687 *(complex128t
*) dst
= (complex128t
) real_val
;
692 else if (src_type
== BT_COMPLEX
)
695 *(_Complex
float*) dst
= (_Complex
float) cmpx_val
;
696 else if (dst_kind
== 8)
697 *(_Complex
double*) dst
= (_Complex
double) cmpx_val
;
698 #ifdef HAVE_GFC_REAL_10
699 else if (dst_kind
== 10)
700 *(_Complex
long double*) dst
= (_Complex
long double) cmpx_val
;
702 #ifdef HAVE_GFC_REAL_16
703 else if (dst_kind
== 16)
704 *(complex128t
*) dst
= (complex128t
) cmpx_val
;
717 fprintf (stderr
, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
718 "%d to type %d kind %d\n", src_type
, src_kind
, dst_type
, dst_kind
);
727 _gfortran_caf_get (caf_token_t token
, size_t offset
,
728 int image_index
__attribute__ ((unused
)),
729 gfc_descriptor_t
*src
,
730 caf_vector_t
*src_vector
__attribute__ ((unused
)),
731 gfc_descriptor_t
*dest
, int src_kind
, int dst_kind
,
732 bool may_require_tmp
, int *stat
)
734 /* FIXME: Handle vector subscripts. */
737 int rank
= GFC_DESCRIPTOR_RANK (dest
);
738 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
739 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
746 void *sr
= (void *) ((char *) MEMTOK (token
) + offset
);
747 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
748 && dst_kind
== src_kind
)
750 memmove (GFC_DESCRIPTOR_DATA (dest
), sr
,
751 dst_size
> src_size
? src_size
: dst_size
);
752 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
755 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest
) + src_size
,
756 ' ', dst_size
- src_size
);
757 else /* dst_kind == 4. */
758 for (i
= src_size
/4; i
< dst_size
/4; i
++)
759 ((int32_t*) GFC_DESCRIPTOR_DATA (dest
))[i
] = (int32_t) ' ';
762 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
763 assign_char1_from_char4 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
765 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
766 assign_char4_from_char1 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
769 convert_type (GFC_DESCRIPTOR_DATA (dest
), GFC_DESCRIPTOR_TYPE (dest
),
770 dst_kind
, sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
775 for (j
= 0; j
< rank
; j
++)
777 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
788 ptrdiff_t array_offset_sr
, array_offset_dst
;
789 void *tmp
= malloc (size
*src_size
);
791 array_offset_dst
= 0;
792 for (i
= 0; i
< size
; i
++)
794 ptrdiff_t array_offset_sr
= 0;
795 ptrdiff_t stride
= 1;
796 ptrdiff_t extent
= 1;
797 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
799 array_offset_sr
+= ((i
/ (extent
*stride
))
800 % (src
->dim
[j
]._ubound
801 - src
->dim
[j
].lower_bound
+ 1))
802 * src
->dim
[j
]._stride
;
803 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
804 stride
= src
->dim
[j
]._stride
;
806 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
807 void *sr
= (void *)((char *) MEMTOK (token
) + offset
808 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
809 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
810 array_offset_dst
+= src_size
;
814 for (i
= 0; i
< size
; i
++)
816 ptrdiff_t array_offset_dst
= 0;
817 ptrdiff_t stride
= 1;
818 ptrdiff_t extent
= 1;
819 for (j
= 0; j
< rank
-1; j
++)
821 array_offset_dst
+= ((i
/ (extent
*stride
))
822 % (dest
->dim
[j
]._ubound
823 - dest
->dim
[j
].lower_bound
+ 1))
824 * dest
->dim
[j
]._stride
;
825 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
826 stride
= dest
->dim
[j
]._stride
;
828 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
829 void *dst
= dest
->base_addr
830 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
831 void *sr
= tmp
+ array_offset_sr
;
833 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
834 && dst_kind
== src_kind
)
836 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
837 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
838 && dst_size
> src_size
)
841 memset ((void*)(char*) dst
+ src_size
, ' ',
843 else /* dst_kind == 4. */
844 for (k
= src_size
/4; k
< dst_size
/4; k
++)
845 ((int32_t*) dst
)[k
] = (int32_t) ' ';
848 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
849 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
850 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
851 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
853 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
854 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
855 array_offset_sr
+= src_size
;
862 for (i
= 0; i
< size
; i
++)
864 ptrdiff_t array_offset_dst
= 0;
865 ptrdiff_t stride
= 1;
866 ptrdiff_t extent
= 1;
867 for (j
= 0; j
< rank
-1; j
++)
869 array_offset_dst
+= ((i
/ (extent
*stride
))
870 % (dest
->dim
[j
]._ubound
871 - dest
->dim
[j
].lower_bound
+ 1))
872 * dest
->dim
[j
]._stride
;
873 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
874 stride
= dest
->dim
[j
]._stride
;
876 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
877 void *dst
= dest
->base_addr
+ array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
879 ptrdiff_t array_offset_sr
= 0;
882 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
884 array_offset_sr
+= ((i
/ (extent
*stride
))
885 % (src
->dim
[j
]._ubound
886 - src
->dim
[j
].lower_bound
+ 1))
887 * src
->dim
[j
]._stride
;
888 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
889 stride
= src
->dim
[j
]._stride
;
891 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
892 void *sr
= (void *)((char *) MEMTOK (token
) + offset
893 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
895 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
896 && dst_kind
== src_kind
)
898 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
899 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
902 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
903 else /* dst_kind == 4. */
904 for (k
= src_size
/4; k
< dst_size
/4; k
++)
905 ((int32_t*) dst
)[k
] = (int32_t) ' ';
908 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
909 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
910 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
911 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
913 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
914 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
920 _gfortran_caf_send (caf_token_t token
, size_t offset
,
921 int image_index
__attribute__ ((unused
)),
922 gfc_descriptor_t
*dest
,
923 caf_vector_t
*dst_vector
__attribute__ ((unused
)),
924 gfc_descriptor_t
*src
, int dst_kind
, int src_kind
,
925 bool may_require_tmp
, int *stat
)
927 /* FIXME: Handle vector subscripts. */
930 int rank
= GFC_DESCRIPTOR_RANK (dest
);
931 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
932 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
939 void *dst
= (void *) ((char *) MEMTOK (token
) + offset
);
940 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
941 && dst_kind
== src_kind
)
943 memmove (dst
, GFC_DESCRIPTOR_DATA (src
),
944 dst_size
> src_size
? src_size
: dst_size
);
945 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
948 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
949 else /* dst_kind == 4. */
950 for (i
= src_size
/4; i
< dst_size
/4; i
++)
951 ((int32_t*) dst
)[i
] = (int32_t) ' ';
954 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
955 assign_char1_from_char4 (dst_size
, src_size
, dst
,
956 GFC_DESCRIPTOR_DATA (src
));
957 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
958 assign_char4_from_char1 (dst_size
, src_size
, dst
,
959 GFC_DESCRIPTOR_DATA (src
));
961 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
962 GFC_DESCRIPTOR_DATA (src
), GFC_DESCRIPTOR_TYPE (src
),
968 for (j
= 0; j
< rank
; j
++)
970 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
981 ptrdiff_t array_offset_sr
, array_offset_dst
;
984 if (GFC_DESCRIPTOR_RANK (src
) == 0)
986 tmp
= malloc (src_size
);
987 memcpy (tmp
, GFC_DESCRIPTOR_DATA (src
), src_size
);
991 tmp
= malloc (size
*src_size
);
992 array_offset_dst
= 0;
993 for (i
= 0; i
< size
; i
++)
995 ptrdiff_t array_offset_sr
= 0;
996 ptrdiff_t stride
= 1;
997 ptrdiff_t extent
= 1;
998 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
1000 array_offset_sr
+= ((i
/ (extent
*stride
))
1001 % (src
->dim
[j
]._ubound
1002 - src
->dim
[j
].lower_bound
+ 1))
1003 * src
->dim
[j
]._stride
;
1004 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
1005 stride
= src
->dim
[j
]._stride
;
1007 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
1008 void *sr
= (void *) ((char *) src
->base_addr
1009 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
1010 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
1011 array_offset_dst
+= src_size
;
1015 array_offset_sr
= 0;
1016 for (i
= 0; i
< size
; i
++)
1018 ptrdiff_t array_offset_dst
= 0;
1019 ptrdiff_t stride
= 1;
1020 ptrdiff_t extent
= 1;
1021 for (j
= 0; j
< rank
-1; j
++)
1023 array_offset_dst
+= ((i
/ (extent
*stride
))
1024 % (dest
->dim
[j
]._ubound
1025 - dest
->dim
[j
].lower_bound
+ 1))
1026 * dest
->dim
[j
]._stride
;
1027 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
1028 stride
= dest
->dim
[j
]._stride
;
1030 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
1031 void *dst
= (void *)((char *) MEMTOK (token
) + offset
1032 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
1033 void *sr
= tmp
+ array_offset_sr
;
1034 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
1035 && dst_kind
== src_kind
)
1038 dst_size
> src_size
? src_size
: dst_size
);
1039 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
1040 && dst_size
> src_size
)
1043 memset ((void*)(char*) dst
+ src_size
, ' ',
1045 else /* dst_kind == 4. */
1046 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1047 ((int32_t*) dst
)[k
] = (int32_t) ' ';
1050 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
1051 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
1052 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
1053 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
1055 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
1056 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
1057 if (GFC_DESCRIPTOR_RANK (src
))
1058 array_offset_sr
+= src_size
;
1064 for (i
= 0; i
< size
; i
++)
1066 ptrdiff_t array_offset_dst
= 0;
1067 ptrdiff_t stride
= 1;
1068 ptrdiff_t extent
= 1;
1069 for (j
= 0; j
< rank
-1; j
++)
1071 array_offset_dst
+= ((i
/ (extent
*stride
))
1072 % (dest
->dim
[j
]._ubound
1073 - dest
->dim
[j
].lower_bound
+ 1))
1074 * dest
->dim
[j
]._stride
;
1075 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
1076 stride
= dest
->dim
[j
]._stride
;
1078 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
1079 void *dst
= (void *)((char *) MEMTOK (token
) + offset
1080 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
1082 if (GFC_DESCRIPTOR_RANK (src
) != 0)
1084 ptrdiff_t array_offset_sr
= 0;
1087 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
1089 array_offset_sr
+= ((i
/ (extent
*stride
))
1090 % (src
->dim
[j
]._ubound
1091 - src
->dim
[j
].lower_bound
+ 1))
1092 * src
->dim
[j
]._stride
;
1093 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
1094 stride
= src
->dim
[j
]._stride
;
1096 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
1097 sr
= (void *)((char *) src
->base_addr
1098 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
1101 sr
= src
->base_addr
;
1103 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
1104 && dst_kind
== src_kind
)
1107 dst_size
> src_size
? src_size
: dst_size
);
1108 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
1111 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
1112 else /* dst_kind == 4. */
1113 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1114 ((int32_t*) dst
)[k
] = (int32_t) ' ';
1117 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
1118 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
1119 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
1120 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
1122 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
1123 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
, stat
);
1129 _gfortran_caf_sendget (caf_token_t dst_token
, size_t dst_offset
,
1130 int dst_image_index
, gfc_descriptor_t
*dest
,
1131 caf_vector_t
*dst_vector
, caf_token_t src_token
,
1133 int src_image_index
__attribute__ ((unused
)),
1134 gfc_descriptor_t
*src
,
1135 caf_vector_t
*src_vector
__attribute__ ((unused
)),
1136 int dst_kind
, int src_kind
, bool may_require_tmp
)
1138 /* FIXME: Handle vector subscript of 'src_vector'. */
1139 /* For a single image, src->base_addr should be the same as src_token + offset
1140 but to play save, we do it properly. */
1141 void *src_base
= GFC_DESCRIPTOR_DATA (src
);
1142 GFC_DESCRIPTOR_DATA (src
) = (void *) ((char *) MEMTOK (src_token
)
1144 _gfortran_caf_send (dst_token
, dst_offset
, dst_image_index
, dest
, dst_vector
,
1145 src
, dst_kind
, src_kind
, may_require_tmp
, NULL
);
1146 GFC_DESCRIPTOR_DATA (src
) = src_base
;
1150 /* Emitted when a theorectically unreachable part is reached. */
1151 const char unreachable
[] = "Fatal error: unreachable alternative found.\n";
1155 copy_data (void *ds
, void *sr
, int dst_type
, int src_type
,
1156 int dst_kind
, int src_kind
, size_t dst_size
, size_t src_size
,
1157 size_t num
, int *stat
)
1160 if (dst_type
== src_type
&& dst_kind
== src_kind
)
1162 memmove (ds
, sr
, (dst_size
> src_size
? src_size
: dst_size
) * num
);
1163 if ((dst_type
== BT_CHARACTER
|| src_type
== BT_CHARACTER
)
1164 && dst_size
> src_size
)
1167 memset ((void*)(char*) ds
+ src_size
, ' ', dst_size
-src_size
);
1168 else /* dst_kind == 4. */
1169 for (k
= src_size
/4; k
< dst_size
/4; k
++)
1170 ((int32_t*) ds
)[k
] = (int32_t) ' ';
1173 else if (dst_type
== BT_CHARACTER
&& dst_kind
== 1)
1174 assign_char1_from_char4 (dst_size
, src_size
, ds
, sr
);
1175 else if (dst_type
== BT_CHARACTER
)
1176 assign_char4_from_char1 (dst_size
, src_size
, ds
, sr
);
1178 for (k
= 0; k
< num
; ++k
)
1180 convert_type (ds
, dst_type
, dst_kind
, sr
, src_type
, src_kind
, stat
);
1187 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1189 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1190 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1191 if (num <= 0 || abs_stride < 1) return; \
1192 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1197 get_for_ref (caf_reference_t
*ref
, size_t *i
, size_t *dst_index
,
1198 caf_single_token_t single_token
, gfc_descriptor_t
*dst
,
1199 gfc_descriptor_t
*src
, void *ds
, void *sr
,
1200 int dst_kind
, int src_kind
, size_t dst_dim
, size_t src_dim
,
1201 size_t num
, int *stat
, int src_type
)
1203 ptrdiff_t extent_src
= 1, array_offset_src
= 0, stride_src
;
1204 size_t next_dst_dim
;
1206 if (unlikely (ref
== NULL
))
1207 /* May be we should issue an error here, because this case should not
1211 if (ref
->next
== NULL
)
1213 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dst
);
1214 ptrdiff_t array_offset_dst
= 0;;
1215 size_t dst_rank
= GFC_DESCRIPTOR_RANK (dst
);
1219 case CAF_REF_COMPONENT
:
1220 /* Because the token is always registered after the component, its
1221 offset is always greater zero. */
1222 if (ref
->u
.c
.caf_token_offset
> 0)
1223 /* Note, that sr is dereffed here. */
1224 copy_data (ds
, *(void **)(sr
+ ref
->u
.c
.offset
),
1225 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1226 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1228 copy_data (ds
, sr
+ ref
->u
.c
.offset
,
1229 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1230 dst_kind
, src_kind
, dst_size
, ref
->item_size
, 1, stat
);
1233 case CAF_REF_STATIC_ARRAY
:
1234 /* Intentionally fall through. */
1236 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1238 for (size_t d
= 0; d
< dst_rank
; ++d
)
1239 array_offset_dst
+= dst_index
[d
];
1240 copy_data (ds
+ array_offset_dst
* dst_size
, sr
,
1241 GFC_DESCRIPTOR_TYPE (dst
), src_type
,
1242 dst_kind
, src_kind
, dst_size
, ref
->item_size
, num
,
1249 caf_runtime_error (unreachable
);
1255 case CAF_REF_COMPONENT
:
1256 if (ref
->u
.c
.caf_token_offset
> 0)
1258 single_token
= *(caf_single_token_t
*)(sr
+ ref
->u
.c
.caf_token_offset
);
1260 if (ref
->next
&& ref
->next
->type
== CAF_REF_ARRAY
)
1261 src
= single_token
->desc
;
1265 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
1266 /* The currently ref'ed component was allocatabe (caf_token_offset
1267 > 0) and the next ref is a component, too, then the new sr has to
1268 be dereffed. (static arrays cannot be allocatable or they
1269 become an array with descriptor. */
1270 sr
= *(void **)(sr
+ ref
->u
.c
.offset
);
1272 sr
+= ref
->u
.c
.offset
;
1274 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
, src
,
1275 ds
, sr
, dst_kind
, src_kind
, dst_dim
, 0,
1279 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1280 (gfc_descriptor_t
*)(sr
+ ref
->u
.c
.offset
), ds
,
1281 sr
+ ref
->u
.c
.offset
, dst_kind
, src_kind
, dst_dim
, 0, 1,
1285 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1287 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1288 src
, ds
, sr
, dst_kind
, src_kind
,
1289 dst_dim
, 0, 1, stat
, src_type
);
1292 /* Only when on the left most index switch the data pointer to
1293 the array's data pointer. */
1295 sr
= GFC_DESCRIPTOR_DATA (src
);
1296 switch (ref
->u
.a
.mode
[src_dim
])
1298 case CAF_ARR_REF_VECTOR
:
1299 extent_src
= GFC_DIMENSION_EXTENT (src
->dim
[src_dim
]);
1300 array_offset_src
= 0;
1301 dst_index
[dst_dim
] = 0;
1302 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1305 #define KINDCASE(kind, type) case kind: \
1306 array_offset_src = (((index_type) \
1307 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1308 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1309 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1312 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1314 KINDCASE (1, GFC_INTEGER_1
);
1315 KINDCASE (2, GFC_INTEGER_2
);
1316 KINDCASE (4, GFC_INTEGER_4
);
1317 #ifdef HAVE_GFC_INTEGER_8
1318 KINDCASE (8, GFC_INTEGER_8
);
1320 #ifdef HAVE_GFC_INTEGER_16
1321 KINDCASE (16, GFC_INTEGER_16
);
1324 caf_runtime_error (unreachable
);
1329 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1330 ds
, sr
+ array_offset_src
* ref
->item_size
,
1331 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1334 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1337 case CAF_ARR_REF_FULL
:
1338 COMPUTE_NUM_ITEMS (extent_src
,
1339 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1340 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1341 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1342 stride_src
= src
->dim
[src_dim
]._stride
1343 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1344 array_offset_src
= 0;
1345 dst_index
[dst_dim
] = 0;
1346 for (index_type idx
= 0; idx
< extent_src
;
1347 ++idx
, array_offset_src
+= stride_src
)
1349 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1350 ds
, sr
+ array_offset_src
* ref
->item_size
,
1351 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1354 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1357 case CAF_ARR_REF_RANGE
:
1358 COMPUTE_NUM_ITEMS (extent_src
,
1359 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1360 ref
->u
.a
.dim
[src_dim
].s
.start
,
1361 ref
->u
.a
.dim
[src_dim
].s
.end
);
1362 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1363 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1364 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1365 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1366 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1367 dst_index
[dst_dim
] = 0;
1368 /* Increase the dst_dim only, when the src_extent is greater one
1369 or src and dst extent are both one. Don't increase when the scalar
1370 source is not present in the dst. */
1371 next_dst_dim
= extent_src
> 1
1372 || (GFC_DIMENSION_EXTENT (dst
->dim
[dst_dim
]) == 1
1373 && extent_src
== 1) ? (dst_dim
+ 1) : dst_dim
;
1374 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1376 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1377 ds
, sr
+ array_offset_src
* ref
->item_size
,
1378 dst_kind
, src_kind
, next_dst_dim
, src_dim
+ 1,
1381 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1382 array_offset_src
+= stride_src
;
1385 case CAF_ARR_REF_SINGLE
:
1386 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1387 - src
->dim
[src_dim
].lower_bound
)
1388 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1389 dst_index
[dst_dim
] = 0;
1390 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
, ds
,
1391 sr
+ array_offset_src
* ref
->item_size
,
1392 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1395 case CAF_ARR_REF_OPEN_END
:
1396 COMPUTE_NUM_ITEMS (extent_src
,
1397 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1398 ref
->u
.a
.dim
[src_dim
].s
.start
,
1399 GFC_DIMENSION_UBOUND (src
->dim
[src_dim
]));
1400 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1401 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1402 array_offset_src
= (ref
->u
.a
.dim
[src_dim
].s
.start
1403 - GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]))
1404 * GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
1405 dst_index
[dst_dim
] = 0;
1406 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1408 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1409 ds
, sr
+ array_offset_src
* ref
->item_size
,
1410 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1413 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1414 array_offset_src
+= stride_src
;
1417 case CAF_ARR_REF_OPEN_START
:
1418 COMPUTE_NUM_ITEMS (extent_src
,
1419 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1420 GFC_DIMENSION_LBOUND (src
->dim
[src_dim
]),
1421 ref
->u
.a
.dim
[src_dim
].s
.end
);
1422 stride_src
= GFC_DIMENSION_STRIDE (src
->dim
[src_dim
])
1423 * ref
->u
.a
.dim
[src_dim
].s
.stride
;
1424 array_offset_src
= 0;
1425 dst_index
[dst_dim
] = 0;
1426 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1428 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, src
,
1429 ds
, sr
+ array_offset_src
* ref
->item_size
,
1430 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1433 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1434 array_offset_src
+= stride_src
;
1438 caf_runtime_error (unreachable
);
1441 case CAF_REF_STATIC_ARRAY
:
1442 if (ref
->u
.a
.mode
[src_dim
] == CAF_ARR_REF_NONE
)
1444 get_for_ref (ref
->next
, i
, dst_index
, single_token
, dst
,
1445 NULL
, ds
, sr
, dst_kind
, src_kind
,
1446 dst_dim
, 0, 1, stat
, src_type
);
1449 switch (ref
->u
.a
.mode
[src_dim
])
1451 case CAF_ARR_REF_VECTOR
:
1452 array_offset_src
= 0;
1453 dst_index
[dst_dim
] = 0;
1454 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[src_dim
].v
.nvec
;
1457 #define KINDCASE(kind, type) case kind: \
1458 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1461 switch (ref
->u
.a
.dim
[src_dim
].v
.kind
)
1463 KINDCASE (1, GFC_INTEGER_1
);
1464 KINDCASE (2, GFC_INTEGER_2
);
1465 KINDCASE (4, GFC_INTEGER_4
);
1466 #ifdef HAVE_GFC_INTEGER_8
1467 KINDCASE (8, GFC_INTEGER_8
);
1469 #ifdef HAVE_GFC_INTEGER_16
1470 KINDCASE (16, GFC_INTEGER_16
);
1473 caf_runtime_error (unreachable
);
1478 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1479 ds
, sr
+ array_offset_src
* ref
->item_size
,
1480 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1483 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1486 case CAF_ARR_REF_FULL
:
1487 dst_index
[dst_dim
] = 0;
1488 for (array_offset_src
= 0 ;
1489 array_offset_src
<= ref
->u
.a
.dim
[src_dim
].s
.end
;
1490 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
)
1492 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1493 ds
, sr
+ array_offset_src
* ref
->item_size
,
1494 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1497 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1500 case CAF_ARR_REF_RANGE
:
1501 COMPUTE_NUM_ITEMS (extent_src
,
1502 ref
->u
.a
.dim
[src_dim
].s
.stride
,
1503 ref
->u
.a
.dim
[src_dim
].s
.start
,
1504 ref
->u
.a
.dim
[src_dim
].s
.end
);
1505 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1506 dst_index
[dst_dim
] = 0;
1507 for (index_type idx
= 0; idx
< extent_src
; ++idx
)
1509 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
,
1510 ds
, sr
+ array_offset_src
* ref
->item_size
,
1511 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
1514 += GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
1515 array_offset_src
+= ref
->u
.a
.dim
[src_dim
].s
.stride
;
1518 case CAF_ARR_REF_SINGLE
:
1519 array_offset_src
= ref
->u
.a
.dim
[src_dim
].s
.start
;
1520 get_for_ref (ref
, i
, dst_index
, single_token
, dst
, NULL
, ds
,
1521 sr
+ array_offset_src
* ref
->item_size
,
1522 dst_kind
, src_kind
, dst_dim
, src_dim
+ 1, 1,
1525 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
1526 case CAF_ARR_REF_OPEN_END
:
1527 case CAF_ARR_REF_OPEN_START
:
1529 caf_runtime_error (unreachable
);
1533 caf_runtime_error (unreachable
);
1539 _gfortran_caf_get_by_ref (caf_token_t token
,
1540 int image_index
__attribute__ ((unused
)),
1541 gfc_descriptor_t
*dst
, caf_reference_t
*refs
,
1542 int dst_kind
, int src_kind
,
1543 bool may_require_tmp
__attribute__ ((unused
)),
1544 bool dst_reallocatable
, int *stat
,
1547 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
1548 "unknown kind in vector-ref.\n";
1549 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
1550 "unknown reference type.\n";
1551 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
1552 "unknown array reference type.\n";
1553 const char rankoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1554 "rank out of range.\n";
1555 const char extentoutofrange
[] = "libcaf_single::caf_get_by_ref(): "
1556 "extent out of range.\n";
1557 const char cannotallocdst
[] = "libcaf_single::caf_get_by_ref(): "
1558 "cannot allocate memory.\n";
1559 const char nonallocextentmismatch
[] = "libcaf_single::caf_get_by_ref(): "
1560 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1561 const char doublearrayref
[] = "libcaf_single::caf_get_by_ref(): "
1562 "two or more array part references are not supported.\n";
1564 size_t dst_index
[GFC_MAX_DIMENSIONS
];
1565 int dst_rank
= GFC_DESCRIPTOR_RANK (dst
);
1566 int dst_cur_dim
= 0;
1567 size_t src_size
= 0;
1568 caf_single_token_t single_token
= TOKEN (token
);
1569 void *memptr
= single_token
->memptr
;
1570 gfc_descriptor_t
*src
= single_token
->desc
;
1571 caf_reference_t
*riter
= refs
;
1573 /* Reallocation of dst.data is needed (e.g., array to small). */
1574 bool realloc_needed
;
1575 /* Reallocation of dst.data is required, because data is not alloced at
1577 bool realloc_required
;
1578 bool extent_mismatch
= false;
1579 /* Set when the first non-scalar array reference is encountered. */
1580 bool in_array_ref
= false;
1581 bool array_extent_fixed
= false;
1582 realloc_needed
= realloc_required
= GFC_DESCRIPTOR_DATA (dst
) == NULL
;
1584 assert (!realloc_needed
|| dst_reallocatable
);
1589 /* Compute the size of the result. In the beginning size just counts the
1590 number of elements. */
1594 switch (riter
->type
)
1596 case CAF_REF_COMPONENT
:
1597 if (riter
->u
.c
.caf_token_offset
)
1599 single_token
= *(caf_single_token_t
*)
1600 (memptr
+ riter
->u
.c
.caf_token_offset
);
1601 memptr
= single_token
->memptr
;
1602 src
= single_token
->desc
;
1606 memptr
+= riter
->u
.c
.offset
;
1607 /* When the next ref is an array ref, assume there is an
1608 array descriptor at memptr. Note, static arrays do not have
1610 if (riter
->next
&& riter
->next
->type
== CAF_REF_ARRAY
)
1611 src
= (gfc_descriptor_t
*)memptr
;
1617 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1619 switch (riter
->u
.a
.mode
[i
])
1621 case CAF_ARR_REF_VECTOR
:
1622 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1623 #define KINDCASE(kind, type) case kind: \
1624 memptr += (((index_type) \
1625 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1626 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1627 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1628 * riter->item_size; \
1631 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1633 KINDCASE (1, GFC_INTEGER_1
);
1634 KINDCASE (2, GFC_INTEGER_2
);
1635 KINDCASE (4, GFC_INTEGER_4
);
1636 #ifdef HAVE_GFC_INTEGER_8
1637 KINDCASE (8, GFC_INTEGER_8
);
1639 #ifdef HAVE_GFC_INTEGER_16
1640 KINDCASE (16, GFC_INTEGER_16
);
1643 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1648 case CAF_ARR_REF_FULL
:
1649 COMPUTE_NUM_ITEMS (delta
,
1650 riter
->u
.a
.dim
[i
].s
.stride
,
1651 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1652 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1653 /* The memptr stays unchanged when ref'ing the first element
1656 case CAF_ARR_REF_RANGE
:
1657 COMPUTE_NUM_ITEMS (delta
,
1658 riter
->u
.a
.dim
[i
].s
.stride
,
1659 riter
->u
.a
.dim
[i
].s
.start
,
1660 riter
->u
.a
.dim
[i
].s
.end
);
1661 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1662 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1663 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1666 case CAF_ARR_REF_SINGLE
:
1668 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1669 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1670 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1673 case CAF_ARR_REF_OPEN_END
:
1674 COMPUTE_NUM_ITEMS (delta
,
1675 riter
->u
.a
.dim
[i
].s
.stride
,
1676 riter
->u
.a
.dim
[i
].s
.start
,
1677 GFC_DIMENSION_UBOUND (src
->dim
[i
]));
1678 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
1679 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
1680 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
1683 case CAF_ARR_REF_OPEN_START
:
1684 COMPUTE_NUM_ITEMS (delta
,
1685 riter
->u
.a
.dim
[i
].s
.stride
,
1686 GFC_DIMENSION_LBOUND (src
->dim
[i
]),
1687 riter
->u
.a
.dim
[i
].s
.end
);
1688 /* The memptr stays unchanged when ref'ing the first element
1692 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1697 /* Check the various properties of the destination array.
1698 Is an array expected and present? */
1699 if (delta
> 1 && dst_rank
== 0)
1701 /* No, an array is required, but not provided. */
1702 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1705 /* Special mode when called by __caf_sendget_by_ref (). */
1706 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1708 dst_rank
= dst_cur_dim
+ 1;
1709 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1710 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1712 /* When dst is an array. */
1715 /* Check that dst_cur_dim is valid for dst. Can be
1716 superceeded only by scalar data. */
1717 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1719 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1722 /* Do further checks, when the source is not scalar. */
1723 else if (delta
!= 1)
1725 /* Check that the extent is not scalar and we are not in
1726 an array ref for the dst side. */
1729 /* Check that this is the non-scalar extent. */
1730 if (!array_extent_fixed
)
1732 /* In an array extent now. */
1733 in_array_ref
= true;
1734 /* Check that we haven't skipped any scalar
1735 dimensions yet and that the dst is
1738 && dst_rank
== GFC_DESCRIPTOR_RANK (src
))
1740 if (dst_reallocatable
)
1742 /* Dst is reallocatable, which means that
1743 the bounds are not set. Set them. */
1744 for (dst_cur_dim
= 0; dst_cur_dim
< (int)i
;
1746 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
],
1752 /* Else press thumbs, that there are enough
1753 dimensional refs to come. Checked below. */
1757 caf_internal_error (doublearrayref
, stat
, NULL
,
1762 /* When the realloc is required, then no extent may have
1764 extent_mismatch
= realloc_required
1765 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1766 /* When it already known, that a realloc is needed or
1767 the extent does not match the needed one. */
1768 if (realloc_required
|| realloc_needed
1771 /* Check whether dst is reallocatable. */
1772 if (unlikely (!dst_reallocatable
))
1774 caf_internal_error (nonallocextentmismatch
, stat
,
1776 GFC_DESCRIPTOR_EXTENT (dst
,
1780 /* Only report an error, when the extent needs to be
1781 modified, which is not allowed. */
1782 else if (!dst_reallocatable
&& extent_mismatch
)
1784 caf_internal_error (extentoutofrange
, stat
, NULL
,
1788 realloc_needed
= true;
1790 /* Only change the extent when it does not match. This is
1791 to prevent resetting given array bounds. */
1792 if (extent_mismatch
)
1793 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1797 /* Only increase the dim counter, when in an array ref. */
1798 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1801 size
*= (index_type
)delta
;
1805 array_extent_fixed
= true;
1806 in_array_ref
= false;
1807 /* Check, if we got less dimensional refs than the rank of dst
1809 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1812 case CAF_REF_STATIC_ARRAY
:
1813 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
1815 switch (riter
->u
.a
.mode
[i
])
1817 case CAF_ARR_REF_VECTOR
:
1818 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
1819 #define KINDCASE(kind, type) case kind: \
1820 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1821 * riter->item_size; \
1824 switch (riter
->u
.a
.dim
[i
].v
.kind
)
1826 KINDCASE (1, GFC_INTEGER_1
);
1827 KINDCASE (2, GFC_INTEGER_2
);
1828 KINDCASE (4, GFC_INTEGER_4
);
1829 #ifdef HAVE_GFC_INTEGER_8
1830 KINDCASE (8, GFC_INTEGER_8
);
1832 #ifdef HAVE_GFC_INTEGER_16
1833 KINDCASE (16, GFC_INTEGER_16
);
1836 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
1841 case CAF_ARR_REF_FULL
:
1842 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
1844 /* The memptr stays unchanged when ref'ing the first element
1847 case CAF_ARR_REF_RANGE
:
1848 COMPUTE_NUM_ITEMS (delta
,
1849 riter
->u
.a
.dim
[i
].s
.stride
,
1850 riter
->u
.a
.dim
[i
].s
.start
,
1851 riter
->u
.a
.dim
[i
].s
.end
);
1852 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1853 * riter
->u
.a
.dim
[i
].s
.stride
1856 case CAF_ARR_REF_SINGLE
:
1858 memptr
+= riter
->u
.a
.dim
[i
].s
.start
1859 * riter
->u
.a
.dim
[i
].s
.stride
1862 case CAF_ARR_REF_OPEN_END
:
1863 /* This and OPEN_START are mapped to a RANGE and therefore
1864 cannot occur here. */
1865 case CAF_ARR_REF_OPEN_START
:
1867 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
1872 /* Check the various properties of the destination array.
1873 Is an array expected and present? */
1874 if (delta
> 1 && dst_rank
== 0)
1876 /* No, an array is required, but not provided. */
1877 caf_internal_error (extentoutofrange
, stat
, NULL
, 0);
1880 /* Special mode when called by __caf_sendget_by_ref (). */
1881 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1883 dst_rank
= dst_cur_dim
+ 1;
1884 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1885 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1887 /* When dst is an array. */
1890 /* Check that dst_cur_dim is valid for dst. Can be
1891 superceeded only by scalar data. */
1892 if (dst_cur_dim
>= dst_rank
&& delta
!= 1)
1894 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
1897 /* Do further checks, when the source is not scalar. */
1898 else if (delta
!= 1)
1900 /* Check that the extent is not scalar and we are not in
1901 an array ref for the dst side. */
1904 /* Check that this is the non-scalar extent. */
1905 if (!array_extent_fixed
)
1907 /* In an array extent now. */
1908 in_array_ref
= true;
1909 /* The dst is not reallocatable, so nothing more
1910 to do, then correct the dim counter. */
1915 caf_internal_error (doublearrayref
, stat
, NULL
,
1920 /* When the realloc is required, then no extent may have
1922 extent_mismatch
= realloc_required
1923 || GFC_DESCRIPTOR_EXTENT (dst
, dst_cur_dim
) != delta
;
1924 /* When it is already known, that a realloc is needed or
1925 the extent does not match the needed one. */
1926 if (realloc_required
|| realloc_needed
1929 /* Check whether dst is reallocatable. */
1930 if (unlikely (!dst_reallocatable
))
1932 caf_internal_error (nonallocextentmismatch
, stat
,
1934 GFC_DESCRIPTOR_EXTENT (dst
,
1938 /* Only report an error, when the extent needs to be
1939 modified, which is not allowed. */
1940 else if (!dst_reallocatable
&& extent_mismatch
)
1942 caf_internal_error (extentoutofrange
, stat
, NULL
,
1946 realloc_needed
= true;
1948 /* Only change the extent when it does not match. This is
1949 to prevent resetting given array bounds. */
1950 if (extent_mismatch
)
1951 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, delta
,
1954 /* Only increase the dim counter, when in an array ref. */
1955 if (in_array_ref
&& dst_cur_dim
< dst_rank
)
1958 size
*= (index_type
)delta
;
1962 array_extent_fixed
= true;
1963 in_array_ref
= false;
1964 /* Check, if we got less dimensional refs than the rank of dst
1966 assert (dst_cur_dim
== GFC_DESCRIPTOR_RANK (dst
));
1970 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
1973 src_size
= riter
->item_size
;
1974 riter
= riter
->next
;
1976 if (size
== 0 || src_size
== 0)
1979 - size contains the number of elements to store in the destination array,
1980 - src_size gives the size in bytes of each item in the destination array.
1985 if (!array_extent_fixed
)
1988 /* Special mode when called by __caf_sendget_by_ref (). */
1989 if (dst_rank
== -1 && GFC_DESCRIPTOR_DATA (dst
) == NULL
)
1991 dst_rank
= dst_cur_dim
+ 1;
1992 GFC_DESCRIPTOR_RANK (dst
) = dst_rank
;
1993 GFC_DESCRIPTOR_SIZE (dst
) = dst_kind
;
1995 /* This can happen only, when the result is scalar. */
1996 for (dst_cur_dim
= 0; dst_cur_dim
< dst_rank
; ++dst_cur_dim
)
1997 GFC_DIMENSION_SET (dst
->dim
[dst_cur_dim
], 1, 1, 1);
2000 GFC_DESCRIPTOR_DATA (dst
) = malloc (size
* GFC_DESCRIPTOR_SIZE (dst
));
2001 if (unlikely (GFC_DESCRIPTOR_DATA (dst
) == NULL
))
2003 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2008 /* Reset the token. */
2009 single_token
= TOKEN (token
);
2010 memptr
= single_token
->memptr
;
2011 src
= single_token
->desc
;
2012 memset(dst_index
, 0, sizeof (dst_index
));
2014 get_for_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2015 GFC_DESCRIPTOR_DATA (dst
), memptr
, dst_kind
, src_kind
, 0, 0,
2021 send_by_ref (caf_reference_t
*ref
, size_t *i
, size_t *src_index
,
2022 caf_single_token_t single_token
, gfc_descriptor_t
*dst
,
2023 gfc_descriptor_t
*src
, void *ds
, void *sr
,
2024 int dst_kind
, int src_kind
, size_t dst_dim
, size_t src_dim
,
2025 size_t num
, size_t size
, int *stat
, int dst_type
)
2027 const char vecrefunknownkind
[] = "libcaf_single::caf_send_by_ref(): "
2028 "unknown kind in vector-ref.\n";
2029 ptrdiff_t extent_dst
= 1, array_offset_dst
= 0, stride_dst
;
2030 const size_t src_rank
= GFC_DESCRIPTOR_RANK (src
);
2032 if (unlikely (ref
== NULL
))
2033 /* May be we should issue an error here, because this case should not
2037 if (ref
->next
== NULL
)
2039 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
2040 ptrdiff_t array_offset_src
= 0;;
2044 case CAF_REF_COMPONENT
:
2045 if (ref
->u
.c
.caf_token_offset
> 0)
2047 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2049 /* Create a scalar temporary array descriptor. */
2050 gfc_descriptor_t static_dst
;
2051 GFC_DESCRIPTOR_DATA (&static_dst
) = NULL
;
2052 GFC_DESCRIPTOR_DTYPE (&static_dst
)
2053 = GFC_DESCRIPTOR_DTYPE (src
);
2054 /* The component can be allocated now, because it is a
2056 _gfortran_caf_register (ref
->item_size
,
2057 CAF_REGTYPE_COARRAY_ALLOC
,
2058 ds
+ ref
->u
.c
.caf_token_offset
,
2059 &static_dst
, stat
, NULL
, 0);
2060 single_token
= *(caf_single_token_t
*)
2061 (ds
+ ref
->u
.c
.caf_token_offset
);
2062 /* In case of an error in allocation return. When stat is
2063 NULL, then register_component() terminates on error. */
2064 if (stat
!= NULL
&& *stat
)
2066 /* Publish the allocated memory. */
2067 *((void **)(ds
+ ref
->u
.c
.offset
))
2068 = GFC_DESCRIPTOR_DATA (&static_dst
);
2069 ds
= GFC_DESCRIPTOR_DATA (&static_dst
);
2070 /* Set the type from the src. */
2071 dst_type
= GFC_DESCRIPTOR_TYPE (src
);
2075 single_token
= *(caf_single_token_t
*)
2076 (ds
+ ref
->u
.c
.caf_token_offset
);
2077 dst
= single_token
->desc
;
2080 ds
= GFC_DESCRIPTOR_DATA (dst
);
2081 dst_type
= GFC_DESCRIPTOR_TYPE (dst
);
2084 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2086 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2087 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2090 copy_data (ds
+ ref
->u
.c
.offset
, sr
, dst_type
,
2091 GFC_DESCRIPTOR_TYPE (src
),
2092 dst_kind
, src_kind
, ref
->item_size
, src_size
, 1, stat
);
2095 case CAF_REF_STATIC_ARRAY
:
2096 /* Intentionally fall through. */
2098 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2102 for (size_t d
= 0; d
< src_rank
; ++d
)
2103 array_offset_src
+= src_index
[d
];
2104 copy_data (ds
, sr
+ array_offset_src
* src_size
,
2105 dst_type
, GFC_DESCRIPTOR_TYPE (src
), dst_kind
,
2106 src_kind
, ref
->item_size
, src_size
, num
, stat
);
2109 copy_data (ds
, sr
, dst_type
, GFC_DESCRIPTOR_TYPE (src
),
2110 dst_kind
, src_kind
, ref
->item_size
, src_size
, num
,
2117 caf_runtime_error (unreachable
);
2123 case CAF_REF_COMPONENT
:
2124 if (ref
->u
.c
.caf_token_offset
> 0)
2126 if (*(void**)(ds
+ ref
->u
.c
.offset
) == NULL
)
2128 /* This component refs an unallocated array. Non-arrays are
2129 caught in the if (!ref->next) above. */
2130 dst
= (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
);
2131 /* Assume that the rank and the dimensions fit for copying src
2133 GFC_DESCRIPTOR_DTYPE (dst
) = GFC_DESCRIPTOR_DTYPE (src
);
2136 for (size_t d
= 0; d
< src_rank
; ++d
)
2138 extent_dst
= GFC_DIMENSION_EXTENT (src
->dim
[d
]);
2139 GFC_DIMENSION_LBOUND (dst
->dim
[d
]) = 0;
2140 GFC_DIMENSION_UBOUND (dst
->dim
[d
]) = extent_dst
- 1;
2141 GFC_DIMENSION_STRIDE (dst
->dim
[d
]) = stride_dst
;
2142 stride_dst
*= extent_dst
;
2144 /* Null the data-pointer to make register_component allocate
2146 GFC_DESCRIPTOR_DATA (dst
) = NULL
;
2148 /* The size of the array is given by size. */
2149 _gfortran_caf_register (size
* ref
->item_size
,
2150 CAF_REGTYPE_COARRAY_ALLOC
,
2151 ds
+ ref
->u
.c
.caf_token_offset
,
2152 dst
, stat
, NULL
, 0);
2153 /* In case of an error in allocation return. When stat is
2154 NULL, then register_component() terminates on error. */
2155 if (stat
!= NULL
&& *stat
)
2158 single_token
= *(caf_single_token_t
*)(ds
+ ref
->u
.c
.caf_token_offset
);
2159 /* When a component is allocatable (caf_token_offset != 0) and not an
2160 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
2162 if (ref
->next
&& ref
->next
->type
== CAF_REF_COMPONENT
)
2163 ds
= *(void **)(ds
+ ref
->u
.c
.offset
);
2165 ds
+= ref
->u
.c
.offset
;
2167 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2168 single_token
->desc
, src
, ds
, sr
,
2169 dst_kind
, src_kind
, 0, src_dim
, 1, size
, stat
, dst_type
);
2172 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2173 (gfc_descriptor_t
*)(ds
+ ref
->u
.c
.offset
), src
,
2174 ds
+ ref
->u
.c
.offset
, sr
, dst_kind
, src_kind
, 0, src_dim
,
2175 1, size
, stat
, dst_type
);
2178 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2180 send_by_ref (ref
->next
, i
, src_index
, single_token
,
2181 (gfc_descriptor_t
*)ds
, src
, ds
, sr
, dst_kind
, src_kind
,
2182 0, src_dim
, 1, size
, stat
, dst_type
);
2185 /* Only when on the left most index switch the data pointer to
2186 the array's data pointer. And only for non-static arrays. */
2187 if (dst_dim
== 0 && ref
->type
!= CAF_REF_STATIC_ARRAY
)
2188 ds
= GFC_DESCRIPTOR_DATA (dst
);
2189 switch (ref
->u
.a
.mode
[dst_dim
])
2191 case CAF_ARR_REF_VECTOR
:
2192 array_offset_dst
= 0;
2193 src_index
[src_dim
] = 0;
2194 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2197 #define KINDCASE(kind, type) case kind: \
2198 array_offset_dst = (((index_type) \
2199 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2200 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2201 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2204 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2206 KINDCASE (1, GFC_INTEGER_1
);
2207 KINDCASE (2, GFC_INTEGER_2
);
2208 KINDCASE (4, GFC_INTEGER_4
);
2209 #ifdef HAVE_GFC_INTEGER_8
2210 KINDCASE (8, GFC_INTEGER_8
);
2212 #ifdef HAVE_GFC_INTEGER_16
2213 KINDCASE (16, GFC_INTEGER_16
);
2216 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2221 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2222 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2223 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2224 1, size
, stat
, dst_type
);
2227 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2230 case CAF_ARR_REF_FULL
:
2231 COMPUTE_NUM_ITEMS (extent_dst
,
2232 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2233 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2234 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2235 array_offset_dst
= 0;
2236 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2237 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2238 src_index
[src_dim
] = 0;
2239 for (index_type idx
= 0; idx
< extent_dst
;
2240 ++idx
, array_offset_dst
+= stride_dst
)
2242 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2243 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2244 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2245 1, size
, stat
, dst_type
);
2248 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2251 case CAF_ARR_REF_RANGE
:
2252 COMPUTE_NUM_ITEMS (extent_dst
,
2253 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2254 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2255 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2256 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2257 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2258 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2259 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2260 src_index
[src_dim
] = 0;
2261 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2263 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2264 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2265 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2266 1, size
, stat
, dst_type
);
2269 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2270 array_offset_dst
+= stride_dst
;
2273 case CAF_ARR_REF_SINGLE
:
2274 array_offset_dst
= (ref
->u
.a
.dim
[dst_dim
].s
.start
2275 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]))
2276 * GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
]);
2277 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
, ds
2278 + array_offset_dst
* ref
->item_size
, sr
,
2279 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2280 size
, stat
, dst_type
);
2282 case CAF_ARR_REF_OPEN_END
:
2283 COMPUTE_NUM_ITEMS (extent_dst
,
2284 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2285 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2286 GFC_DIMENSION_UBOUND (dst
->dim
[dst_dim
]));
2287 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
2288 - GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]);
2289 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2290 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2291 src_index
[src_dim
] = 0;
2292 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2294 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2295 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2296 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2297 1, size
, stat
, dst_type
);
2300 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2301 array_offset_dst
+= stride_dst
;
2304 case CAF_ARR_REF_OPEN_START
:
2305 COMPUTE_NUM_ITEMS (extent_dst
,
2306 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2307 GFC_DIMENSION_LBOUND (dst
->dim
[dst_dim
]),
2308 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2309 array_offset_dst
= 0;
2310 stride_dst
= GFC_DIMENSION_STRIDE (dst
->dim
[dst_dim
])
2311 * ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2312 src_index
[src_dim
] = 0;
2313 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2315 send_by_ref (ref
, i
, src_index
, single_token
, dst
, src
,
2316 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2317 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2318 1, size
, stat
, dst_type
);
2321 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2322 array_offset_dst
+= stride_dst
;
2326 caf_runtime_error (unreachable
);
2329 case CAF_REF_STATIC_ARRAY
:
2330 if (ref
->u
.a
.mode
[dst_dim
] == CAF_ARR_REF_NONE
)
2332 send_by_ref (ref
->next
, i
, src_index
, single_token
, NULL
,
2333 src
, ds
, sr
, dst_kind
, src_kind
,
2334 0, src_dim
, 1, size
, stat
, dst_type
);
2337 switch (ref
->u
.a
.mode
[dst_dim
])
2339 case CAF_ARR_REF_VECTOR
:
2340 array_offset_dst
= 0;
2341 src_index
[src_dim
] = 0;
2342 for (size_t idx
= 0; idx
< ref
->u
.a
.dim
[dst_dim
].v
.nvec
;
2345 #define KINDCASE(kind, type) case kind: \
2346 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2349 switch (ref
->u
.a
.dim
[dst_dim
].v
.kind
)
2351 KINDCASE (1, GFC_INTEGER_1
);
2352 KINDCASE (2, GFC_INTEGER_2
);
2353 KINDCASE (4, GFC_INTEGER_4
);
2354 #ifdef HAVE_GFC_INTEGER_8
2355 KINDCASE (8, GFC_INTEGER_8
);
2357 #ifdef HAVE_GFC_INTEGER_16
2358 KINDCASE (16, GFC_INTEGER_16
);
2361 caf_runtime_error (unreachable
);
2366 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2367 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2368 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2369 1, size
, stat
, dst_type
);
2371 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2374 case CAF_ARR_REF_FULL
:
2375 src_index
[src_dim
] = 0;
2376 for (array_offset_dst
= 0 ;
2377 array_offset_dst
<= ref
->u
.a
.dim
[dst_dim
].s
.end
;
2378 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
)
2380 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2381 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2382 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2383 1, size
, stat
, dst_type
);
2386 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2389 case CAF_ARR_REF_RANGE
:
2390 COMPUTE_NUM_ITEMS (extent_dst
,
2391 ref
->u
.a
.dim
[dst_dim
].s
.stride
,
2392 ref
->u
.a
.dim
[dst_dim
].s
.start
,
2393 ref
->u
.a
.dim
[dst_dim
].s
.end
);
2394 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2395 src_index
[src_dim
] = 0;
2396 for (index_type idx
= 0; idx
< extent_dst
; ++idx
)
2398 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2399 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2400 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
+ 1,
2401 1, size
, stat
, dst_type
);
2404 += GFC_DIMENSION_STRIDE (src
->dim
[src_dim
]);
2405 array_offset_dst
+= ref
->u
.a
.dim
[dst_dim
].s
.stride
;
2408 case CAF_ARR_REF_SINGLE
:
2409 array_offset_dst
= ref
->u
.a
.dim
[dst_dim
].s
.start
;
2410 send_by_ref (ref
, i
, src_index
, single_token
, NULL
, src
,
2411 ds
+ array_offset_dst
* ref
->item_size
, sr
,
2412 dst_kind
, src_kind
, dst_dim
+ 1, src_dim
, 1,
2413 size
, stat
, dst_type
);
2415 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
2416 case CAF_ARR_REF_OPEN_END
:
2417 case CAF_ARR_REF_OPEN_START
:
2419 caf_runtime_error (unreachable
);
2423 caf_runtime_error (unreachable
);
2429 _gfortran_caf_send_by_ref (caf_token_t token
,
2430 int image_index
__attribute__ ((unused
)),
2431 gfc_descriptor_t
*src
, caf_reference_t
*refs
,
2432 int dst_kind
, int src_kind
,
2433 bool may_require_tmp
__attribute__ ((unused
)),
2434 bool dst_reallocatable
, int *stat
, int dst_type
)
2436 const char vecrefunknownkind
[] = "libcaf_single::caf_get_by_ref(): "
2437 "unknown kind in vector-ref.\n";
2438 const char unknownreftype
[] = "libcaf_single::caf_send_by_ref(): "
2439 "unknown reference type.\n";
2440 const char unknownarrreftype
[] = "libcaf_single::caf_send_by_ref(): "
2441 "unknown array reference type.\n";
2442 const char rankoutofrange
[] = "libcaf_single::caf_send_by_ref(): "
2443 "rank out of range.\n";
2444 const char realloconinnerref
[] = "libcaf_single::caf_send_by_ref(): "
2445 "reallocation of array followed by component ref not allowed.\n";
2446 const char cannotallocdst
[] = "libcaf_single::caf_send_by_ref(): "
2447 "cannot allocate memory.\n";
2448 const char nonallocextentmismatch
[] = "libcaf_single::caf_send_by_ref(): "
2449 "extent of non-allocatable array mismatch.\n";
2450 const char innercompref
[] = "libcaf_single::caf_send_by_ref(): "
2451 "inner unallocated component detected.\n";
2453 size_t dst_index
[GFC_MAX_DIMENSIONS
];
2454 int src_rank
= GFC_DESCRIPTOR_RANK (src
);
2455 int src_cur_dim
= 0;
2456 size_t src_size
= 0;
2457 caf_single_token_t single_token
= TOKEN (token
);
2458 void *memptr
= single_token
->memptr
;
2459 gfc_descriptor_t
*dst
= single_token
->desc
;
2460 caf_reference_t
*riter
= refs
;
2462 bool extent_mismatch
;
2463 /* Note that the component is not allocated yet. */
2464 index_type new_component_idx
= -1;
2469 /* Compute the size of the result. In the beginning size just counts the
2470 number of elements. */
2474 switch (riter
->type
)
2476 case CAF_REF_COMPONENT
:
2477 if (unlikely (new_component_idx
!= -1))
2479 /* Allocating a component in the middle of a component ref is not
2480 support. We don't know the type to allocate. */
2481 caf_internal_error (innercompref
, stat
, NULL
, 0);
2484 if (riter
->u
.c
.caf_token_offset
> 0)
2486 /* Check whether the allocatable component is zero, then no
2487 token is present, too. The token's pointer is not cleared
2488 when the structure is initialized. */
2489 if (*(void**)(memptr
+ riter
->u
.c
.offset
) == NULL
)
2491 /* This component is not yet allocated. Check that it is
2492 allocatable here. */
2493 if (!dst_reallocatable
)
2495 caf_internal_error (cannotallocdst
, stat
, NULL
, 0);
2498 single_token
= NULL
;
2503 single_token
= *(caf_single_token_t
*)
2504 (memptr
+ riter
->u
.c
.caf_token_offset
);
2505 memptr
+= riter
->u
.c
.offset
;
2506 dst
= single_token
->desc
;
2510 /* Regular component. */
2511 memptr
+= riter
->u
.c
.offset
;
2512 dst
= (gfc_descriptor_t
*)memptr
;
2517 memptr
= GFC_DESCRIPTOR_DATA (dst
);
2520 /* When the dst array needs to be allocated, then look at the
2521 extent of the source array in the dimension dst_cur_dim. */
2522 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2524 switch (riter
->u
.a
.mode
[i
])
2526 case CAF_ARR_REF_VECTOR
:
2527 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2528 #define KINDCASE(kind, type) case kind: \
2529 memptr += (((index_type) \
2530 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2531 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2532 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2533 * riter->item_size; \
2536 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2538 KINDCASE (1, GFC_INTEGER_1
);
2539 KINDCASE (2, GFC_INTEGER_2
);
2540 KINDCASE (4, GFC_INTEGER_4
);
2541 #ifdef HAVE_GFC_INTEGER_8
2542 KINDCASE (8, GFC_INTEGER_8
);
2544 #ifdef HAVE_GFC_INTEGER_16
2545 KINDCASE (16, GFC_INTEGER_16
);
2548 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2553 case CAF_ARR_REF_FULL
:
2555 COMPUTE_NUM_ITEMS (delta
,
2556 riter
->u
.a
.dim
[i
].s
.stride
,
2557 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2558 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2560 COMPUTE_NUM_ITEMS (delta
,
2561 riter
->u
.a
.dim
[i
].s
.stride
,
2562 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2563 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2565 case CAF_ARR_REF_RANGE
:
2566 COMPUTE_NUM_ITEMS (delta
,
2567 riter
->u
.a
.dim
[i
].s
.stride
,
2568 riter
->u
.a
.dim
[i
].s
.start
,
2569 riter
->u
.a
.dim
[i
].s
.end
);
2570 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2571 - dst
->dim
[i
].lower_bound
)
2572 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2575 case CAF_ARR_REF_SINGLE
:
2577 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2578 - dst
->dim
[i
].lower_bound
)
2579 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2582 case CAF_ARR_REF_OPEN_END
:
2584 COMPUTE_NUM_ITEMS (delta
,
2585 riter
->u
.a
.dim
[i
].s
.stride
,
2586 riter
->u
.a
.dim
[i
].s
.start
,
2587 GFC_DIMENSION_UBOUND (dst
->dim
[i
]));
2589 COMPUTE_NUM_ITEMS (delta
,
2590 riter
->u
.a
.dim
[i
].s
.stride
,
2591 riter
->u
.a
.dim
[i
].s
.start
,
2592 GFC_DIMENSION_UBOUND (src
->dim
[src_cur_dim
]));
2593 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
2594 - dst
->dim
[i
].lower_bound
)
2595 * GFC_DIMENSION_STRIDE (dst
->dim
[i
])
2598 case CAF_ARR_REF_OPEN_START
:
2600 COMPUTE_NUM_ITEMS (delta
,
2601 riter
->u
.a
.dim
[i
].s
.stride
,
2602 GFC_DIMENSION_LBOUND (dst
->dim
[i
]),
2603 riter
->u
.a
.dim
[i
].s
.end
);
2605 COMPUTE_NUM_ITEMS (delta
,
2606 riter
->u
.a
.dim
[i
].s
.stride
,
2607 GFC_DIMENSION_LBOUND (src
->dim
[src_cur_dim
]),
2608 riter
->u
.a
.dim
[i
].s
.end
);
2609 /* The memptr stays unchanged when ref'ing the first element
2613 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2619 /* Check the various properties of the source array.
2620 When src is an array. */
2621 if (delta
> 1 && src_rank
> 0)
2623 /* Check that src_cur_dim is valid for src. Can be
2624 superceeded only by scalar data. */
2625 if (src_cur_dim
>= src_rank
)
2627 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2630 /* Do further checks, when the source is not scalar. */
2633 /* When the realloc is required, then no extent may have
2635 extent_mismatch
= memptr
== NULL
2637 && GFC_DESCRIPTOR_EXTENT (dst
, src_cur_dim
)
2639 /* When it already known, that a realloc is needed or
2640 the extent does not match the needed one. */
2641 if (extent_mismatch
)
2643 /* Check whether dst is reallocatable. */
2644 if (unlikely (!dst_reallocatable
))
2646 caf_internal_error (nonallocextentmismatch
, stat
,
2648 GFC_DESCRIPTOR_EXTENT (dst
,
2652 /* Report error on allocatable but missing inner
2654 else if (riter
->next
!= NULL
)
2656 caf_internal_error (realloconinnerref
, stat
, NULL
,
2661 /* Only change the extent when it does not match. This is
2662 to prevent resetting given array bounds. */
2663 if (extent_mismatch
)
2664 GFC_DIMENSION_SET (dst
->dim
[src_cur_dim
], 1, delta
,
2667 /* Increase the dim-counter of the src only when the extent
2669 if (src_cur_dim
< src_rank
2670 && GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
) == delta
)
2673 size
*= (index_type
)delta
;
2676 case CAF_REF_STATIC_ARRAY
:
2677 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
2679 switch (riter
->u
.a
.mode
[i
])
2681 case CAF_ARR_REF_VECTOR
:
2682 delta
= riter
->u
.a
.dim
[i
].v
.nvec
;
2683 #define KINDCASE(kind, type) case kind: \
2684 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2685 * riter->item_size; \
2688 switch (riter
->u
.a
.dim
[i
].v
.kind
)
2690 KINDCASE (1, GFC_INTEGER_1
);
2691 KINDCASE (2, GFC_INTEGER_2
);
2692 KINDCASE (4, GFC_INTEGER_4
);
2693 #ifdef HAVE_GFC_INTEGER_8
2694 KINDCASE (8, GFC_INTEGER_8
);
2696 #ifdef HAVE_GFC_INTEGER_16
2697 KINDCASE (16, GFC_INTEGER_16
);
2700 caf_internal_error (vecrefunknownkind
, stat
, NULL
, 0);
2705 case CAF_ARR_REF_FULL
:
2706 delta
= riter
->u
.a
.dim
[i
].s
.end
/ riter
->u
.a
.dim
[i
].s
.stride
2708 /* The memptr stays unchanged when ref'ing the first element
2711 case CAF_ARR_REF_RANGE
:
2712 COMPUTE_NUM_ITEMS (delta
,
2713 riter
->u
.a
.dim
[i
].s
.stride
,
2714 riter
->u
.a
.dim
[i
].s
.start
,
2715 riter
->u
.a
.dim
[i
].s
.end
);
2716 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2717 * riter
->u
.a
.dim
[i
].s
.stride
2720 case CAF_ARR_REF_SINGLE
:
2722 memptr
+= riter
->u
.a
.dim
[i
].s
.start
2723 * riter
->u
.a
.dim
[i
].s
.stride
2726 case CAF_ARR_REF_OPEN_END
:
2727 /* This and OPEN_START are mapped to a RANGE and therefore
2728 cannot occur here. */
2729 case CAF_ARR_REF_OPEN_START
:
2731 caf_internal_error (unknownarrreftype
, stat
, NULL
, 0);
2736 /* Check the various properties of the source array.
2737 Only when the source array is not scalar examine its
2739 if (delta
> 1 && src_rank
> 0)
2741 /* Check that src_cur_dim is valid for src. Can be
2742 superceeded only by scalar data. */
2743 if (src_cur_dim
>= src_rank
)
2745 caf_internal_error (rankoutofrange
, stat
, NULL
, 0);
2750 /* We will not be able to realloc the dst, because that's
2751 a fixed size array. */
2752 extent_mismatch
= GFC_DESCRIPTOR_EXTENT (src
, src_cur_dim
)
2754 /* When the extent does not match the needed one we can
2756 if (extent_mismatch
)
2758 caf_internal_error (nonallocextentmismatch
, stat
,
2760 GFC_DESCRIPTOR_EXTENT (src
,
2767 size
*= (index_type
)delta
;
2771 caf_internal_error (unknownreftype
, stat
, NULL
, 0);
2774 src_size
= riter
->item_size
;
2775 riter
= riter
->next
;
2777 if (size
== 0 || src_size
== 0)
2780 - size contains the number of elements to store in the destination array,
2781 - src_size gives the size in bytes of each item in the destination array.
2784 /* Reset the token. */
2785 single_token
= TOKEN (token
);
2786 memptr
= single_token
->memptr
;
2787 dst
= single_token
->desc
;
2788 memset (dst_index
, 0, sizeof (dst_index
));
2790 send_by_ref (refs
, &i
, dst_index
, single_token
, dst
, src
,
2791 memptr
, GFC_DESCRIPTOR_DATA (src
), dst_kind
, src_kind
, 0, 0,
2792 1, size
, stat
, dst_type
);
2798 _gfortran_caf_sendget_by_ref (caf_token_t dst_token
, int dst_image_index
,
2799 caf_reference_t
*dst_refs
, caf_token_t src_token
,
2800 int src_image_index
,
2801 caf_reference_t
*src_refs
, int dst_kind
,
2802 int src_kind
, bool may_require_tmp
, int *dst_stat
,
2803 int *src_stat
, int dst_type
, int src_type
)
2805 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS
, void) temp
;
2806 GFC_DESCRIPTOR_DATA (&temp
) = NULL
;
2807 GFC_DESCRIPTOR_RANK (&temp
) = -1;
2808 GFC_DESCRIPTOR_TYPE (&temp
) = dst_type
;
2810 _gfortran_caf_get_by_ref (src_token
, src_image_index
,
2811 (gfc_descriptor_t
*) &temp
, src_refs
,
2812 dst_kind
, src_kind
, may_require_tmp
, true,
2813 src_stat
, src_type
);
2815 if (src_stat
&& *src_stat
!= 0)
2818 _gfortran_caf_send_by_ref (dst_token
, dst_image_index
,
2819 (gfc_descriptor_t
*) &temp
, dst_refs
,
2820 dst_kind
, dst_kind
, may_require_tmp
, true,
2821 dst_stat
, dst_type
);
2822 if (GFC_DESCRIPTOR_DATA (&temp
))
2823 free (GFC_DESCRIPTOR_DATA (&temp
));
2828 _gfortran_caf_atomic_define (caf_token_t token
, size_t offset
,
2829 int image_index
__attribute__ ((unused
)),
2830 void *value
, int *stat
,
2831 int type
__attribute__ ((unused
)), int kind
)
2835 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2837 __atomic_store (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2844 _gfortran_caf_atomic_ref (caf_token_t token
, size_t offset
,
2845 int image_index
__attribute__ ((unused
)),
2846 void *value
, int *stat
,
2847 int type
__attribute__ ((unused
)), int kind
)
2851 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2853 __atomic_load (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
2861 _gfortran_caf_atomic_cas (caf_token_t token
, size_t offset
,
2862 int image_index
__attribute__ ((unused
)),
2863 void *old
, void *compare
, void *new_val
, int *stat
,
2864 int type
__attribute__ ((unused
)), int kind
)
2868 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2870 *(uint32_t *) old
= *(uint32_t *) compare
;
2871 (void) __atomic_compare_exchange_n (atom
, (uint32_t *) old
,
2872 *(uint32_t *) new_val
, false,
2873 __ATOMIC_RELAXED
, __ATOMIC_RELAXED
);
2880 _gfortran_caf_atomic_op (int op
, caf_token_t token
, size_t offset
,
2881 int image_index
__attribute__ ((unused
)),
2882 void *value
, void *old
, int *stat
,
2883 int type
__attribute__ ((unused
)), int kind
)
2888 uint32_t *atom
= (uint32_t *) ((char *) MEMTOK (token
) + offset
);
2892 case GFC_CAF_ATOMIC_ADD
:
2893 res
= __atomic_fetch_add (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2895 case GFC_CAF_ATOMIC_AND
:
2896 res
= __atomic_fetch_and (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2898 case GFC_CAF_ATOMIC_OR
:
2899 res
= __atomic_fetch_or (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2901 case GFC_CAF_ATOMIC_XOR
:
2902 res
= __atomic_fetch_xor (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
2905 __builtin_unreachable();
2909 *(uint32_t *) old
= res
;
2916 _gfortran_caf_event_post (caf_token_t token
, size_t index
,
2917 int image_index
__attribute__ ((unused
)),
2918 int *stat
, char *errmsg
__attribute__ ((unused
)),
2919 size_t errmsg_len
__attribute__ ((unused
)))
2922 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2923 * sizeof (uint32_t));
2924 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2931 _gfortran_caf_event_wait (caf_token_t token
, size_t index
,
2932 int until_count
, int *stat
,
2933 char *errmsg
__attribute__ ((unused
)),
2934 size_t errmsg_len
__attribute__ ((unused
)))
2936 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2937 * sizeof (uint32_t));
2938 uint32_t value
= (uint32_t)-until_count
;
2939 __atomic_fetch_add (event
, (uint32_t) value
, __ATOMIC_RELAXED
);
2946 _gfortran_caf_event_query (caf_token_t token
, size_t index
,
2947 int image_index
__attribute__ ((unused
)),
2948 int *count
, int *stat
)
2950 uint32_t *event
= (uint32_t *) ((char *) MEMTOK (token
) + index
2951 * sizeof (uint32_t));
2952 __atomic_load (event
, (uint32_t *) count
, __ATOMIC_RELAXED
);
2959 _gfortran_caf_lock (caf_token_t token
, size_t index
,
2960 int image_index
__attribute__ ((unused
)),
2961 int *acquired_lock
, int *stat
, char *errmsg
,
2964 const char *msg
= "Already locked";
2965 bool *lock
= &((bool *) MEMTOK (token
))[index
];
2971 *acquired_lock
= (int) true;
2979 *acquired_lock
= (int) false;
2991 size_t len
= (sizeof (msg
) > errmsg_len
) ? errmsg_len
2993 memcpy (errmsg
, msg
, len
);
2994 if (errmsg_len
> len
)
2995 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
2999 _gfortran_caf_error_stop_str (msg
, strlen (msg
), false);
3004 _gfortran_caf_unlock (caf_token_t token
, size_t index
,
3005 int image_index
__attribute__ ((unused
)),
3006 int *stat
, char *errmsg
, size_t errmsg_len
)
3008 const char *msg
= "Variable is not locked";
3009 bool *lock
= &((bool *) MEMTOK (token
))[index
];
3024 size_t len
= (sizeof (msg
) > errmsg_len
) ? errmsg_len
3026 memcpy (errmsg
, msg
, len
);
3027 if (errmsg_len
> len
)
3028 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
3032 _gfortran_caf_error_stop_str (msg
, strlen (msg
), false);
3036 _gfortran_caf_is_present (caf_token_t token
,
3037 int image_index
__attribute__ ((unused
)),
3038 caf_reference_t
*refs
)
3040 const char arraddressingnotallowed
[] = "libcaf_single::caf_is_present(): "
3041 "only scalar indexes allowed.\n";
3042 const char unknownreftype
[] = "libcaf_single::caf_get_by_ref(): "
3043 "unknown reference type.\n";
3044 const char unknownarrreftype
[] = "libcaf_single::caf_get_by_ref(): "
3045 "unknown array reference type.\n";
3047 caf_single_token_t single_token
= TOKEN (token
);
3048 void *memptr
= single_token
->memptr
;
3049 gfc_descriptor_t
*src
= single_token
->desc
;
3050 caf_reference_t
*riter
= refs
;
3054 switch (riter
->type
)
3056 case CAF_REF_COMPONENT
:
3057 if (riter
->u
.c
.caf_token_offset
)
3059 single_token
= *(caf_single_token_t
*)
3060 (memptr
+ riter
->u
.c
.caf_token_offset
);
3061 memptr
= single_token
->memptr
;
3062 src
= single_token
->desc
;
3066 memptr
+= riter
->u
.c
.offset
;
3067 src
= (gfc_descriptor_t
*)memptr
;
3071 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3073 switch (riter
->u
.a
.mode
[i
])
3075 case CAF_ARR_REF_SINGLE
:
3076 memptr
+= (riter
->u
.a
.dim
[i
].s
.start
3077 - GFC_DIMENSION_LBOUND (src
->dim
[i
]))
3078 * GFC_DIMENSION_STRIDE (src
->dim
[i
])
3081 case CAF_ARR_REF_FULL
:
3082 /* A full array ref is allowed on the last reference only. */
3083 if (riter
->next
== NULL
)
3085 /* else fall through reporting an error. */
3087 case CAF_ARR_REF_VECTOR
:
3088 case CAF_ARR_REF_RANGE
:
3089 case CAF_ARR_REF_OPEN_END
:
3090 case CAF_ARR_REF_OPEN_START
:
3091 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3094 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3099 case CAF_REF_STATIC_ARRAY
:
3100 for (i
= 0; riter
->u
.a
.mode
[i
] != CAF_ARR_REF_NONE
; ++i
)
3102 switch (riter
->u
.a
.mode
[i
])
3104 case CAF_ARR_REF_SINGLE
:
3105 memptr
+= riter
->u
.a
.dim
[i
].s
.start
3106 * riter
->u
.a
.dim
[i
].s
.stride
3109 case CAF_ARR_REF_FULL
:
3110 /* A full array ref is allowed on the last reference only. */
3111 if (riter
->next
== NULL
)
3113 /* else fall through reporting an error. */
3115 case CAF_ARR_REF_VECTOR
:
3116 case CAF_ARR_REF_RANGE
:
3117 case CAF_ARR_REF_OPEN_END
:
3118 case CAF_ARR_REF_OPEN_START
:
3119 caf_internal_error (arraddressingnotallowed
, 0, NULL
, 0);
3122 caf_internal_error (unknownarrreftype
, 0, NULL
, 0);
3128 caf_internal_error (unknownreftype
, 0, NULL
, 0);
3131 riter
= riter
->next
;
3133 return memptr
!= NULL
;
3136 /* Reference the libraries implementation. */
3137 extern void _gfortran_random_init (int32_t, int32_t, int32_t);
3139 void _gfortran_caf_random_init (bool repeatable
, bool image_distinct
)
3141 /* In a single image implementation always forward to the gfortran
3143 _gfortran_random_init (repeatable
, image_distinct
, 1);