procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
gcc/libgfortran/intrinsics/unpack_generic.c
Jakub Jelinek 133d0d422e fortran, libgfortran: Avoid using libquadmath for glibc 2.26+ 
As mentioned by Joseph in PR105101, glibc 2.26 or later has on x86
(both -m32/-m64), powerpc64le, ia64 and mips support for
*f128 math/complex APIs plus strtof128 and strfromf128, and these APIs allow
us to avoid libquadmath for Fortran purposes on these architectures,
replace *q math/complex APIs, strtof128 instead of strtoflt128 and,
while strfromf128 unfortunately isn't a perfect replacement to
quadmath_snprintf, it can be made to work.

The advantage of this is that when configured against such glibcs
(2.26 is now almost 5 years old), we can avoid linking against an extra shared
library and the math support in glibc is maintained better than libquadmath.

We need both a compiler change (so that for glibc 2.26+ it uses *f128 APIs
instead of *q) and library change.

The above mentioned problem with strfromf128 is that the strfrom* functions
are severely restricted versions of snprintf.  In libgfortran, we handle
!isfinite differently and just use snprintf/quadmath_snprintf for
%+-#.*{L,Q}{f,e} printing.
strfrom* doesn't allow +, -, # modifiers and it only supports .34 or
similar precision, not .* .  The L/Q etc. letters are omitted.
The + is there to force + sign at the start if it is positive.
Workaround in the patch is to add the + at the start manually for
!signbit (val).
The - (left alignment instead of right) I don't understand why we need it,
when minimum field width isn't specified (for strfrom* can't be specified),
no padding is ever added anywhere I believe.
The # is to force adding . - workaround is to search for first . or e or '\0'
character, if it is '\0', just append ., if it is e, insert . before e and
memmove the rest (which is just a few bytes, e, +/- and at most a few digits)
one byte later.
The .* case is handled by creating the format string for strfrom* by
snprintf into a temporary buffer.

As requested, this patch also switches from using __float128 type in
libgfortran to _Float128 which is equivalent on all arches that support
__float128.

The change is done in a backwards compatible change, when GCC is configured
against glibc 2.26 or newer, libgfortran.so.5 itself doesn't link against
-lquadmath nor uses any libquadmath APIs, libgfortran.a doesn't use any
libquadmath APIs either.  User programs and libraries when being linked
by gfortran driver are linked against -lgfortran and -lquadmath, but
the latter only in the --as-needed linker mode, which means it needs
to be around during linking and will be linked in if there are any
calls to math/complex functions with real(kind=16) or complex(kind=16)
in compilation units compiled by older versions of gcc, but if either
user code doesn't call those math/complex functions for the largest
supported kind, or the code is recompiled by gcc with this change in,
libquadmath won't be linked in.

2022-06-28  Jakub Jelinek  <jakub@redhat.com>

gcc/fortran/
	* gfortran.h (gfc_real_info): Add use_iec_60559 bitfield.
	* trans-types.h (gfc_real16_use_iec_60559): Declare.
	* trans-types.cc (gfc_real16_use_iec_60559): Define.
	(gfc_init_kinds): When building powerpc64le-linux libgfortran
	on glibc 2.26 to 2.31, set gfc_real16_use_iec_60559 and
	use_iec_60559.
	(gfc_build_real_type): Set gfc_real16_use_iec_60559 and use_iec_60559
	on glibc 2.26 or later.
	* trans-intrinsic.cc (gfc_build_intrinsic_lib_fndecls): Adjust
	comment.  Handle gfc_real16_use_iec_60559.
	(gfc_get_intrinsic_lib_fndecl): Handle use_iec_60559.
