/* Single-image implementation of GNU Fortran Coarray Library
- Copyright (C) 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2011-2019 Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
#include <stdlib.h> /* For exit and malloc. */
#include <string.h> /* For memcpy and memset. */
#include <stdarg.h> /* For variadic arguments. */
+#include <stdint.h>
+#include <assert.h>
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
+struct caf_single_token
+{
+ /* The pointer to the memory registered. For arrays this is the data member
+ in the descriptor. For components it's the pure data pointer. */
+ void *memptr;
+ /* The descriptor when this token is associated to an allocatable array. */
+ gfc_descriptor_t *desc;
+ /* Set when the caf lib has allocated the memory in memptr and is responsible
+ for freeing it on deregister. */
+ bool owning_memory;
+};
+typedef struct caf_single_token *caf_single_token_t;
+
+#define TOKEN(X) ((caf_single_token_t) (X))
+#define MEMTOK(X) ((caf_single_token_t) (X))->memptr
+
/* Single-image implementation of the CAF library.
Note: For performance reasons -fcoarry=single should be used
rather than this library. */
/* Global variables. */
caf_static_t *caf_static_list = NULL;
-
/* Keep in sync with mpi.c. */
static void
caf_runtime_error (const char *message, ...)
exit (EXIT_FAILURE);
}
+/* Error handling is similar everytime. */
+static void
+caf_internal_error (const char *msg, int *stat, char *errmsg,
+ size_t errmsg_len, ...)
+{
+ va_list args;
+ va_start (args, errmsg_len);
+ if (stat)
+ {
+ *stat = 1;
+ if (errmsg_len > 0)
+ {
+ int len = snprintf (errmsg, errmsg_len, msg, args);
+ if (len >= 0 && errmsg_len > (size_t) len)
+ memset (&errmsg[len], ' ', errmsg_len - len);
+ }
+ va_end (args);
+ return;
+ }
+ else
+ caf_runtime_error (msg, args);
+ va_end (args);
+}
+
+
void
_gfortran_caf_init (int *argc __attribute__ ((unused)),
- char ***argv __attribute__ ((unused)),
- int *this_image, int *num_images)
+ char ***argv __attribute__ ((unused)))
{
- *this_image = 1;
- *num_images = 1;
}
while (caf_static_list != NULL)
{
caf_static_t *tmp = caf_static_list->prev;
- free (caf_static_list->token[0]);
free (caf_static_list->token);
free (caf_static_list);
caf_static_list = tmp;
}
-void *
-_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
- int *stat, char *errmsg, int errmsg_len)
+int
+_gfortran_caf_this_image (int distance __attribute__ ((unused)))
+{
+ return 1;
+}
+
+
+int
+_gfortran_caf_num_images (int distance __attribute__ ((unused)),
+ int failed __attribute__ ((unused)))
+{
+ return 1;
+}
+
+
+void
+_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
+ gfc_descriptor_t *data, int *stat, char *errmsg,
+ size_t errmsg_len)
{
+ const char alloc_fail_msg[] = "Failed to allocate coarray";
void *local;
+ caf_single_token_t single_token;
+
+ if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
+ || type == CAF_REGTYPE_CRITICAL)
+ local = calloc (size, sizeof (bool));
+ else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC)
+ /* In the event_(wait|post) function the counter for events is a uint32,
+ so better allocate enough memory here. */
+ local = calloc (size, sizeof (uint32_t));
+ else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
+ local = NULL;
+ else
+ local = malloc (size);
- local = malloc (size);
- token = malloc (sizeof (void*) * 1);
- token[0] = local;
+ if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+ *token = malloc (sizeof (struct caf_single_token));
- if (unlikely (local == NULL || token == NULL))
+ if (unlikely (*token == NULL
+ || (local == NULL
+ && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
{
- const char msg[] = "Failed to allocate coarray";
- if (stat)
- {
- *stat = 1;
- if (errmsg_len > 0)
- {
- int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
- : (int) sizeof (msg);
- memcpy (errmsg, msg, len);
- if (errmsg_len > len)
- memset (&errmsg[len], ' ', errmsg_len-len);
- }
- return NULL;
- }
- else
- caf_runtime_error (msg);
+ /* Freeing the memory conditionally seems pointless, but
+ caf_internal_error () may return, when a stat is given and then the
+ memory may be lost. */
+ if (local)
+ free (local);
+ if (*token)
+ free (*token);
+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+ return;
}
+ single_token = TOKEN (*token);
+ single_token->memptr = local;
+ single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
+ single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
+
+
if (stat)
*stat = 0;
- if (type == CAF_REGTYPE_COARRAY_STATIC)
+ if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+ || type == CAF_REGTYPE_EVENT_ALLOC)
{
caf_static_t *tmp = malloc (sizeof (caf_static_t));
tmp->prev = caf_static_list;
- tmp->token = token;
+ tmp->token = *token;
caf_static_list = tmp;
}
- return local;
+ GFC_DESCRIPTOR_DATA (data) = local;
}
void
-_gfortran_caf_deregister (void **token, int *stat,
+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
- free (*token);
- free (token);
+ caf_single_token_t single_token = TOKEN (*token);
+
+ if (single_token->owning_memory && single_token->memptr)
+ free (single_token->memptr);
+
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ free (TOKEN (*token));
+ *token = NULL;
+ }
+ else
+ {
+ single_token->memptr = NULL;
+ single_token->owning_memory = false;
+ }
if (stat)
*stat = 0;
void
_gfortran_caf_sync_all (int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ __asm__ __volatile__ ("":::"memory");
+ if (stat)
+ *stat = 0;
+}
+
+
+void
+_gfortran_caf_sync_memory (int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
{
+ __asm__ __volatile__ ("":::"memory");
if (stat)
*stat = 0;
}
int images[] __attribute__ ((unused)),
int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
#ifdef GFC_CAF_CHECK
int i;
}
#endif
+ __asm__ __volatile__ ("":::"memory");
if (stat)
*stat = 0;
}
void
-_gfortran_caf_error_stop_str (const char *string, int32_t len)
+_gfortran_caf_stop_numeric(int stop_code, bool quiet)
+{
+ if (!quiet)
+ fprintf (stderr, "STOP %d\n", stop_code);
+ exit (0);
+}
+
+
+void
+_gfortran_caf_stop_str(const char *string, size_t len, bool quiet)
{
- fputs ("ERROR STOP ", stderr);
- while (len--)
- fputc (*(string++), stderr);
- fputs ("\n", stderr);
+ if (!quiet)
+ {
+ fputs ("STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
+ exit (0);
+}
+
+void
+_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
+{
+ if (!quiet)
+ {
+ fputs ("ERROR STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
exit (1);
}
+/* Reported that the program terminated because of a fail image issued.
+ Because this is a single image library, nothing else than aborting the whole
+ program can be done. */
+
+void _gfortran_caf_fail_image (void)
+{
+ fputs ("IMAGE FAILED!\n", stderr);
+ exit (0);
+}
+
+
+/* Get the status of image IMAGE. Because being the single image library all
+ other images are reported to be stopped. */
+
+int _gfortran_caf_image_status (int image,
+ caf_team_t * team __attribute__ ((unused)))
+{
+ if (image == 1)
+ return 0;
+ else
+ return CAF_STAT_STOPPED_IMAGE;
+}
+
+
+/* Single image library. There cannot be any failed images with only one
+ image. */
+
+void
+_gfortran_caf_failed_images (gfc_descriptor_t *array,
+ caf_team_t * team __attribute__ ((unused)),
+ int * kind)
+{
+ int local_kind = kind != NULL ? *kind : 4;
+
+ array->base_addr = NULL;
+ array->dtype.type = BT_INTEGER;
+ array->dtype.elem_len = local_kind;
+ /* Setting lower_bound higher then upper_bound is what the compiler does to
+ indicate an empty array. */
+ array->dim[0].lower_bound = 0;
+ array->dim[0]._ubound = -1;
+ array->dim[0]._stride = 1;
+ array->offset = 0;
+}
+
+
+/* With only one image available no other images can be stopped. Therefore
+ return an empty array. */
+
+void
+_gfortran_caf_stopped_images (gfc_descriptor_t *array,
+ caf_team_t * team __attribute__ ((unused)),
+ int * kind)
+{
+ int local_kind = kind != NULL ? *kind : 4;
+
+ array->base_addr = NULL;
+ array->dtype.type = BT_INTEGER;
+ array->dtype.elem_len = local_kind;
+ /* Setting lower_bound higher then upper_bound is what the compiler does to
+ indicate an empty array. */
+ array->dim[0].lower_bound = 0;
+ array->dim[0]._ubound = -1;
+ array->dim[0]._stride = 1;
+ array->offset = 0;
+}
+
+
void
-_gfortran_caf_error_stop (int32_t error)
+_gfortran_caf_error_stop (int error, bool quiet)
{
- fprintf (stderr, "ERROR STOP %d\n", error);
+ if (!quiet)
+ fprintf (stderr, "ERROR STOP %d\n", error);
exit (error);
}
+
+
+void
+_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
+ int source_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
+ int result_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
+ int result_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
+ int result_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
+
+
+void
+_gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
+ void * (*opr) (void *, void *)
+ __attribute__ ((unused)),
+ int opr_flags __attribute__ ((unused)),
+ int result_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+ {
+ if (stat)
+ *stat = 0;
+ }
+
+
+static void
+assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
+ unsigned char *src)
+{
+ size_t i, n;
+ n = dst_size/4 > src_size ? src_size : dst_size/4;
+ for (i = 0; i < n; ++i)
+ dst[i] = (int32_t) src[i];
+ for (; i < dst_size/4; ++i)
+ dst[i] = (int32_t) ' ';
+}
+
+
+static void
+assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
+ uint32_t *src)
+{
+ size_t i, n;
+ n = dst_size > src_size/4 ? src_size/4 : dst_size;
+ for (i = 0; i < n; ++i)
+ dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
+ if (dst_size > n)
+ memset (&dst[n], ' ', dst_size - n);
+}
+
+
+static void
+convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
+ int src_kind, int *stat)
+{
+#ifdef HAVE_GFC_INTEGER_16
+ typedef __int128 int128t;
+#else
+ typedef int64_t int128t;
+#endif
+
+#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
+ typedef long double real128t;
+ typedef _Complex long double complex128t;
+#elif defined(HAVE_GFC_REAL_16)
+ typedef _Complex float __attribute__((mode(TC))) __complex128;
+ typedef __float128 real128t;
+ typedef __complex128 complex128t;
+#elif defined(HAVE_GFC_REAL_10)
+ typedef long double real128t;
+ typedef long double complex128t;
+#else
+ typedef double real128t;
+ typedef _Complex double complex128t;
+#endif
+
+ int128t int_val = 0;
+ real128t real_val = 0;
+ complex128t cmpx_val = 0;
+
+ switch (src_type)
+ {
+ case BT_INTEGER:
+ if (src_kind == 1)
+ int_val = *(int8_t*) src;
+ else if (src_kind == 2)
+ int_val = *(int16_t*) src;
+ else if (src_kind == 4)
+ int_val = *(int32_t*) src;
+ else if (src_kind == 8)
+ int_val = *(int64_t*) src;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (src_kind == 16)
+ int_val = *(int128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ case BT_REAL:
+ if (src_kind == 4)
+ real_val = *(float*) src;
+ else if (src_kind == 8)
+ real_val = *(double*) src;
+#ifdef HAVE_GFC_REAL_10
+ else if (src_kind == 10)
+ real_val = *(long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (src_kind == 16)
+ real_val = *(real128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ case BT_COMPLEX:
+ if (src_kind == 4)
+ cmpx_val = *(_Complex float*) src;
+ else if (src_kind == 8)
+ cmpx_val = *(_Complex double*) src;
+#ifdef HAVE_GFC_REAL_10
+ else if (src_kind == 10)
+ cmpx_val = *(_Complex long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (src_kind == 16)
+ cmpx_val = *(complex128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ default:
+ goto error;
+ }
+
+ switch (dst_type)
+ {
+ case BT_INTEGER:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) int_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) int_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) int_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) int_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) real_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) real_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) real_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) real_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) cmpx_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) cmpx_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) cmpx_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) cmpx_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ else
+ goto error;
+ return;
+ case BT_REAL:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) int_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) int_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) real_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) real_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) cmpx_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ return;
+ case BT_COMPLEX:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) int_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) int_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) real_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) real_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) cmpx_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ else
+ goto error;
+ return;
+ default:
+ goto error;
+ }
+
+error:
+ fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
+ "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
+ if (stat)
+ *stat = 1;
+ else
+ abort ();
+}
+
+
+void
+_gfortran_caf_get (caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ gfc_descriptor_t *src,
+ caf_vector_t *src_vector __attribute__ ((unused)),
+ gfc_descriptor_t *dest, int src_kind, int dst_kind,
+ bool may_require_tmp, int *stat)
+{
+ /* FIXME: Handle vector subscripts. */
+ size_t i, k, size;
+ int j;
+ int rank = GFC_DESCRIPTOR_RANK (dest);
+ size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+ size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+
+ if (stat)
+ *stat = 0;
+
+ if (rank == 0)
+ {
+ void *sr = (void *) ((char *) MEMTOK (token) + offset);
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (GFC_DESCRIPTOR_DATA (dest), sr,
+ dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
+ ' ', dst_size - src_size);
+ else /* dst_kind == 4. */
+ for (i = src_size/4; i < dst_size/4; i++)
+ ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+ sr);
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
+ sr);
+ else
+ convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
+ dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+ return;
+ }
+
+ size = 1;
+ for (j = 0; j < rank; j++)
+ {
+ ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+ if (dimextent < 0)
+ dimextent = 0;
+ size *= dimextent;
+ }
+
+ if (size == 0)
+ return;
+
+ if (may_require_tmp)
+ {
+ ptrdiff_t array_offset_sr, array_offset_dst;
+ void *tmp = malloc (size*src_size);
+
+ array_offset_dst = 0;
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_sr = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+ {
+ array_offset_sr += ((i / (extent*stride))
+ % (src->dim[j]._ubound
+ - src->dim[j].lower_bound + 1))
+ * src->dim[j]._stride;
+ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+ stride = src->dim[j]._stride;
+ }
+ array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+ void *sr = (void *)((char *) MEMTOK (token) + offset
+ + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+ memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+ array_offset_dst += src_size;
+ }
+
+ array_offset_sr = 0;
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_dst = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset_dst += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+ void *dst = dest->base_addr
+ + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
+ void *sr = tmp + array_offset_sr;
+
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+ && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) dst + src_size, ' ',
+ dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) dst)[k] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, dst, sr);
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, dst, sr);
+ else
+ convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+ sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+ array_offset_sr += src_size;
+ }
+
+ free (tmp);
+ return;
+ }
+
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_dst = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset_dst += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+ void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
+
+ ptrdiff_t array_offset_sr = 0;
+ stride = 1;
+ extent = 1;
+ for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+ {
+ array_offset_sr += ((i / (extent*stride))
+ % (src->dim[j]._ubound
+ - src->dim[j].lower_bound + 1))
+ * src->dim[j]._stride;
+ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+ stride = src->dim[j]._stride;
+ }
+ array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+ void *sr = (void *)((char *) MEMTOK (token) + offset
+ + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) dst)[k] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, dst, sr);
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, dst, sr);
+ else
+ convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+ sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+ }
+}
+
+
+void
+_gfortran_caf_send (caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ gfc_descriptor_t *dest,
+ caf_vector_t *dst_vector __attribute__ ((unused)),
+ gfc_descriptor_t *src, int dst_kind, int src_kind,
+ bool may_require_tmp, int *stat)
+{
+ /* FIXME: Handle vector subscripts. */
+ size_t i, k, size;
+ int j;
+ int rank = GFC_DESCRIPTOR_RANK (dest);
+ size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+ size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+
+ if (stat)
+ *stat = 0;
+
+ if (rank == 0)
+ {
+ void *dst = (void *) ((char *) MEMTOK (token) + offset);
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (dst, GFC_DESCRIPTOR_DATA (src),
+ dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (i = src_size/4; i < dst_size/4; i++)
+ ((int32_t*) dst)[i] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, dst,
+ GFC_DESCRIPTOR_DATA (src));
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, dst,
+ GFC_DESCRIPTOR_DATA (src));
+ else
+ convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+ GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
+ src_kind, stat);
+ return;
+ }
+
+ size = 1;
+ for (j = 0; j < rank; j++)
+ {
+ ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+ if (dimextent < 0)
+ dimextent = 0;
+ size *= dimextent;
+ }
+
+ if (size == 0)
+ return;
+
+ if (may_require_tmp)
+ {
+ ptrdiff_t array_offset_sr, array_offset_dst;
+ void *tmp;
+
+ if (GFC_DESCRIPTOR_RANK (src) == 0)
+ {
+ tmp = malloc (src_size);
+ memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
+ }
+ else
+ {
+ tmp = malloc (size*src_size);
+ array_offset_dst = 0;
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_sr = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+ {
+ array_offset_sr += ((i / (extent*stride))
+ % (src->dim[j]._ubound
+ - src->dim[j].lower_bound + 1))
+ * src->dim[j]._stride;
+ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+ stride = src->dim[j]._stride;
+ }
+ array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+ void *sr = (void *) ((char *) src->base_addr
+ + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+ memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+ array_offset_dst += src_size;
+ }
+ }
+
+ array_offset_sr = 0;
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_dst = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset_dst += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+ void *dst = (void *)((char *) MEMTOK (token) + offset
+ + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+ void *sr = tmp + array_offset_sr;
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (dst, sr,
+ dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+ && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) dst + src_size, ' ',
+ dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) dst)[k] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, dst, sr);
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, dst, sr);
+ else
+ convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+ sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+ if (GFC_DESCRIPTOR_RANK (src))
+ array_offset_sr += src_size;
+ }
+ free (tmp);
+ return;
+ }
+
+ for (i = 0; i < size; i++)
+ {
+ ptrdiff_t array_offset_dst = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset_dst += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+ void *dst = (void *)((char *) MEMTOK (token) + offset
+ + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+ void *sr;
+ if (GFC_DESCRIPTOR_RANK (src) != 0)
+ {
+ ptrdiff_t array_offset_sr = 0;
+ stride = 1;
+ extent = 1;
+ for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+ {
+ array_offset_sr += ((i / (extent*stride))
+ % (src->dim[j]._ubound
+ - src->dim[j].lower_bound + 1))
+ * src->dim[j]._stride;
+ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+ stride = src->dim[j]._stride;
+ }
+ array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
+ sr = (void *)((char *) src->base_addr
+ + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+ }
+ else
+ sr = src->base_addr;
+
+ if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+ && dst_kind == src_kind)
+ {
+ memmove (dst, sr,
+ dst_size > src_size ? src_size : dst_size);
+ if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) dst)[k] = (int32_t) ' ';
+ }
+ }
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, dst, sr);
+ else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, dst, sr);
+ else
+ convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+ sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
+ }
+}
+
+
+void
+_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
+ int dst_image_index, gfc_descriptor_t *dest,
+ caf_vector_t *dst_vector, caf_token_t src_token,
+ size_t src_offset,
+ int src_image_index __attribute__ ((unused)),
+ gfc_descriptor_t *src,
+ caf_vector_t *src_vector __attribute__ ((unused)),
+ int dst_kind, int src_kind, bool may_require_tmp)
+{
+ /* FIXME: Handle vector subscript of 'src_vector'. */
+ /* For a single image, src->base_addr should be the same as src_token + offset
+ but to play save, we do it properly. */
+ void *src_base = GFC_DESCRIPTOR_DATA (src);
+ GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
+ + src_offset);
+ _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
+ src, dst_kind, src_kind, may_require_tmp, NULL);
+ GFC_DESCRIPTOR_DATA (src) = src_base;
+}
+
+
+/* Emitted when a theorectically unreachable part is reached. */
+const char unreachable[] = "Fatal error: unreachable alternative found.\n";
+
+
+static void
+copy_data (void *ds, void *sr, int dst_type, int src_type,
+ int dst_kind, int src_kind, size_t dst_size, size_t src_size,
+ size_t num, int *stat)
+{
+ size_t k;
+ if (dst_type == src_type && dst_kind == src_kind)
+ {
+ memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
+ if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
+ && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) ds)[k] = (int32_t) ' ';
+ }
+ }
+ else if (dst_type == BT_CHARACTER && dst_kind == 1)
+ assign_char1_from_char4 (dst_size, src_size, ds, sr);
+ else if (dst_type == BT_CHARACTER)
+ assign_char4_from_char1 (dst_size, src_size, ds, sr);
+ else
+ for (k = 0; k < num; ++k)
+ {
+ convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
+ ds += dst_size;
+ sr += src_size;
+ }
+}
+
+
+#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
+ do { \
+ index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
+ num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
+ if (num <= 0 || abs_stride < 1) return; \
+ num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
+ } while (0)
+
+
+static void
+get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
+ caf_single_token_t single_token, gfc_descriptor_t *dst,
+ gfc_descriptor_t *src, void *ds, void *sr,
+ int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
+ size_t num, int *stat, int src_type)
+{
+ ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
+ size_t next_dst_dim;
+
+ if (unlikely (ref == NULL))
+ /* May be we should issue an error here, because this case should not
+ occur. */
+ return;
+
+ if (ref->next == NULL)
+ {
+ size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
+ ptrdiff_t array_offset_dst = 0;;
+ size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ /* Because the token is always registered after the component, its
+ offset is always greater zero. */
+ if (ref->u.c.caf_token_offset > 0)
+ /* Note, that sr is dereffed here. */
+ copy_data (ds, *(void **)(sr + ref->u.c.offset),
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+ else
+ copy_data (ds, sr + ref->u.c.offset,
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+ ++(*i);
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ /* Intentionally fall through. */
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ for (size_t d = 0; d < dst_rank; ++d)
+ array_offset_dst += dst_index[d];
+ copy_data (ds + array_offset_dst * dst_size, sr,
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
+ dst_kind, src_kind, dst_size, ref->item_size, num,
+ stat);
+ *i += num;
+ return;
+ }
+ break;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ }
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (ref->u.c.caf_token_offset > 0)
+ {
+ single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset);
+
+ if (ref->next && ref->next->type == CAF_REF_ARRAY)
+ src = single_token->desc;
+ else
+ src = NULL;
+
+ if (ref->next && ref->next->type == CAF_REF_COMPONENT)
+ /* The currently ref'ed component was allocatabe (caf_token_offset
+ > 0) and the next ref is a component, too, then the new sr has to
+ be dereffed. (static arrays cannot be allocatable or they
+ become an array with descriptor. */
+ sr = *(void **)(sr + ref->u.c.offset);
+ else
+ sr += ref->u.c.offset;
+
+ get_for_ref (ref->next, i, dst_index, single_token, dst, src,
+ ds, sr, dst_kind, src_kind, dst_dim, 0,
+ 1, stat, src_type);
+ }
+ else
+ get_for_ref (ref->next, i, dst_index, single_token, dst,
+ (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
+ sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
+ stat, src_type);
+ return;
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ get_for_ref (ref->next, i, dst_index, single_token, dst,
+ src, ds, sr, dst_kind, src_kind,
+ dst_dim, 0, 1, stat, src_type);
+ return;
+ }
+ /* Only when on the left most index switch the data pointer to
+ the array's data pointer. */
+ if (src_dim == 0)
+ sr = GFC_DESCRIPTOR_DATA (src);
+ switch (ref->u.a.mode[src_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
+ array_offset_src = 0;
+ dst_index[dst_dim] = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_src = (((index_type) \
+ ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
+ - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
+ * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
+ break
+
+ switch (ref->u.a.dim[src_dim].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_runtime_error (unreachable);
+ return;
+ }
+#undef KINDCASE
+
+ get_for_ref (ref, i, dst_index, single_token, dst, src,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[src_dim]),
+ GFC_DIMENSION_UBOUND (src->dim[src_dim]));
+ stride_src = src->dim[src_dim]._stride
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = 0;
+ dst_index[dst_dim] = 0;
+ for (index_type idx = 0; idx < extent_src;
+ ++idx, array_offset_src += stride_src)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, src,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ ref->u.a.dim[src_dim].s.end);
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
+ * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+ * ref->u.a.dim[src_dim].s.stride;
+ dst_index[dst_dim] = 0;
+ /* Increase the dst_dim only, when the src_extent is greater one
+ or src and dst extent are both one. Don't increase when the scalar
+ source is not present in the dst. */
+ next_dst_dim = extent_src > 1
+ || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
+ && extent_src == 1) ? (dst_dim + 1) : dst_dim;
+ for (index_type idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, src,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, next_dst_dim, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ array_offset_src += stride_src;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - src->dim[src_dim].lower_bound)
+ * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ dst_index[dst_dim] = 0;
+ get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+ stat, src_type);
+ return;
+ case CAF_ARR_REF_OPEN_END:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ GFC_DIMENSION_UBOUND (src->dim[src_dim]));
+ stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
+ * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ dst_index[dst_dim] = 0;
+ for (index_type idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, src,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ array_offset_src += stride_src;
+ }
+ return;
+ case CAF_ARR_REF_OPEN_START:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[src_dim]),
+ ref->u.a.dim[src_dim].s.end);
+ stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = 0;
+ dst_index[dst_dim] = 0;
+ for (index_type idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, src,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ array_offset_src += stride_src;
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ get_for_ref (ref->next, i, dst_index, single_token, dst,
+ NULL, ds, sr, dst_kind, src_kind,
+ dst_dim, 0, 1, stat, src_type);
+ return;
+ }
+ switch (ref->u.a.mode[src_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ array_offset_src = 0;
+ dst_index[dst_dim] = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
+ break
+
+ switch (ref->u.a.dim[src_dim].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_runtime_error (unreachable);
+ return;
+ }
+#undef KINDCASE
+
+ get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ dst_index[dst_dim] = 0;
+ for (array_offset_src = 0 ;
+ array_offset_src <= ref->u.a.dim[src_dim].s.end;
+ array_offset_src += ref->u.a.dim[src_dim].s.stride)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ ref->u.a.dim[src_dim].s.end);
+ array_offset_src = ref->u.a.dim[src_dim].s.start;
+ dst_index[dst_dim] = 0;
+ for (index_type idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, single_token, dst, NULL,
+ ds, sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, src_type);
+ dst_index[dst_dim]
+ += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ array_offset_src += ref->u.a.dim[src_dim].s.stride;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_src = ref->u.a.dim[src_dim].s.start;
+ get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
+ sr + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+ stat, src_type);
+ return;
+ /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+}
+
+
+void
+_gfortran_caf_get_by_ref (caf_token_t token,
+ int image_index __attribute__ ((unused)),
+ gfc_descriptor_t *dst, caf_reference_t *refs,
+ int dst_kind, int src_kind,
+ bool may_require_tmp __attribute__ ((unused)),
+ bool dst_reallocatable, int *stat,
+ int src_type)
+{
+ const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown kind in vector-ref.\n";
+ const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown reference type.\n";
+ const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown array reference type.\n";
+ const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+ "rank out of range.\n";
+ const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+ "extent out of range.\n";
+ const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
+ "cannot allocate memory.\n";
+ const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
+ "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
+ const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
+ "two or more array part references are not supported.\n";
+ size_t size, i;
+ size_t dst_index[GFC_MAX_DIMENSIONS];
+ int dst_rank = GFC_DESCRIPTOR_RANK (dst);
+ int dst_cur_dim = 0;
+ size_t src_size = 0;
+ caf_single_token_t single_token = TOKEN (token);
+ void *memptr = single_token->memptr;
+ gfc_descriptor_t *src = single_token->desc;
+ caf_reference_t *riter = refs;
+ long delta;
+ /* Reallocation of dst.data is needed (e.g., array to small). */
+ bool realloc_needed;
+ /* Reallocation of dst.data is required, because data is not alloced at
+ all. */
+ bool realloc_required;
+ bool extent_mismatch = false;
+ /* Set when the first non-scalar array reference is encountered. */
+ bool in_array_ref = false;
+ bool array_extent_fixed = false;
+ realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
+
+ assert (!realloc_needed || dst_reallocatable);
+
+ if (stat)
+ *stat = 0;
+
+ /* Compute the size of the result. In the beginning size just counts the
+ number of elements. */
+ size = 1;
+ while (riter)
+ {
+ switch (riter->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (riter->u.c.caf_token_offset)
+ {
+ single_token = *(caf_single_token_t*)
+ (memptr + riter->u.c.caf_token_offset);
+ memptr = single_token->memptr;
+ src = single_token->desc;
+ }
+ else
+ {
+ memptr += riter->u.c.offset;
+ /* When the next ref is an array ref, assume there is an
+ array descriptor at memptr. Note, static arrays do not have
+ a descriptor. */
+ if (riter->next && riter->next->type == CAF_REF_ARRAY)
+ src = (gfc_descriptor_t *)memptr;
+ else
+ src = NULL;
+ }
+ break;
+ case CAF_REF_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ memptr += (((index_type) \
+ ((type *)riter->u.a.dim[i].v.vector)[0]) \
+ - GFC_DIMENSION_LBOUND (src->dim[i])) \
+ * GFC_DIMENSION_STRIDE (src->dim[i]) \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[i]),
+ GFC_DIMENSION_UBOUND (src->dim[i]));
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ memptr += (riter->u.a.dim[i].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[i]))
+ * GFC_DIMENSION_STRIDE (src->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ memptr += (riter->u.a.dim[i].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[i]))
+ * GFC_DIMENSION_STRIDE (src->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ GFC_DIMENSION_UBOUND (src->dim[i]));
+ memptr += (riter->u.a.dim[i].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[i]))
+ * GFC_DIMENSION_STRIDE (src->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_START:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[i]),
+ riter->u.a.dim[i].s.end);
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ default:
+ caf_internal_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the destination array.
+ Is an array expected and present? */
+ if (delta > 1 && dst_rank == 0)
+ {
+ /* No, an array is required, but not provided. */
+ caf_internal_error (extentoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Special mode when called by __caf_sendget_by_ref (). */
+ if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
+ {
+ dst_rank = dst_cur_dim + 1;
+ GFC_DESCRIPTOR_RANK (dst) = dst_rank;
+ GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
+ }
+ /* When dst is an array. */
+ if (dst_rank > 0)
+ {
+ /* Check that dst_cur_dim is valid for dst. Can be
+ superceeded only by scalar data. */
+ if (dst_cur_dim >= dst_rank && delta != 1)
+ {
+ caf_internal_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Do further checks, when the source is not scalar. */
+ else if (delta != 1)
+ {
+ /* Check that the extent is not scalar and we are not in
+ an array ref for the dst side. */
+ if (!in_array_ref)
+ {
+ /* Check that this is the non-scalar extent. */
+ if (!array_extent_fixed)
+ {
+ /* In an array extent now. */
+ in_array_ref = true;
+ /* Check that we haven't skipped any scalar
+ dimensions yet and that the dst is
+ compatible. */
+ if (i > 0
+ && dst_rank == GFC_DESCRIPTOR_RANK (src))
+ {
+ if (dst_reallocatable)
+ {
+ /* Dst is reallocatable, which means that
+ the bounds are not set. Set them. */
+ for (dst_cur_dim= 0; dst_cur_dim < (int)i;
+ ++dst_cur_dim)
+ GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
+ 1, 1, 1);
+ }
+ else
+ dst_cur_dim = i;
+ }
+ /* Else press thumbs, that there are enough
+ dimensional refs to come. Checked below. */
+ }
+ else
+ {
+ caf_internal_error (doublearrayref, stat, NULL,
+ 0);
+ return;
+ }
+ }
+ /* When the realloc is required, then no extent may have
+ been set. */
+ extent_mismatch = realloc_required
+ || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+ /* When it already known, that a realloc is needed or
+ the extent does not match the needed one. */
+ if (realloc_required || realloc_needed
+ || extent_mismatch)
+ {
+ /* Check whether dst is reallocatable. */
+ if (unlikely (!dst_reallocatable))
+ {
+ caf_internal_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (dst,
+ dst_cur_dim));
+ return;
+ }
+ /* Only report an error, when the extent needs to be
+ modified, which is not allowed. */
+ else if (!dst_reallocatable && extent_mismatch)
+ {
+ caf_internal_error (extentoutofrange, stat, NULL,
+ 0);
+ return;
+ }
+ realloc_needed = true;
+ }
+ /* Only change the extent when it does not match. This is
+ to prevent resetting given array bounds. */
+ if (extent_mismatch)
+ GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
+ size);
+ }
+
+ /* Only increase the dim counter, when in an array ref. */
+ if (in_array_ref && dst_cur_dim < dst_rank)
+ ++dst_cur_dim;
+ }
+ size *= (index_type)delta;
+ }
+ if (in_array_ref)
+ {
+ array_extent_fixed = true;
+ in_array_ref = false;
+ /* Check, if we got less dimensional refs than the rank of dst
+ expects. */
+ assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
+ }
+ break;
+ case CAF_REF_STATIC_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
+ + 1;
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ /* This and OPEN_START are mapped to a RANGE and therefore
+ cannot occur here. */
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_internal_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the destination array.
+ Is an array expected and present? */
+ if (delta > 1 && dst_rank == 0)
+ {
+ /* No, an array is required, but not provided. */
+ caf_internal_error (extentoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Special mode when called by __caf_sendget_by_ref (). */
+ if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
+ {
+ dst_rank = dst_cur_dim + 1;
+ GFC_DESCRIPTOR_RANK (dst) = dst_rank;
+ GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
+ }
+ /* When dst is an array. */
+ if (dst_rank > 0)
+ {
+ /* Check that dst_cur_dim is valid for dst. Can be
+ superceeded only by scalar data. */
+ if (dst_cur_dim >= dst_rank && delta != 1)
+ {
+ caf_internal_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Do further checks, when the source is not scalar. */
+ else if (delta != 1)
+ {
+ /* Check that the extent is not scalar and we are not in
+ an array ref for the dst side. */
+ if (!in_array_ref)
+ {
+ /* Check that this is the non-scalar extent. */
+ if (!array_extent_fixed)
+ {
+ /* In an array extent now. */
+ in_array_ref = true;
+ /* The dst is not reallocatable, so nothing more
+ to do, then correct the dim counter. */
+ dst_cur_dim = i;
+ }
+ else
+ {
+ caf_internal_error (doublearrayref, stat, NULL,
+ 0);
+ return;
+ }
+ }
+ /* When the realloc is required, then no extent may have
+ been set. */
+ extent_mismatch = realloc_required
+ || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+ /* When it is already known, that a realloc is needed or
+ the extent does not match the needed one. */
+ if (realloc_required || realloc_needed
+ || extent_mismatch)
+ {
+ /* Check whether dst is reallocatable. */
+ if (unlikely (!dst_reallocatable))
+ {
+ caf_internal_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (dst,
+ dst_cur_dim));
+ return;
+ }
+ /* Only report an error, when the extent needs to be
+ modified, which is not allowed. */
+ else if (!dst_reallocatable && extent_mismatch)
+ {
+ caf_internal_error (extentoutofrange, stat, NULL,
+ 0);
+ return;
+ }
+ realloc_needed = true;
+ }
+ /* Only change the extent when it does not match. This is
+ to prevent resetting given array bounds. */
+ if (extent_mismatch)
+ GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
+ size);
+ }
+ /* Only increase the dim counter, when in an array ref. */
+ if (in_array_ref && dst_cur_dim < dst_rank)
+ ++dst_cur_dim;
+ }
+ size *= (index_type)delta;
+ }
+ if (in_array_ref)
+ {
+ array_extent_fixed = true;
+ in_array_ref = false;
+ /* Check, if we got less dimensional refs than the rank of dst
+ expects. */
+ assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
+ }
+ break;
+ default:
+ caf_internal_error (unknownreftype, stat, NULL, 0);
+ return;
+ }
+ src_size = riter->item_size;
+ riter = riter->next;
+ }
+ if (size == 0 || src_size == 0)
+ return;
+ /* Postcondition:
+ - size contains the number of elements to store in the destination array,
+ - src_size gives the size in bytes of each item in the destination array.
+ */
+
+ if (realloc_needed)
+ {
+ if (!array_extent_fixed)
+ {
+ assert (size == 1);
+ /* Special mode when called by __caf_sendget_by_ref (). */
+ if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
+ {
+ dst_rank = dst_cur_dim + 1;
+ GFC_DESCRIPTOR_RANK (dst) = dst_rank;
+ GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
+ }
+ /* This can happen only, when the result is scalar. */
+ for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
+ GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
+ }
+
+ GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
+ if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
+ {
+ caf_internal_error (cannotallocdst, stat, NULL, 0);
+ return;
+ }
+ }
+
+ /* Reset the token. */
+ single_token = TOKEN (token);
+ memptr = single_token->memptr;
+ src = single_token->desc;
+ memset(dst_index, 0, sizeof (dst_index));
+ i = 0;
+ get_for_ref (refs, &i, dst_index, single_token, dst, src,
+ GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
+ 1, stat, src_type);
+}
+
+
+static void
+send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
+ caf_single_token_t single_token, gfc_descriptor_t *dst,
+ gfc_descriptor_t *src, void *ds, void *sr,
+ int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
+ size_t num, size_t size, int *stat, int dst_type)
+{
+ const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
+ "unknown kind in vector-ref.\n";
+ ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
+ const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
+
+ if (unlikely (ref == NULL))
+ /* May be we should issue an error here, because this case should not
+ occur. */
+ return;
+
+ if (ref->next == NULL)
+ {
+ size_t src_size = GFC_DESCRIPTOR_SIZE (src);
+ ptrdiff_t array_offset_src = 0;;
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (ref->u.c.caf_token_offset > 0)
+ {
+ if (*(void**)(ds + ref->u.c.offset) == NULL)
+ {
+ /* Create a scalar temporary array descriptor. */
+ gfc_descriptor_t static_dst;
+ GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
+ GFC_DESCRIPTOR_DTYPE (&static_dst)
+ = GFC_DESCRIPTOR_DTYPE (src);
+ /* The component can be allocated now, because it is a
+ scalar. */
+ _gfortran_caf_register (ref->item_size,
+ CAF_REGTYPE_COARRAY_ALLOC,
+ ds + ref->u.c.caf_token_offset,
+ &static_dst, stat, NULL, 0);
+ single_token = *(caf_single_token_t *)
+ (ds + ref->u.c.caf_token_offset);
+ /* In case of an error in allocation return. When stat is
+ NULL, then register_component() terminates on error. */
+ if (stat != NULL && *stat)
+ return;
+ /* Publish the allocated memory. */
+ *((void **)(ds + ref->u.c.offset))
+ = GFC_DESCRIPTOR_DATA (&static_dst);
+ ds = GFC_DESCRIPTOR_DATA (&static_dst);
+ /* Set the type from the src. */
+ dst_type = GFC_DESCRIPTOR_TYPE (src);
+ }
+ else
+ {
+ single_token = *(caf_single_token_t *)
+ (ds + ref->u.c.caf_token_offset);
+ dst = single_token->desc;
+ if (dst)
+ {
+ ds = GFC_DESCRIPTOR_DATA (dst);
+ dst_type = GFC_DESCRIPTOR_TYPE (dst);
+ }
+ else
+ ds = *(void **)(ds + ref->u.c.offset);
+ }
+ copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+ }
+ else
+ copy_data (ds + ref->u.c.offset, sr, dst_type,
+ GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+ ++(*i);
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ /* Intentionally fall through. */
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+ {
+ if (src_rank > 0)
+ {
+ for (size_t d = 0; d < src_rank; ++d)
+ array_offset_src += src_index[d];
+ copy_data (ds, sr + array_offset_src * src_size,
+ dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind,
+ src_kind, ref->item_size, src_size, num, stat);
+ }
+ else
+ copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, num,
+ stat);
+ *i += num;
+ return;
+ }
+ break;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ }
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (ref->u.c.caf_token_offset > 0)
+ {
+ if (*(void**)(ds + ref->u.c.offset) == NULL)
+ {
+ /* This component refs an unallocated array. Non-arrays are
+ caught in the if (!ref->next) above. */
+ dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
+ /* Assume that the rank and the dimensions fit for copying src
+ to dst. */
+ GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
+ dst->offset = 0;
+ stride_dst = 1;
+ for (size_t d = 0; d < src_rank; ++d)
+ {
+ extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
+ GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
+ GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
+ GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
+ stride_dst *= extent_dst;
+ }
+ /* Null the data-pointer to make register_component allocate
+ its own memory. */
+ GFC_DESCRIPTOR_DATA (dst) = NULL;
+
+ /* The size of the array is given by size. */
+ _gfortran_caf_register (size * ref->item_size,
+ CAF_REGTYPE_COARRAY_ALLOC,
+ ds + ref->u.c.caf_token_offset,
+ dst, stat, NULL, 0);
+ /* In case of an error in allocation return. When stat is
+ NULL, then register_component() terminates on error. */
+ if (stat != NULL && *stat)
+ return;
+ }
+ single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
+ /* When a component is allocatable (caf_token_offset != 0) and not an
+ array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
+ dereffed. */
+ if (ref->next && ref->next->type == CAF_REF_COMPONENT)
+ ds = *(void **)(ds + ref->u.c.offset);
+ else
+ ds += ref->u.c.offset;
+
+ send_by_ref (ref->next, i, src_index, single_token,
+ single_token->desc, src, ds, sr,
+ dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type);
+ }
+ else
+ send_by_ref (ref->next, i, src_index, single_token,
+ (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
+ ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
+ 1, size, stat, dst_type);
+ return;
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+ {
+ send_by_ref (ref->next, i, src_index, single_token,
+ (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
+ 0, src_dim, 1, size, stat, dst_type);
+ return;
+ }
+ /* Only when on the left most index switch the data pointer to
+ the array's data pointer. And only for non-static arrays. */
+ if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
+ ds = GFC_DESCRIPTOR_DATA (dst);
+ switch (ref->u.a.mode[dst_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ array_offset_dst = 0;
+ src_index[src_dim] = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_dst = (((index_type) \
+ ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
+ - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
+ * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
+ break
+
+ switch (ref->u.a.dim[dst_dim].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+
+ send_by_ref (ref, i, src_index, single_token, dst, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ COMPUTE_NUM_ITEMS (extent_dst,
+ ref->u.a.dim[dst_dim].s.stride,
+ GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
+ GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
+ array_offset_dst = 0;
+ stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+ * ref->u.a.dim[dst_dim].s.stride;
+ src_index[src_dim] = 0;
+ for (index_type idx = 0; idx < extent_dst;
+ ++idx, array_offset_dst += stride_dst)
+ {
+ send_by_ref (ref, i, src_index, single_token, dst, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_dst,
+ ref->u.a.dim[dst_dim].s.stride,
+ ref->u.a.dim[dst_dim].s.start,
+ ref->u.a.dim[dst_dim].s.end);
+ array_offset_dst = ref->u.a.dim[dst_dim].s.start
+ - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
+ stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+ * ref->u.a.dim[dst_dim].s.stride;
+ src_index[src_dim] = 0;
+ for (index_type idx = 0; idx < extent_dst; ++idx)
+ {
+ send_by_ref (ref, i, src_index, single_token, dst, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ array_offset_dst += stride_dst;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_dst = (ref->u.a.dim[dst_dim].s.start
+ - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
+ * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
+ send_by_ref (ref, i, src_index, single_token, dst, src, ds
+ + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim, 1,
+ size, stat, dst_type);
+ return;
+ case CAF_ARR_REF_OPEN_END:
+ COMPUTE_NUM_ITEMS (extent_dst,
+ ref->u.a.dim[dst_dim].s.stride,
+ ref->u.a.dim[dst_dim].s.start,
+ GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
+ array_offset_dst = ref->u.a.dim[dst_dim].s.start
+ - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
+ stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+ * ref->u.a.dim[dst_dim].s.stride;
+ src_index[src_dim] = 0;
+ for (index_type idx = 0; idx < extent_dst; ++idx)
+ {
+ send_by_ref (ref, i, src_index, single_token, dst, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ array_offset_dst += stride_dst;
+ }
+ return;
+ case CAF_ARR_REF_OPEN_START:
+ COMPUTE_NUM_ITEMS (extent_dst,
+ ref->u.a.dim[dst_dim].s.stride,
+ GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
+ ref->u.a.dim[dst_dim].s.end);
+ array_offset_dst = 0;
+ stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
+ * ref->u.a.dim[dst_dim].s.stride;
+ src_index[src_dim] = 0;
+ for (index_type idx = 0; idx < extent_dst; ++idx)
+ {
+ send_by_ref (ref, i, src_index, single_token, dst, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ array_offset_dst += stride_dst;
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+ {
+ send_by_ref (ref->next, i, src_index, single_token, NULL,
+ src, ds, sr, dst_kind, src_kind,
+ 0, src_dim, 1, size, stat, dst_type);
+ return;
+ }
+ switch (ref->u.a.mode[dst_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ array_offset_dst = 0;
+ src_index[src_dim] = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
+ break
+
+ switch (ref->u.a.dim[dst_dim].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_runtime_error (unreachable);
+ return;
+ }
+#undef KINDCASE
+
+ send_by_ref (ref, i, src_index, single_token, NULL, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ src_index[src_dim] = 0;
+ for (array_offset_dst = 0 ;
+ array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
+ array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
+ {
+ send_by_ref (ref, i, src_index, single_token, NULL, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_dst,
+ ref->u.a.dim[dst_dim].s.stride,
+ ref->u.a.dim[dst_dim].s.start,
+ ref->u.a.dim[dst_dim].s.end);
+ array_offset_dst = ref->u.a.dim[dst_dim].s.start;
+ src_index[src_dim] = 0;
+ for (index_type idx = 0; idx < extent_dst; ++idx)
+ {
+ send_by_ref (ref, i, src_index, single_token, NULL, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, size, stat, dst_type);
+ if (src_rank > 0)
+ src_index[src_dim]
+ += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
+ array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_dst = ref->u.a.dim[dst_dim].s.start;
+ send_by_ref (ref, i, src_index, single_token, NULL, src,
+ ds + array_offset_dst * ref->item_size, sr,
+ dst_kind, src_kind, dst_dim + 1, src_dim, 1,
+ size, stat, dst_type);
+ return;
+ /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+}
+
+
+void
+_gfortran_caf_send_by_ref (caf_token_t token,
+ int image_index __attribute__ ((unused)),
+ gfc_descriptor_t *src, caf_reference_t *refs,
+ int dst_kind, int src_kind,
+ bool may_require_tmp __attribute__ ((unused)),
+ bool dst_reallocatable, int *stat, int dst_type)
+{
+ const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown kind in vector-ref.\n";
+ const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
+ "unknown reference type.\n";
+ const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
+ "unknown array reference type.\n";
+ const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
+ "rank out of range.\n";
+ const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
+ "reallocation of array followed by component ref not allowed.\n";
+ const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
+ "cannot allocate memory.\n";
+ const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
+ "extent of non-allocatable array mismatch.\n";
+ const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
+ "inner unallocated component detected.\n";
+ size_t size, i;
+ size_t dst_index[GFC_MAX_DIMENSIONS];
+ int src_rank = GFC_DESCRIPTOR_RANK (src);
+ int src_cur_dim = 0;
+ size_t src_size = 0;
+ caf_single_token_t single_token = TOKEN (token);
+ void *memptr = single_token->memptr;
+ gfc_descriptor_t *dst = single_token->desc;
+ caf_reference_t *riter = refs;
+ long delta;
+ bool extent_mismatch;
+ /* Note that the component is not allocated yet. */
+ index_type new_component_idx = -1;
+
+ if (stat)
+ *stat = 0;
+
+ /* Compute the size of the result. In the beginning size just counts the
+ number of elements. */
+ size = 1;
+ while (riter)
+ {
+ switch (riter->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (unlikely (new_component_idx != -1))
+ {
+ /* Allocating a component in the middle of a component ref is not
+ support. We don't know the type to allocate. */
+ caf_internal_error (innercompref, stat, NULL, 0);
+ return;
+ }
+ if (riter->u.c.caf_token_offset > 0)
+ {
+ /* Check whether the allocatable component is zero, then no
+ token is present, too. The token's pointer is not cleared
+ when the structure is initialized. */
+ if (*(void**)(memptr + riter->u.c.offset) == NULL)
+ {
+ /* This component is not yet allocated. Check that it is
+ allocatable here. */
+ if (!dst_reallocatable)
+ {
+ caf_internal_error (cannotallocdst, stat, NULL, 0);
+ return;
+ }
+ single_token = NULL;
+ memptr = NULL;
+ dst = NULL;
+ break;
+ }
+ single_token = *(caf_single_token_t*)
+ (memptr + riter->u.c.caf_token_offset);
+ memptr += riter->u.c.offset;
+ dst = single_token->desc;
+ }
+ else
+ {
+ /* Regular component. */
+ memptr += riter->u.c.offset;
+ dst = (gfc_descriptor_t *)memptr;
+ }
+ break;
+ case CAF_REF_ARRAY:
+ if (dst != NULL)
+ memptr = GFC_DESCRIPTOR_DATA (dst);
+ else
+ dst = src;
+ /* When the dst array needs to be allocated, then look at the
+ extent of the source array in the dimension dst_cur_dim. */
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ memptr += (((index_type) \
+ ((type *)riter->u.a.dim[i].v.vector)[0]) \
+ - GFC_DIMENSION_LBOUND (dst->dim[i])) \
+ * GFC_DIMENSION_STRIDE (dst->dim[i]) \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ if (dst)
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (dst->dim[i]),
+ GFC_DIMENSION_UBOUND (dst->dim[i]));
+ else
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
+ GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ memptr += (riter->u.a.dim[i].s.start
+ - dst->dim[i].lower_bound)
+ * GFC_DIMENSION_STRIDE (dst->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ memptr += (riter->u.a.dim[i].s.start
+ - dst->dim[i].lower_bound)
+ * GFC_DIMENSION_STRIDE (dst->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ if (dst)
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ GFC_DIMENSION_UBOUND (dst->dim[i]));
+ else
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
+ memptr += (riter->u.a.dim[i].s.start
+ - dst->dim[i].lower_bound)
+ * GFC_DIMENSION_STRIDE (dst->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_START:
+ if (dst)
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (dst->dim[i]),
+ riter->u.a.dim[i].s.end);
+ else
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
+ riter->u.a.dim[i].s.end);
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ default:
+ caf_internal_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the source array.
+ When src is an array. */
+ if (delta > 1 && src_rank > 0)
+ {
+ /* Check that src_cur_dim is valid for src. Can be
+ superceeded only by scalar data. */
+ if (src_cur_dim >= src_rank)
+ {
+ caf_internal_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Do further checks, when the source is not scalar. */
+ else
+ {
+ /* When the realloc is required, then no extent may have
+ been set. */
+ extent_mismatch = memptr == NULL
+ || (dst
+ && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
+ != delta);
+ /* When it already known, that a realloc is needed or
+ the extent does not match the needed one. */
+ if (extent_mismatch)
+ {
+ /* Check whether dst is reallocatable. */
+ if (unlikely (!dst_reallocatable))
+ {
+ caf_internal_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (dst,
+ src_cur_dim));
+ return;
+ }
+ /* Report error on allocatable but missing inner
+ ref. */
+ else if (riter->next != NULL)
+ {
+ caf_internal_error (realloconinnerref, stat, NULL,
+ 0);
+ return;
+ }
+ }
+ /* Only change the extent when it does not match. This is
+ to prevent resetting given array bounds. */
+ if (extent_mismatch)
+ GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
+ size);
+ }
+ /* Increase the dim-counter of the src only when the extent
+ matches. */
+ if (src_cur_dim < src_rank
+ && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
+ ++src_cur_dim;
+ }
+ size *= (index_type)delta;
+ }
+ break;
+ case CAF_REF_STATIC_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, GFC_INTEGER_1);
+ KINDCASE (2, GFC_INTEGER_2);
+ KINDCASE (4, GFC_INTEGER_4);
+#ifdef HAVE_GFC_INTEGER_8
+ KINDCASE (8, GFC_INTEGER_8);
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+ KINDCASE (16, GFC_INTEGER_16);
+#endif
+ default:
+ caf_internal_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
+ + 1;
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ /* This and OPEN_START are mapped to a RANGE and therefore
+ cannot occur here. */
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_internal_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the source array.
+ Only when the source array is not scalar examine its
+ properties. */
+ if (delta > 1 && src_rank > 0)
+ {
+ /* Check that src_cur_dim is valid for src. Can be
+ superceeded only by scalar data. */
+ if (src_cur_dim >= src_rank)
+ {
+ caf_internal_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ else
+ {
+ /* We will not be able to realloc the dst, because that's
+ a fixed size array. */
+ extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
+ != delta;
+ /* When the extent does not match the needed one we can
+ only stop here. */
+ if (extent_mismatch)
+ {
+ caf_internal_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (src,
+ src_cur_dim));
+ return;
+ }
+ }
+ ++src_cur_dim;
+ }
+ size *= (index_type)delta;
+ }
+ break;
+ default:
+ caf_internal_error (unknownreftype, stat, NULL, 0);
+ return;
+ }
+ src_size = riter->item_size;
+ riter = riter->next;
+ }
+ if (size == 0 || src_size == 0)
+ return;
+ /* Postcondition:
+ - size contains the number of elements to store in the destination array,
+ - src_size gives the size in bytes of each item in the destination array.
+ */
+
+ /* Reset the token. */
+ single_token = TOKEN (token);
+ memptr = single_token->memptr;
+ dst = single_token->desc;
+ memset (dst_index, 0, sizeof (dst_index));
+ i = 0;
+ send_by_ref (refs, &i, dst_index, single_token, dst, src,
+ memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
+ 1, size, stat, dst_type);
+ assert (i == size);
+}
+
+
+void
+_gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
+ caf_reference_t *dst_refs, caf_token_t src_token,
+ int src_image_index,
+ caf_reference_t *src_refs, int dst_kind,
+ int src_kind, bool may_require_tmp, int *dst_stat,
+ int *src_stat, int dst_type, int src_type)
+{
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp;
+ GFC_DESCRIPTOR_DATA (&temp) = NULL;
+ GFC_DESCRIPTOR_RANK (&temp) = -1;
+ GFC_DESCRIPTOR_TYPE (&temp) = dst_type;
+
+ _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
+ dst_kind, src_kind, may_require_tmp, true,
+ src_stat, src_type);
+
+ if (src_stat && *src_stat != 0)
+ return;
+
+ _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
+ dst_kind, dst_kind, may_require_tmp, true,
+ dst_stat, dst_type);
+ if (GFC_DESCRIPTOR_DATA (&temp))
+ free (GFC_DESCRIPTOR_DATA (&temp));
+}
+
+
+void
+_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ void *value, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ assert(kind == 4);
+
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+ __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
+
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ void *value, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ assert(kind == 4);
+
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+ __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
+
+ if (stat)
+ *stat = 0;
+}
+
+
+void
+_gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ void *old, void *compare, void *new_val, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ assert(kind == 4);
+
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+ *(uint32_t *) old = *(uint32_t *) compare;
+ (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
+ *(uint32_t *) new_val, false,
+ __ATOMIC_RELAXED, __ATOMIC_RELAXED);
+ if (stat)
+ *stat = 0;
+}
+
+
+void
+_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
+ int image_index __attribute__ ((unused)),
+ void *value, void *old, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ assert(kind == 4);
+
+ uint32_t res;
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
+
+ switch (op)
+ {
+ case GFC_CAF_ATOMIC_ADD:
+ res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+ break;
+ case GFC_CAF_ATOMIC_AND:
+ res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+ break;
+ case GFC_CAF_ATOMIC_OR:
+ res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+ break;
+ case GFC_CAF_ATOMIC_XOR:
+ res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
+ break;
+ default:
+ __builtin_unreachable();
+ }
+
+ if (old)
+ *(uint32_t *) old = res;
+
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_post (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ uint32_t value = 1;
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_wait (caf_token_t token, size_t index,
+ int until_count, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
+ uint32_t value = (uint32_t)-until_count;
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_query (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *count, int *stat)
+{
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
+ __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_lock (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)
+{
+ const char *msg = "Already locked";
+ bool *lock = &((bool *) MEMTOK (token))[index];
+
+ if (!*lock)
+ {
+ *lock = true;
+ if (aquired_lock)
+ *aquired_lock = (int) true;
+ if (stat)
+ *stat = 0;
+ return;
+ }
+
+ if (aquired_lock)
+ {
+ *aquired_lock = (int) false;
+ if (stat)
+ *stat = 0;
+ return;
+ }
+
+
+ if (stat)
+ {
+ *stat = 1;
+ if (errmsg_len > 0)
+ {
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
+ memcpy (errmsg, msg, len);
+ if (errmsg_len > len)
+ memset (&errmsg[len], ' ', errmsg_len-len);
+ }
+ return;
+ }
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
+}
+
+
+void
+_gfortran_caf_unlock (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *stat, char *errmsg, size_t errmsg_len)
+{
+ const char *msg = "Variable is not locked";
+ bool *lock = &((bool *) MEMTOK (token))[index];
+
+ if (*lock)
+ {
+ *lock = false;
+ if (stat)
+ *stat = 0;
+ return;
+ }
+
+ if (stat)
+ {
+ *stat = 1;
+ if (errmsg_len > 0)
+ {
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
+ memcpy (errmsg, msg, len);
+ if (errmsg_len > len)
+ memset (&errmsg[len], ' ', errmsg_len-len);
+ }
+ return;
+ }
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
+}
+
+int
+_gfortran_caf_is_present (caf_token_t token,
+ int image_index __attribute__ ((unused)),
+ caf_reference_t *refs)
+{
+ const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
+ "only scalar indexes allowed.\n";
+ const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown reference type.\n";
+ const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown array reference type.\n";
+ size_t i;
+ caf_single_token_t single_token = TOKEN (token);
+ void *memptr = single_token->memptr;
+ gfc_descriptor_t *src = single_token->desc;
+ caf_reference_t *riter = refs;
+
+ while (riter)
+ {
+ switch (riter->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (riter->u.c.caf_token_offset)
+ {
+ single_token = *(caf_single_token_t*)
+ (memptr + riter->u.c.caf_token_offset);
+ memptr = single_token->memptr;
+ src = single_token->desc;
+ }
+ else
+ {
+ memptr += riter->u.c.offset;
+ src = (gfc_descriptor_t *)memptr;
+ }
+ break;
+ case CAF_REF_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_SINGLE:
+ memptr += (riter->u.a.dim[i].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[i]))
+ * GFC_DIMENSION_STRIDE (src->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_FULL:
+ /* A full array ref is allowed on the last reference only. */
+ if (riter->next == NULL)
+ break;
+ /* else fall through reporting an error. */
+ /* FALLTHROUGH */
+ case CAF_ARR_REF_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+ return 0;
+ default:
+ caf_internal_error (unknownarrreftype, 0, NULL, 0);
+ return 0;
+ }
+ }
+ break;
+ case CAF_REF_STATIC_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_SINGLE:
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_FULL:
+ /* A full array ref is allowed on the last reference only. */
+ if (riter->next == NULL)
+ break;
+ /* else fall through reporting an error. */
+ /* FALLTHROUGH */
+ case CAF_ARR_REF_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+ return 0;
+ default:
+ caf_internal_error (unknownarrreftype, 0, NULL, 0);
+ return 0;
+ }
+ }
+ break;
+ default:
+ caf_internal_error (unknownreftype, 0, NULL, 0);
+ return 0;
+ }
+ riter = riter->next;
+ }
+ return memptr != NULL;
+}
projects / thirdparty / gcc.git / blobdiff