OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
355436fb15
gcc/libgfortran/caf/single.c
Janne Blomqvist 3f5fabc0ea Character length cleanup for Coarray Fortran library 
Following the change to use size_t for Fortran character lengths (PR
78534), this patch modifies the Coarray ABI in a similar way. The
single-image implementation that is included in libgfortran is
updated, but this needs corresponding work in the OpenCoarray library
as well for multi-image support. I also fixed the types for the STOP
and ERROR STOP implementation in libgfortran, as the calling of them
is somewhat intertwined with the calling of the corresponding CAF
functions. I'll send the OpenCoarray changes as a separate pull
request to the OpenCoarrays repository.

Regtested on x86_64-pc-linux-gnu.

gcc/fortran/ChangeLog:

2018-02-22  Janne Blomqvist  <jb@gcc.gnu.org>

	* gfortran.texi: Update Coarray API description.
	* trans-decl.c (gfc_build_builtin_function_decls): Use size_t for
	character lengths, int for exit codes.
	(generate_coarray_sym_init): Use size_t for character length.
	* trans-intrinsic.c (conv_co_collective): Likewise.
	* trans-stmt.c (gfc_trans_lock_unlock): Likewise.
	(gfc_trans_event_post_wait): Likewise.
	(gfc_trans_sync): Likewise.
	(gfc_trans_stop): Use size_t for character lengths, int for exit
	codes.

libgfortran/ChangeLog:

2018-02-22  Janne Blomqvist  <jb@gcc.gnu.org>

	* libgfortran.h (stop_string): Use size_t for character length.
	* runtime/stop.c (stop_string): Likewise.
	(error_stop_string): Likewise.
	(stop_numeric): Use int for exit code.
	(error_stop_numeric): Likewise.
	* caf/libcaf.h: Remove stdint.h include.
	(_gfortran_caf_register): Use size_t for character length.
	(_gfortran_caf_deregister): Likewise.
	(_gfortran_caf_sync_all): Likewise.
	(_gfortran_caf_sync_memory): Likewise.
	(_gfortran_caf_sync_images): Likewise.
	(_gfortran_caf_stop_numeric): Use int for exit code.
	(_gfortran_caf_stop_str): Use size_t for character length.
	(_gfortran_caf_error_stop_str): Likewise.
	(_gfortran_caf_error_stop): Use int for exit code.
	(_gfortran_caf_co_broadcast): Use size_t for character length.
	(_gfortran_caf_co_sum): Likewise.
	(_gfortran_caf_co_min): Likewise.
	(_gfortran_caf_co_max): Likewise.
	(_gfortran_caf_co_reduce): Likewise.
	(_gfortran_caf_lock): Likewise.
	(_gfortran_caf_unlock): Likewise.
	(_gfortran_caf_event_post): Likewise.
	(_gfortran_caf_event_wait): Likewise.
	* caf/mpi.c (_gfortran_caf_register): Update implementation to
	match prototype.
	(_gfortran_caf_deregister): Likewise.
	(_gfortran_caf_sync_all): Likewise.
	(_gfortran_caf_sync_images): Likewise.
	(_gfortran_caf_error_stop_str): Likewise.
	(_gfortran_caf_error_stop): Likewise.
	* caf/single.c (caf_internal_error): Likewise.
	(_gfortran_caf_register): Likewise.
	(_gfortran_caf_deregister): Likewise.
	(_gfortran_caf_sync_all): Likewise.
	(_gfortran_caf_sync_memory): Likewise.
	(_gfortran_caf_sync_images): Likewise.
	(_gfortran_caf_stop_numeric): Likewise.
	(_gfortran_caf_stop_str): Likewise.
	(_gfortran_caf_error_stop_str): Likewise.
	(_gfortran_caf_error_stop): Likewise.
	(_gfortran_caf_co_broadcast): Likewise.
	(_gfortran_caf_co_sum): Likewise.
	(_gfortran_caf_co_min): Likewise.
	(_gfortran_caf_co_max): Likewise.
	(_gfortran_caf_co_reduce): Likewise.
	(_gfortran_caf_event_post): Likewise.
	(_gfortran_caf_event_wait): Likewise.
	(_gfortran_caf_lock): Likewise.
	(_gfortran_caf_unlock): Likewise.

From-SVN: r257894
2018-02-22 11:44:31 +02:00

3129 lines
91 KiB
C
Raw Blame History

/* Single-image implementation of GNU Fortran Coarray Library
Copyright (C) 2011-2018 Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
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
<http://www.gnu.org/licenses/>. */
#include "libcaf.h"
#include <stdio.h> /* For fputs and fprintf. */
#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, ...)
{
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,
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)))
{
}
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,
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);
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)),
size_t 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)),
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;
}
void
_gfortran_caf_sync_images (int count __attribute__ ((unused)),
int images[] __attribute__ ((unused)),
int *stat,
char *errmsg __attribute__ ((unused)),
size_t 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(int stop_code)
{
fprintf (stderr, "STOP %d\n", stop_code);
exit (0);
}
void
_gfortran_caf_stop_str(const char *string, size_t len)
{
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)
{
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.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 (int 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)),
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 can not 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 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,
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(): "
"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;
/* 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
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;
}
/* 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 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, 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(): "
"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, 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));
}
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));
}
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;
}
Reference in New Issue View Git Blame Copy Permalink