libgfortran/
	* configure.ac: Check for strtof128 and strfromf128.
	Check for math and complex *f128 functions.  Set
	have_iec_60559_libc_support to yes if *f128 support is around, for
	--enable-libquadmath-support default to "default" rather than yes if
	have_iec_60559_libc_support is yes.
	* acinclude.m4 (LIBGFOR_CHECK_FLOAT128): Test
	_Float128/_Complex _Float128 rather than __float128 and
	_Complex float __attribute__((mode(TC))).  If libquadmath support
	is defaulted and have_iec_60559_libc_support is yes, define and subst
	USE_IEC_60559.  Remove unused LIBGFOR_BUILD_QUAD conditional.
	* Makefile.am (kinds.h): Pass @USE_IEC_60559@ as an extra
	mk-kinds-h.sh argument.
	* mk-kinds-h.sh: Accept 4th use_iec_60559 argument.  Use
	_Float128/_Complex _Float128 types instead of __float128 and
	_Complex float __attribute__((mode(TC))), and if use_iec_60559 is yes,
	use f128 suffix instead of q and define GFC_REAL_16_USE_IEC_60559.
	* kinds-override.h: Use _Float128/_Complex _Float128 types instead of
	__float128 and _Complex float __attribute__((mode(TC))), if
	USE_IEC_60559 is defined, use f128 suffixes instead of q and
	define GFC_REAL_17_USE_IEC_60559.
	* libgfortran.h: Don't include quadmath_weak.h if USE_IEC_60559 is
	defined.
	(GFC_REAL_16_INFINITY, GFC_REAL_16_QUIET_NAN): Define
	for GFC_REAL_16_USE_IEC_60559 differently.
	* caf/single.c (convert_type): Use _Float128/_Complex _Float128
	instead of __float128 and _Complex float __attribute__((mode(TC))).
	For HAVE_GFC_REAL_10 when HAVE_GFC_REAL_16 isn't defined use
	_Complex long double instead of long double.
	* ieee/issignaling_fallback.h (ieee854_float128_shape_type): Use
	_Float128 instead of __float128.
	(__issignalingf128): Change argument type to _Float128.
	(issignaling): Use _Float128 instead of __float128 in _Generic.
	* intrinsics/cshift0.c (cshift0): Use _Float128 instead of __float128
	in a comment.  Fix a comment typo, logn double -> long double.
	* intrinsics/erfc_scaled.c (_THRESH, _M_2_SQRTPI, _INF, _ERFC, _EXP):
	Use different definitions if GFC_REAL_16_USE_IEC_60559.
	(_THRESH, _M_2_SQRTPI): Use GFC_REAL_17_LITERAL macro.
	(_ERFC, _EXP): Use different definitions if GFC_REAL_17_USE_IEC_60559.
	* intrinsics/spread_generic.c (spread, spread_scalar): Use _Float128
	instead of __float128 in a comment.  Fix a comment typo,
	logn double -> long double.
	* intrinsics/trigd.c (ENABLE_SIND, ENABLE_COSD, ENABLE_TAND): Handle
	GFC_REAL_16_USE_IEC_60559.
	* intrinsics/pack_generic.c (pack): Use _Float128 instead of
	__float128 in a comment.  Fix a comment typo, logn double ->
	long double.
	* intrinsics/unpack_generic.c (unpack1, unpack0): Likewise.
	* runtime/in_pack_generic.c (internal_pack): Likewise.
	* runtime/in_unpack_generic.c (internal_unpack): Likewise.
	* io/read.c (convert_real, convert_infnan): Handle
	GFC_REAL_16_USE_IEC_60559 and GFC_REAL_17_USE_IEC_60559.
	* io/transfer128.c (tmp1, tmp2): Don't define if libquadmath
	isn't needed.
	* io/write_float.def (gfor_strfromf128): New function.
	(DTOA2Q, FDTOA2Q): Define differently if
	GFC_REAL_16_USE_IEC_60559 or GFC_REAL_17_USE_IEC_60559.
	* m4/mtype.m4: Use different suffix if GFC_REAL_16_USE_IEC_60559
	or GFC_REAL_17_USE_IEC_60559.
	* config.h.in: Regenerated.
	* configure: Regenerated.
	* Makefile.in: Regenerated.
	* generated/bessel_r16.c: Regenerated.
	* generated/bessel_r17.c: Regenerated.
	* generated/norm2_r16.c: Regenerated.
	* generated/norm2_r17.c: Regenerated.
2022-06-28 13:14:45 +02:00

650 lines
18 KiB
C
Raw Blame History

