This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Thomas.Koenig@online.de: Fix PR libfortran/21333, in_pack / in_unpack alignment issues]
- From: Thomas Koenig <Thomas dot Koenig at online dot de>
- To: gcc-patches at gcc dot gnu dot org
- Date: Mon, 6 Jun 2005 22:48:59 +0200
- Subject: [Thomas.Koenig@online.de: Fix PR libfortran/21333, in_pack / in_unpack alignment issues]
Seems I forgot to forward this to gcc-patches. Here it is.
Thomas
----- Forwarded message from Thomas Koenig <Thomas.Koenig@online.de> -----
Hi gang,
here is the patch for PR 21333. Regression-tested on mainline on
ia64-unknown-linux-gnu and i686-pc-linux-gnu, regression test with
4.0 on i686-pc-linux-gnu is currently running.
OK for both (once the 4.0 test has passed)?
Thomas
2005-06-05 Thomas Koenig <Thomas.Koenig@onlinde.de>
PR libfortran/21333
* Makefile.am: Add in_pack_c4.c, in_pack_c8.c, in_unpack_c4.c
and in_unpack_c8.c.
* Makefile.in: Regenerate.
* libgfortran.h: Declare internal_pack_c4, internal_pack_c8,
internal_unpack_c4 and internal_unpack_c8.
* m4/in_pack.m4: Use rtype_ccode insteald of rtype_kind
in function name.
Use sizeof(rtype) as size for memory allocation.
* m4/in_unpack.m4: Use rtype_ccode insteald of rtype_kind
in function name.
* runtime/in_pack_generic.c: For real, integer and logical
call internal_pack_4 if size==4 and internal_pack_8 if
size==8.
For complex, call internal_pack_c4 if size==8 and
internal_pack_c8 if size==16.
* runtime/in_unpack_generic.c: For real, integer and logical
call internal_unpack_4 if size==4 and internal_unpack_8 if
size==8.
For complex, call internal_unpack_c4 if size==8 and
internal_unpack_c8 if size==16.
* generated/in_pack_i4.c: Regenerated.
* generated/in_pack_i8.c: Regenerated.
* generated/in_unpack_i4.c: Regenerated.
* generated/in_unpack_i8.c: Regenerated.
* generated/in_pack_c4.c: New file.
* generated/in_pack_c8.c: New file.
* generated/in_unpack_c4.c: New file.
* generated/in_unpack_c8.c: New file.
2005-05-06 Thomas Koenig <Thomas.Koenig@online.de>
* gfortran.fortran-torture/execute/in-pack.f90: New test.
! Check in_pack and in_unpack for integer and comlex types, with
! alignment issues thrown in for good measure.
program main
implicit none
complex(kind=4) :: a4(5),b4(5),aa4(5),bb4(5)
real(kind=4) :: r4(100)
equivalence(a4(1),r4(1)),(b4(1),r4(12))
complex(kind=8) :: a8(5),b8(5),aa8(5),bb8(5)
real(kind=8) :: r8(100)
equivalence(a8(1),r8(1)),(b8(1),r8(12))
integer(kind=4) :: i4(5),ii4(5)
integer(kind=8) :: i8(5),ii8(5)
integer :: i
a4 = (/(cmplx(i,-i,kind=4),i=1,5)/)
b4 = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
call csub4(a4(5:1:-1),b4(5:1:-1),5)
aa4 = (/(cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
if (any(aa4 /= a4)) call abort
bb4 = (/(2*cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
if (any(bb4 /= b4)) call abort
a8 = (/(cmplx(i,-i,kind=8),i=1,5)/)
b8 = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
call csub8(a8(5:1:-1),b8(5:1:-1),5)
aa8 = (/(cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
if (any(aa8 /= a8)) call abort
bb8 = (/(2*cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
if (any(bb8 /= b8)) call abort
i4 = (/(i, i=1,5)/)
call isub4(i4(5:1:-1),5)
ii4 = (/(5-i+1,i=1,5)/)
if (any(ii4 /= i4)) call abort
i8 = (/(i,i=1,5)/)
call isub8(i8(5:1:-1),5)
ii8 = (/(5-i+1,i=1,5)/)
if (any(ii8 /= i8)) call abort
end program main
subroutine csub4(a,b,n)
implicit none
complex(kind=4), dimension(n) :: a,b
complex(kind=4), dimension(n) :: aa, bb
integer :: n, i
aa = (/(cmplx(n-i+1,i-n-1,kind=4),i=1,n)/)
if (any(aa /= a)) call abort
bb = (/(2*cmplx(n-i+1,i-n-1,kind=4),i=1,5)/)
if (any(bb /= b)) call abort
a = (/(cmplx(i,-i,kind=4),i=1,5)/)
b = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
end subroutine csub4
subroutine csub8(a,b,n)
implicit none
complex(kind=8), dimension(n) :: a,b
complex(kind=8), dimension(n) :: aa, bb
integer :: n, i
aa = (/(cmplx(n-i+1,i-n-1,kind=8),i=1,n)/)
if (any(aa /= a)) call abort
bb = (/(2*cmplx(n-i+1,i-n-1,kind=8),i=1,5)/)
if (any(bb /= b)) call abort
a = (/(cmplx(i,-i,kind=8),i=1,5)/)
b = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
end subroutine csub8
subroutine isub4(a,n)
implicit none
integer(kind=4), dimension(n) :: a
integer(kind=4), dimension(n) :: aa
integer :: n, i
aa = (/(n-i+1,i=1,n)/)
if (any(aa /= a)) call abort
a = (/(i,i=1,5)/)
end subroutine isub4
subroutine isub8(a,n)
implicit none
integer(kind=8), dimension(n) :: a
integer(kind=8), dimension(n) :: aa
integer :: n, i
aa = (/(n-i+1,i=1,n)/)
if (any(aa /= a)) call abort
a = (/(i,i=1,5)/)
end subroutine isub8
Index: Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.35
diff -c -p -r1.35 Makefile.am
*** Makefile.am 18 May 2005 20:35:25 -0000 1.35
--- Makefile.am 5 Jun 2005 14:50:55 -0000
*************** generated/cshift1_8.c
*** 243,253 ****
in_pack_c = \
generated/in_pack_i4.c \
! generated/in_pack_i8.c
in_unpack_c = \
generated/in_unpack_i4.c \
! generated/in_unpack_i8.c
i_exponent_c = \
generated/exponent_r4.c \
--- 243,257 ----
in_pack_c = \
generated/in_pack_i4.c \
! generated/in_pack_i8.c \
! generated/in_pack_c4.c \
! generated/in_pack_c8.c
in_unpack_c = \
generated/in_unpack_i4.c \
! generated/in_unpack_i8.c \
! generated/in_unpack_c4.c \
! generated/in_unpack_c8.c
i_exponent_c = \
generated/exponent_r4.c \
Index: libgfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/libgfortran.h,v
retrieving revision 1.24
diff -c -p -r1.24 libgfortran.h
*** libgfortran.h 30 Apr 2005 20:51:29 -0000 1.24
--- libgfortran.h 5 Jun 2005 14:50:57 -0000
*************** internal_proto(reshape_packed);
*** 482,488 ****
/* Repacking functions. */
! /* ??? These four aren't currently used by the compiler, though we
certainly could do so. */
GFC_INTEGER_4 *internal_pack_4 (gfc_array_i4 *);
internal_proto(internal_pack_4);
--- 482,488 ----
/* Repacking functions. */
! /* ??? These eight aren't currently used by the compiler, though we
certainly could do so. */
GFC_INTEGER_4 *internal_pack_4 (gfc_array_i4 *);
internal_proto(internal_pack_4);
*************** internal_proto(internal_pack_4);
*** 490,501 ****
--- 490,513 ----
GFC_INTEGER_8 *internal_pack_8 (gfc_array_i8 *);
internal_proto(internal_pack_8);
+ GFC_COMPLEX_4 *internal_pack_c4 (gfc_array_c4 *);
+ internal_proto(internal_pack_c4);
+
+ GFC_COMPLEX_8 *internal_pack_c8 (gfc_array_c8 *);
+ internal_proto(internal_pack_c8);
+
extern void internal_unpack_4 (gfc_array_i4 *, const GFC_INTEGER_4 *);
internal_proto(internal_unpack_4);
extern void internal_unpack_8 (gfc_array_i8 *, const GFC_INTEGER_8 *);
internal_proto(internal_unpack_8);
+ extern void internal_unpack_c4 (gfc_array_c4 *, const GFC_COMPLEX_4 *);
+ internal_proto(internal_unpack_c4);
+
+ extern void internal_unpack_c8 (gfc_array_c8 *, const GFC_COMPLEX_8 *);
+ internal_proto(internal_unpack_c8);
+
/* string_intrinsics.c */
extern GFC_INTEGER_4 compare_string (GFC_INTEGER_4, const char *,
Index: m4/in_pack.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/in_pack.m4,v
retrieving revision 1.5
diff -c -p -r1.5 in_pack.m4
*** m4/in_pack.m4 4 May 2005 21:38:15 -0000 1.5
--- m4/in_pack.m4 5 Jun 2005 14:50:57 -0000
*************** include(iparm.m4)dnl
*** 37,45 ****
/* Allocates a block of memory with internal_malloc if the array needs
repacking. */
! dnl Only the kind (ie size) is used to name the function.
rtype_name *
! `internal_pack_'rtype_kind (rtype * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
--- 37,46 ----
/* Allocates a block of memory with internal_malloc if the array needs
repacking. */
! dnl The kind (ie size) is used to name the function for logicals, integers
! dnl and reals. For complex, it's c4 or c8.
rtype_name *
! `internal_pack_'rtype_ccode (rtype * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
*************** rtype_name *
*** 84,90 ****
return source->data;
/* Allocate storage for the destination. */
! destptr = (rtype_name *)internal_malloc_size (ssize * rtype_kind);
dest = destptr;
src = source->data;
stride0 = stride[0];
--- 85,91 ----
return source->data;
/* Allocate storage for the destination. */
! destptr = (rtype_name *)internal_malloc_size (ssize * sizeof (rtype));
dest = destptr;
src = source->data;
stride0 = stride[0];
Index: m4/in_unpack.m4
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/m4/in_unpack.m4,v
retrieving revision 1.5
diff -c -p -r1.5 in_unpack.m4
*** m4/in_unpack.m4 4 May 2005 21:38:15 -0000 1.5
--- m4/in_unpack.m4 5 Jun 2005 14:50:57 -0000
*************** Boston, MA 02111-1307, USA. */
*** 35,43 ****
#include "libgfortran.h"'
include(iparm.m4)dnl
! dnl Only the kind (ie size) is used to name the function.
void
! `internal_unpack_'rtype_kind (rtype * d, const rtype_name * src)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
--- 35,44 ----
#include "libgfortran.h"'
include(iparm.m4)dnl
! dnl Only the kind (ie size) is used to name the function for integers,
! dnl reals and logicals. For complex, it's c4 and c8.
void
! `internal_unpack_'rtype_ccode (rtype * d, const rtype_name * src)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
Index: runtime/in_pack_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/runtime/in_pack_generic.c,v
retrieving revision 1.6
diff -c -p -r1.6 in_pack_generic.c
*** runtime/in_pack_generic.c 27 May 2005 19:00:50 -0000 1.6
--- runtime/in_pack_generic.c 5 Jun 2005 14:50:57 -0000
*************** internal_pack (gfc_array_char * source)
*** 52,57 ****
--- 52,58 ----
int n;
int packed;
index_type size;
+ int type;
if (source->dim[0].stride == 0)
{
*************** internal_pack (gfc_array_char * source)
*** 59,72 ****
return source->data;
}
size = GFC_DESCRIPTOR_SIZE (source);
! switch (size)
{
! case 4:
! return internal_pack_4 ((gfc_array_i4 *)source);
! case 8:
! return internal_pack_8 ((gfc_array_i8 *)source);
}
dim = GFC_DESCRIPTOR_RANK (source);
--- 60,95 ----
return source->data;
}
+ type = GFC_DESCRIPTOR_TYPE (source);
size = GFC_DESCRIPTOR_SIZE (source);
! switch (type)
{
! case GFC_DTYPE_INTEGER:
! case GFC_DTYPE_LOGICAL:
! case GFC_DTYPE_REAL:
! switch (size)
! {
! case 4:
! return internal_pack_4 ((gfc_array_i4 *)source);
!
! case 8:
! return internal_pack_8 ((gfc_array_i8 *)source);
! }
! break;
!
! case GFC_DTYPE_COMPLEX:
! switch (size)
! {
! case 8:
! return internal_pack_c4 ((gfc_array_c4 *)source);
!
! case 16:
! return internal_pack_c8 ((gfc_array_c8 *)source);
! }
! break;
! default:
! break;
}
dim = GFC_DESCRIPTOR_RANK (source);
Index: runtime/in_unpack_generic.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/runtime/in_unpack_generic.c,v
retrieving revision 1.6
diff -c -p -r1.6 in_unpack_generic.c
*** runtime/in_unpack_generic.c 27 May 2005 19:00:50 -0000 1.6
--- runtime/in_unpack_generic.c 5 Jun 2005 14:50:57 -0000
*************** internal_unpack (gfc_array_char * d, con
*** 50,71 ****
const char *src;
int n;
int size;
dest = d->data;
/* This check may be redundant, but do it anyway. */
if (s == dest || !s)
return;
size = GFC_DESCRIPTOR_SIZE (d);
! switch (size)
{
! case 4:
! internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s);
! return;
!
! case 8:
! internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s);
! return;
}
if (d->dim[0].stride == 0)
--- 50,94 ----
const char *src;
int n;
int size;
+ int type;
dest = d->data;
/* This check may be redundant, but do it anyway. */
if (s == dest || !s)
return;
+ type = GFC_DESCRIPTOR_TYPE (d);
size = GFC_DESCRIPTOR_SIZE (d);
! switch (type)
{
! case GFC_DTYPE_INTEGER:
! case GFC_DTYPE_LOGICAL:
! case GFC_DTYPE_REAL:
! switch (size)
! {
! case 4:
! internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s);
! return;
!
! case 8:
! internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s);
! return;
! }
! break;
!
! case GFC_DTYPE_COMPLEX:
! switch (size)
! {
! case 8:
! internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
! return;
!
! case 16:
! internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
! return;
! }
! default:
! break;
}
if (d->dim[0].stride == 0)
----- End forwarded message -----