As testing by Alessandro revealed, vector subscripts weren't properly
handled.
This patch fixes the compiler side (or at least those issues I found).
In particular, for expressions ("get") it wrongly passed a NULL pointer,
additionally, I used the wrong "ar". For it and for assignments/push
("send", "sendget"), I also used the wrong rank value as one also passes
DIMEN_ELEMENT as DIMEN_RANGE.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
* * *
I still have to add vector subscript support to libcaf_single. I didn't
include an -fdump-tree-original test case, but I can add one if there
regarded as useful.
Attached is – besides the patch for trans-intrinsic.c – a debuging patch
for libcaf_single. I tested it with:
integer :: A(2,3)[*]
A(2,:) = A(1,[1,3,2])[1]
end
integer :: A(2,3)[*]
A(1,[1,3,2])[1] = A(2,:)
end
integer :: A(2,3)[*]
integer :: B(2,3)[*]
A(1,[1,3,2])[1] = B(1,[1,3,2])[1]
end
The output looks like (for the first one):
DEBUG: CAF_GET: 0x7fffb72f71d0
DEBUG: have vector for rank 2 [1]
DEBUG: dim=0: nvec = 0
DEBUG: (1:1:1)
DEBUG: dim=1: nvec = 3
DEBUG: 0: 1
DEBUG: 1: 3
DEBUG: 2: 2
Tobias
2014-12-17 Tobias Burnus <bur...@net-b.de>
* trans-intrinsic.c (gfc_conv_intrinsic_caf_get, conv_caf_send):
Fix vector handling.
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 0cce3cb..31cb6c7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1122,6 +1122,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
res_var = lhs;
dst_var = lhs;
+ vec = null_pointer_node;
+
gfc_init_se (&argse, NULL);
if (array_expr->rank == 0)
{
@@ -1164,10 +1166,12 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
has the wrong type if component references are done. */
gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
- gfc_get_dtype_rank_type (array_expr->rank, type));
+ gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+ : array_expr->rank,
+ type));
if (has_vector)
{
- vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar);
+ vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
*ar = ar2;
}
@@ -1195,8 +1199,6 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
if (lhs_kind == NULL_TREE)
lhs_kind = kind;
- vec = null_pointer_node;
-
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
@@ -1278,10 +1280,12 @@ conv_caf_send (gfc_code *code) {
lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type));
+ gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+ : lhs_expr->rank,
+ lhs_type));
if (has_vector)
{
- vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
+ vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
*ar = ar2;
}
}
@@ -1350,10 +1354,12 @@ conv_caf_send (gfc_code *code) {
tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (rhs_expr->rank, tmp2));
+ gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+ : rhs_expr->rank,
+ tmp2));
if (has_vector)
{
- rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar);
+ rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
*ar = ar2;
}
}
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 632d172..2c6d5ae 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -543,7 +543,7 @@ 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)),
+ caf_vector_t *src_vector,
gfc_descriptor_t *dest, int src_kind, int dst_kind,
bool may_require_tmp)
{
@@ -551,9 +551,43 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
size_t i, k, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
+ int src_rank = GFC_DESCRIPTOR_RANK (src);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+ if (src_vector)
+{
+__builtin_printf("DEBUG: CAF_GET: %p\n", src_vector);
+__builtin_printf("DEBUG: have vector for rank %d [%d]\n", src_rank, rank);
+for (j=0; j < src_rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, src_vector[j].nvec);
+if (src_vector[j].nvec == 0)
+ __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+ src_vector[j].u.triplet.lower_bound,
+ src_vector[j].u.triplet.upper_bound,
+ src_vector[j].u.triplet.stride);
+for (i=0; i < src_vector[j].nvec; i++)
+switch (src_vector[j].u.v.kind) {
+ case 1:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 2:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 4:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 8:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)src_vector[j].u.v.vector)[i]);
+ break;
+/* case 16:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)src_vector[j].u.v.vector)[i]);
+ break;*/
+}
+}
+}
+
if (rank == 0)
{
void *sr = (void *) ((char *) TOKEN (token) + offset);
@@ -744,6 +778,39 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
+ if (dst_vector)
+{
+__builtin_printf("DEBUG: CAF_SEND: %p\n", dst_vector);
+__builtin_printf("DEBUG: have vector for rank %d\n", rank);
+for (j=0; j < rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, dst_vector[j].nvec);
+if (dst_vector[j].nvec == 0)
+ __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+ dst_vector[j].u.triplet.lower_bound,
+ dst_vector[j].u.triplet.upper_bound,
+ dst_vector[j].u.triplet.stride);
+for (i=0; i < dst_vector[j].nvec; i++)
+switch (dst_vector[j].u.v.kind) {
+ case 1:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)dst_vector[j].u.v.vector)[i]);
+ break;
+ case 2:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)dst_vector[j].u.v.vector)[i]);
+ break;
+ case 4:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)dst_vector[j].u.v.vector)[i]);
+ break;
+ case 8:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)dst_vector[j].u.v.vector)[i]);
+ break;
+/* case 16:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)dst_vector[j].u.v.vector)[i]);
+ break;*/
+}
+}
+}
+
if (rank == 0)
{
void *dst = (void *) ((char *) TOKEN (token) + offset);
@@ -948,6 +1015,44 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
/* 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. */
+
+ int src_rank = GFC_DESCRIPTOR_RANK (src);
+ size_t i, k, size;
+ int j;
+ if (src_vector)
+{
+__builtin_printf("DEBUG: CAF_SENDGET: %p / %p\n", dst_vector, src_vector);
+__builtin_printf("DEBUG: have src vector for rank %d\n", src_rank);
+for (j=0; j < src_rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, src_vector[j].nvec);
+if (src_vector[j].nvec == 0)
+ __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+ src_vector[j].u.triplet.lower_bound,
+ src_vector[j].u.triplet.upper_bound,
+ src_vector[j].u.triplet.stride);
+for (i=0; i < src_vector[j].nvec; i++)
+switch (src_vector[j].u.v.kind) {
+ case 1:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 2:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 4:
+ __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)src_vector[j].u.v.vector)[i]);
+ break;
+ case 8:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)src_vector[j].u.v.vector)[i]);
+ break;
+/* case 16:
+ __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)src_vector[j].u.v.vector)[i]);
+ break;*/
+}
+}
+}
+
+
void *src_base = GFC_DESCRIPTOR_DATA (src);
GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
_gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