/* Generic implementation of the UNPACK intrinsic
Copyright (C) 2002-2022 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran 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 of the License, or (at your option) any later version.
Ligbfortran 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 "libgfortran.h"
#include <assert.h>
#include <string.h>
/* All the bounds checking for unpack in one function. If field is NULL,
we don't check it, for the unpack0 functions. */
static void
unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field)
{
index_type vec_size, mask_count;
vec_size = size0 ((array_t *) vector);
mask_count = count_0 (mask);
if (vec_size < mask_count)
runtime_error ("Incorrect size of return value in UNPACK"
" intrinsic: should be at least %ld, is"
" %ld", (long int) mask_count,
(long int) vec_size);
if (field != NULL)
bounds_equal_extents ((array_t *) field, (array_t *) mask,
"FIELD", "UNPACK");
if (ret->base_addr != NULL)
bounds_equal_extents ((array_t *) ret, (array_t *) mask,
"return value", "UNPACK");
}
static void
unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field,
index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rs;
char * restrict rptr;
/* v.* indicates the vector array. */
index_type vstride0;
char *vptr;
/* f.* indicates the field array. */
index_type fstride[GFC_MAX_DIMENSIONS];
index_type fstride0;
const char *fptr;
/* m.* indicates the mask array. */
index_type mstride[GFC_MAX_DIMENSIONS];
index_type mstride0;
const GFC_LOGICAL_1 *mptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
int empty;
int mask_kind;
empty = 0;
mptr = mask->base_addr;
/* Use the same loop for all logical types, by using GFC_LOGICAL_1
and using shifting to address size and endian issues. */
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
{
/* Don't convert a NULL pointer as we use test for NULL below. */
if (mptr)
mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
}
else
runtime_error ("Funny sized logical array");
if (ret->base_addr == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
dim = GFC_DESCRIPTOR_RANK (mask);
rs = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
GFC_DIMENSION_SET(ret->dim[n], 0,
GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
rs *= extent[n];
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, size);
}
else
{
dim = GFC_DESCRIPTOR_RANK (ret);
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
}
}
if (empty)
return;
/* This assert makes sure GCC knows we can access *stride[0] later. */
assert (dim > 0);
vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
rstride0 = rstride[0];
fstride0 = fstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
fptr = field->base_addr;
vptr = vector->base_addr;
while (rptr)
{
if (*mptr)
{
/* From vector. */
memcpy (rptr, vptr, size);
vptr += vstride0;
}
else
{
/* From field. */
memcpy (rptr, fptr, size);
}
/* Advance to the next element. */
rptr += rstride0;
fptr += fstride0;
mptr += mstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * extent[n];
fptr -= fstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
fptr += fstride[n];
mptr += mstride[n];
}
}
}
}
extern void unpack1 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l1 *, const gfc_array_char *);
export_proto(unpack1);
void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field)
{
index_type type_size;
index_type size;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
type_size = GFC_DTYPE_TYPE_SIZE (vector);
size = GFC_DESCRIPTOR_SIZE (vector);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (gfc_array_i1 *) field);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (gfc_array_i2 *) field);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (gfc_array_i4 *) field);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (gfc_array_i8 *) field);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (gfc_array_i16 *) field);
return;
#endif
case GFC_DTYPE_REAL_4:
unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
mask, (gfc_array_r4 *) field);
return;
case GFC_DTYPE_REAL_8:
unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
mask, (gfc_array_r8 *) field);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
_Float128, we have sizeof(long double) == sizeof(_Float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
mask, (gfc_array_r10 *) field);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
mask, (gfc_array_r16 *) field);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
mask, (gfc_array_c4 *) field);
return;
case GFC_DTYPE_COMPLEX_8:
unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
mask, (gfc_array_c8 *) field);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
_Float128, we have sizeof(long double) == sizeof(_Float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
mask, (gfc_array_c10 *) field);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
mask, (gfc_array_c16 *) field);
return;
# endif
#endif
}
switch (GFC_DESCRIPTOR_SIZE(ret))
{
case 1:
unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (gfc_array_i1 *) field);
return;
case 2:
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
|| GFC_UNALIGNED_2(field->base_addr))
break;
else
{
unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (gfc_array_i2 *) field);
return;
}
case 4:
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
|| GFC_UNALIGNED_4(field->base_addr))
break;
else
{
unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (gfc_array_i4 *) field);
return;
}
case 8:
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
|| GFC_UNALIGNED_8(field->base_addr))
break;
else
{
unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (gfc_array_i8 *) field);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case 16:
if (GFC_UNALIGNED_16(ret->base_addr)
|| GFC_UNALIGNED_16(vector->base_addr)
|| GFC_UNALIGNED_16(field->base_addr))
break;
else
{
unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (gfc_array_i16 *) field);
return;
}
#endif
default:
break;
}
unpack_internal (ret, vector, mask, field, size);
}
extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
const gfc_array_char *, const gfc_array_l1 *,
const gfc_array_char *, GFC_INTEGER_4,
GFC_INTEGER_4);
export_proto(unpack1_char);
void
unpack1_char (gfc_array_char *ret,
GFC_INTEGER_4 ret_length __attribute__((unused)),
const gfc_array_char *vector, const gfc_array_l1 *mask,
const gfc_array_char *field, GFC_INTEGER_4 vector_length,
GFC_INTEGER_4 field_length __attribute__((unused)))
{
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
unpack_internal (ret, vector, mask, field, vector_length);
}
extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
const gfc_array_char *, const gfc_array_l1 *,
const gfc_array_char *, GFC_INTEGER_4,
GFC_INTEGER_4);
export_proto(unpack1_char4);
void
unpack1_char4 (gfc_array_char *ret,
GFC_INTEGER_4 ret_length __attribute__((unused)),
const gfc_array_char *vector, const gfc_array_l1 *mask,
const gfc_array_char *field, GFC_INTEGER_4 vector_length,
GFC_INTEGER_4 field_length __attribute__((unused)))
{
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
unpack_internal (ret, vector, mask, field,
vector_length * sizeof (gfc_char4_t));
}
extern void unpack0 (gfc_array_char *, const gfc_array_char *,
const gfc_array_l1 *, char *);
export_proto(unpack0);
void
unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, char *field)
{
gfc_array_char tmp;
index_type type_size;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
type_size = GFC_DTYPE_TYPE_SIZE (vector);
switch (type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (GFC_INTEGER_1 *) field);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (GFC_INTEGER_2 *) field);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (GFC_INTEGER_4 *) field);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (GFC_INTEGER_8 *) field);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (GFC_INTEGER_16 *) field);
return;
#endif
case GFC_DTYPE_REAL_4:
unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
mask, (GFC_REAL_4 *) field);
return;
case GFC_DTYPE_REAL_8:
unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
mask, (GFC_REAL_8 *) field);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
_Float128, we have sizeof(long double) == sizeof(_Float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
mask, (GFC_REAL_10 *) field);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
mask, (GFC_REAL_16 *) field);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
mask, (GFC_COMPLEX_4 *) field);
return;
case GFC_DTYPE_COMPLEX_8:
unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
mask, (GFC_COMPLEX_8 *) field);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
_Float128, we have sizeof(long double) == sizeof(_Float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
mask, (GFC_COMPLEX_10 *) field);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
mask, (GFC_COMPLEX_16 *) field);
return;
# endif
#endif
}
switch (GFC_DESCRIPTOR_SIZE(ret))
{
case 1:
unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (GFC_INTEGER_1 *) field);
return;
case 2:
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
|| GFC_UNALIGNED_2(field))
break;
else
{
unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (GFC_INTEGER_2 *) field);
return;
}
case 4:
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
|| GFC_UNALIGNED_4(field))
break;
else
{
unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (GFC_INTEGER_4 *) field);
return;
}
case 8:
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
|| GFC_UNALIGNED_8(field))
break;
else
{
unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (GFC_INTEGER_8 *) field);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case 16:
if (GFC_UNALIGNED_16(ret->base_addr)
|| GFC_UNALIGNED_16(vector->base_addr)
|| GFC_UNALIGNED_16(field))
break;
else
{
unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (GFC_INTEGER_16 *) field);
return;
}
#endif
}
memset (&tmp, 0, sizeof (tmp));
GFC_DTYPE_CLEAR(&tmp);
tmp.base_addr = field;
unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
}
extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
const gfc_array_char *, const gfc_array_l1 *,
char *, GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(unpack0_char);
void
unpack0_char (gfc_array_char *ret,
GFC_INTEGER_4 ret_length __attribute__((unused)),
const gfc_array_char *vector, const gfc_array_l1 *mask,
char *field, GFC_INTEGER_4 vector_length,
GFC_INTEGER_4 field_length __attribute__((unused)))
{
gfc_array_char tmp;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
memset (&tmp, 0, sizeof (tmp));
GFC_DTYPE_CLEAR(&tmp);
tmp.base_addr = field;
unpack_internal (ret, vector, mask, &tmp, vector_length);
}
extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
const gfc_array_char *, const gfc_array_l1 *,
char *, GFC_INTEGER_4, GFC_INTEGER_4);
export_proto(unpack0_char4);
void
unpack0_char4 (gfc_array_char *ret,
GFC_INTEGER_4 ret_length __attribute__((unused)),
const gfc_array_char *vector, const gfc_array_l1 *mask,
char *field, GFC_INTEGER_4 vector_length,
GFC_INTEGER_4 field_length __attribute__((unused)))
{
gfc_array_char tmp;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
memset (&tmp, 0, sizeof (tmp));
GFC_DTYPE_CLEAR(&tmp);
tmp.base_addr = field;
unpack_internal (ret, vector, mask, &tmp,
vector_length * sizeof (gfc_char4_t));
}
Reference in a new issue View git blame Copy permalink