/* Single-image implementation of GNU Fortran Coarray Library Copyright (C) 2011-2017 Free Software Foundation, Inc. Contributed by Tobias Burnus This file is part of the GNU Fortran Coarray Runtime Library (libcaf). Libcaf is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. Libcaf is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. Under Section 7 of GPL version 3, you are granted additional permissions described in the GCC Runtime Library Exception, version 3.1, as published by the Free Software Foundation. You should have received a copy of the GNU General Public License and a copy of the GCC Runtime Library Exception along with this program; see the files COPYING3 and COPYING.RUNTIME respectively. If not, see . */ #include "libcaf.h" #include /* For fputs and fprintf. */ #include /* For exit and malloc. */ #include /* For memcpy and memset. */ #include /* For variadic arguments. */ #include /* 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, ...) { va_list ap; fprintf (stderr, "Fortran runtime error: "); va_start (ap, message); vfprintf (stderr, message, ap); va_end (ap); fprintf (stderr, "\n"); /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */ exit (EXIT_FAILURE); } /* Error handling is similar everytime. */ static void caf_internal_error (const char *msg, int *stat, char *errmsg, int errmsg_len, ...) { va_list args; va_start (args, errmsg_len); if (stat) { *stat = 1; if (errmsg_len > 0) { size_t len = snprintf (errmsg, errmsg_len, msg, args); if ((size_t)errmsg_len > 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))) { } void _gfortran_caf_finalize (void) { while (caf_static_list != NULL) { caf_static_t *tmp = caf_static_list->prev; free (caf_static_list->token); free (caf_static_list); caf_static_list = tmp; } } 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, int 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); if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY) *token = malloc (sizeof (struct caf_single_token)); if (unlikely (*token == NULL || (local == NULL && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY))) { /* 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 || 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; caf_static_list = tmp; } GFC_DESCRIPTOR_DATA (data) = local; } void _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, char *errmsg __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { 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))) { __asm__ __volatile__ ("":::"memory"); if (stat) *stat = 0; } void _gfortran_caf_sync_memory (int *stat, char *errmsg __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { __asm__ __volatile__ ("":::"memory"); if (stat) *stat = 0; } void _gfortran_caf_sync_images (int count __attribute__ ((unused)), int images[] __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { #ifdef GFC_CAF_CHECK int i; for (i = 0; i < count; i++) if (images[i] != 1) { fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC " "IMAGES", images[i]); exit (EXIT_FAILURE); } #endif __asm__ __volatile__ ("":::"memory"); if (stat) *stat = 0; } void _gfortran_caf_stop_numeric(int32_t stop_code) { fprintf (stderr, "STOP %d\n", stop_code); exit (0); } void _gfortran_caf_stop_str(const char *string, int32_t len) { fputs ("STOP ", stderr); while (len--) fputc (*(string++), stderr); fputs ("\n", stderr); exit (0); } void _gfortran_caf_error_stop_str (const char *string, int32_t len) { 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 can not 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 = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) | (local_kind << GFC_DTYPE_SIZE_SHIFT)); /* 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 = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) | (local_kind << GFC_DTYPE_SIZE_SHIFT)); /* 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) { 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)), int 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)), int 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)), int 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)), int 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)), int 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) { 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); int src_type = -1; switch (ref->type) { case CAF_REF_COMPONENT: /* Because the token is always registered after the component, its offset is always greater zeor. */ if (ref->u.c.caf_token_offset > 0) copy_data (ds, *(void **)(sr + ref->u.c.offset), GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst), dst_kind, src_kind, dst_size, ref->item_size, 1, stat); else copy_data (ds, sr + ref->u.c.offset, GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, dst_size, ref->item_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: src_type = ref->u.a.static_array_type; /* 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 == -1 ? GFC_DESCRIPTOR_TYPE (src) : 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) get_for_ref (ref->next, i, dst_index, *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst, (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc, ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1, stat); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); return; /* The OPEN_* are mapped to a RANGE and therefore can not 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) { 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(): " "can not 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; 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_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; } /* 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 can not 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; } /* 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); /* 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); } 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) { 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;; int dst_type = -1; 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 { /* When no destination descriptor is present, assume that source and dest type are identical. */ dst_type = GFC_DESCRIPTOR_TYPE (src); 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 != NULL ? GFC_DESCRIPTOR_TYPE (dst) : GFC_DESCRIPTOR_TYPE (src), GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: dst_type = ref->u.a.static_array_type; /* 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 * ref->item_size, dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) : dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, num, stat); } else copy_data (ds, sr, dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) : 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); send_by_ref (ref->next, i, src_index, single_token, single_token->desc, src, ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim, 1, size, stat); } 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); 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); return; /* The OPEN_* are mapped to a RANGE and therefore can not 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) { 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(): " "can not 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 can not 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); 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) { gfc_array_void temp; _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs, dst_kind, src_kind, may_require_tmp, true, src_stat); if (src_stat && *src_stat != 0) return; _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs, dst_kind, src_kind, may_require_tmp, true, dst_stat); 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)), int 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)), int 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, int 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) { 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; } _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); } void _gfortran_caf_unlock (caf_token_t token, size_t index, int image_index __attribute__ ((unused)), int *stat, char *errmsg, int 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) { 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; } _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); } 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; }