2011-07-22 Tobias Burnus <burnus@net-b.de>
* trans-array.c (CAF_TOKEN_FIELD): New macro constant.
(gfc_conv_descriptor_token): New function.
* trans-array.h (gfc_conv_descriptor_token): New prototype.
* trans-types.c (gfc_get_array_descriptor_base): For coarrays
with -fcoarray=lib, append "void *token" to the array descriptor.
* trans-expr.c (gfc_conv_procedure_call): Handle token and offset
when passing a descriptor coarray to a nondescriptor dummy.
2011-07-22 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_lib_token_2.f90: New.
@@ -129,6 +129,7 @@ gfc_array_dataptr_type (tree desc)
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
#define DIMENSION_FIELD 3
+#define CAF_TOKEN_FIELD 4
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
@@ -267,6 +268,24 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
return tmp;
}
+
+tree
+gfc_conv_descriptor_token (tree desc)
+{
+ tree type;
+ tree field;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
+ field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
+ gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
+
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+
static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
@@ -429,6 +448,7 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
#undef OFFSET_FIELD
#undef DTYPE_FIELD
#undef DIMENSION_FIELD
+#undef CAF_TOKEN_FIELD
#undef STRIDE_SUBFIELD
#undef LBOUND_SUBFIELD
#undef UBOUND_SUBFIELD
@@ -143,6 +143,7 @@ tree gfc_conv_descriptor_dtype (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
+tree gfc_conv_descriptor_token (tree);
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree);
@@ -3395,48 +3395,62 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (fsym && fsym->attr.codimension
&& gfc_option.coarray == GFC_FCOARRAY_LIB
&& !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
- && (e == NULL
- || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (get_tree_for_caf_expr (e)))))
- /* FIXME: Remove the "||" condition when coarray descriptors have a
- "token" component. This condition occurs when passing an alloc
- coarray or assumed-shape dummy to an explict-shape dummy. */
+ && e == NULL)
{
/* Token and offset. */
VEC_safe_push (tree, gc, stringargs, null_pointer_node);
VEC_safe_push (tree, gc, stringargs,
build_int_cst (gfc_array_index_type, 0));
- gcc_assert (fsym->attr.optional || e != NULL); /* FIXME: "||" cond. */
+ gcc_assert (fsym->attr.optional);
}
else if (fsym && fsym->attr.codimension
&& !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
&& gfc_option.coarray == GFC_FCOARRAY_LIB)
{
tree caf_decl, caf_type;
- tree offset;
+ tree offset, tmp2;
caf_decl = get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
- gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ tmp = gfc_conv_descriptor_token (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
- VEC_safe_push (tree, gc, stringargs,
- GFC_TYPE_ARRAY_CAF_TOKEN (caf_type));
+ VEC_safe_push (tree, gc, stringargs, tmp);
- if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ offset = build_int_cst (gfc_array_index_type, 0);
+ else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
else
offset = build_int_cst (gfc_array_index_type, 0);
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))
- && POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ tmp = gfc_conv_descriptor_data_get (caf_decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (caf_type));
+ tmp = caf_decl;
+ }
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ tmp2 = parmse.expr;
+ }
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
- fold_convert (gfc_array_index_type,
- parmse.expr),
- fold_convert (gfc_array_index_type,
- caf_decl));
+ fold_convert (gfc_array_index_type, tmp2),
+ fold_convert (gfc_array_index_type, tmp));
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, tmp);
@@ -1664,6 +1664,14 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
arraytype, &chain);
TREE_NO_WARNING (decl) = 1;
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+ {
+ decl = gfc_add_field_to_struct_1 (fat_type,
+ get_identifier ("token"),
+ prvoid_type_node, &chain);
+ TREE_NO_WARNING (decl) = 1;
+ }
+
/* Finish off the type. */
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
@@ -0,0 +1,91 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Check whether TOKEN and OFFSET are correctly propagated
+!
+
+program main
+ implicit none
+ type t
+ integer(4) :: a, b
+ end type t
+ integer, allocatable :: caf[:]
+ type(t), allocatable :: caf_dt[:]
+
+ allocate (caf[*])
+ allocate (caf_dt[*])
+
+ caf = 42
+ caf_dt = t (1,2)
+ call sub (caf, caf_dt%b)
+ print *,caf, caf_dt%b
+ if (caf /= -99 .or. caf_dt%b /= -101) call abort ()
+ call sub_opt ()
+ call sub_opt (caf)
+ if (caf /= 124) call abort ()
+contains
+
+ subroutine sub (x1, x2)
+ integer :: x1[*], x2[*]
+ call sub2 (x1, x2)
+ end subroutine sub
+
+ subroutine sub2 (y1, y2)
+ integer :: y1[*], y2[*]
+
+ print *, y1, y2
+ if (y1 /= 42 .or. y2 /= 2) call abort ()
+ y1 = -99
+ y2 = -101
+ end subroutine sub2
+
+ subroutine sub_opt (z)
+ integer, optional :: z[*]
+ if (present (z)) then
+ if (z /= -99) call abort ()
+ z = 124
+ end if
+ end subroutine sub_opt
+
+end program main
+
+! SCAN TREE DUMP AND CLEANUP
+!
+! PROTOTYPE 1:
+!
+! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2,
+! void * restrict caf_token.4, integer(kind=8) caf_offset.5,
+! void * restrict caf_token.6, integer(kind=8) caf_offset.7)
+!
+! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
+!
+! PROTOTYPE 2:
+!
+! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2,
+! void * restrict caf_token.0, integer(kind=8) caf_offset.1,
+! void * restrict caf_token.2, integer(kind=8) caf_offset.3)
+!
+! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
+!
+! CALL 1
+!
+! sub ((integer(kind=4) *) caf.data, &((struct t * restrict) caf_dt.data)->b,
+! caf.token, 0, caf_dt.token, 4);
+!
+! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf.data, &\[^,\]*caf_dt.data.->b, caf.token, 0, caf_dt.token, 4\\)" 1 "original"} }
+!
+! sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2,
+! caf_token.4, NON_LVALUE_EXPR <caf_offset.5>,
+! caf_token.6, NON_LVALUE_EXPR <caf_offset.7>);
+!
+! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original"} }
+!
+! CALL 3
+!
+! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original"} }
+!
+! CALL 4
+!
+! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf.data, caf.token, 0\\)" 1 "original"} }
+!
+! { dg-final { cleanup-tree-dump "original" } }
Dear all, this patch continues a bit the project of argument passing with -fcoarray=lib. As a reminder: The coarray communication library uniquely identifies coarrays based on the token - and it needs to know the offset between the data you want and the base address of the coarray. This patch adds a "token" element as last element in the descriptor such that is can be easily ignored when passing a descriptor to a noncoarray descriptor dummy.* The patch additionally handles passing such an array to a nondescriptor coarray dummy. Build and regtested on x86-64-linux. OK for the trunk? * * * Planned as in follow up patches: * Actually setting the "token" variable in ALLOCATE. Daniel is working on that. * Handling assumed-shape coarrays: Besides actually setting the "token", one also needs to ensure that the "offset" is properly passed. With nested assumed-shape calls, the "offset" issue also occurs when passing such a coarray to a nondescriptor coarray dummy. I am not yet sure whether this can be handled without adding another component ("caf_offset") to the descriptor or whether it can be avoided by "misusing" other fields such as offset. Tobias (*) One currently simply passes the full array, but the planned proper way is to do a cast of the following form. However, as it works as is, fixing this will be of lower priority. struct DescriptorRank * {ref-all} tmparray = (struct DescriptorRankCorank * {ref-all})&coarray;