Dear all,
this patch added token/offset support for assumed-shape coarray dummies
(with .-fcoarray=lib).
Build and regtested.
OK for the trunk?
* * *
BACKGROUND
For coarrays with -fcoarray=lib, for remote access, one needs to know
two things: token and offset.
a) A token (of type "void *") identifies the coarray in the library; its
value is set when the coarray is registered. (For instance, it could
store the base address of the coarray on all images).
b) The offset between the base address of the coarray and the value one
wants to assign.
Recall, if
type(t) :: a(:)[*]
is a coarray (is this case: an assumed-shape dummy argument), then all
of the following are also coarrays: a, a(1:4), a(1), a(1)%direct_comp,
a(2)%direct_comp(2:7), a(4)%direct_comp(3)
CURRENT IMPLEMENTATION for descriptorless and allocatable coarrays
For descriptorless coarrays (scalar or array), those values are stored
as language-specific type nodes (TYPE_LANG_SPECIFIC), namely:
GFC_TYPE_ARRAY_CAF_TOKEN and .GFC_TYPE_ARRAY_CAF_OFFSET.
For descriptorless coarray dummies (scalar or array), the token and the
offset are passed as hidden dummy arguments - similar to string lengths.
For allocatable coarrays (array and scalar), the cobound is transferred
via additional dimension triplets and the the token is stored in the
descriptor as tailing component. The token is accessible via
gfc_conv_descriptor_token.
THIS PATCH: Assumed-shape coarrays
Assumed shape coarrays are declared as, e.g.,
integer :: A(:,:)[*]
thus, contrary to deferred-shape/allocatable coarrays, the codimension
does not need to be passed (and the corank can be differ between actual
and dummy argument). However, both token and offset are important since
this information is not passed.
Handled by passing the token/offset as hidden argument and saving it in
a lang_decl node.
Tobias
2011-08-23 Tobias Burnus <bur...@net-b.de>
* trans-array.c (gfc_conv_descriptor_token): Add assert.
* trans-decl.c (gfc_build_qualified_array,
create_function_arglist): Handle assumed-shape arrays.
* trans-expr.c (gfc_conv_procedure_call): Ditto.
* trans-types.c (gfc_get_array_descriptor_base): Ditto, don't
add "caf_token" to assumed-shape descriptors, new akind argument.
(gfc_get_array_type_bounds): Pass akind.
* trans.h (lang_decl): New elements caf_offset and token.
(GFC_DECL_TOKEN, GFC_DECL_CAF_OFFSET): New macros.
2011-08-23 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/coarray_lib_token_4.f90: New.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3a75658..c5e1940 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -277,6 +277,7 @@ gfc_conv_descriptor_token (tree desc)
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
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);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cdbb375..1059a42 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -755,6 +755,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
&& !sym->attr.contained;
if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && sym->as->type != AS_ASSUMED_SHAPE
&& GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
{
tree token;
@@ -2104,12 +2105,11 @@ create_function_arglist (gfc_symbol * sym)
f->sym->backend_decl = parm;
- /* Coarrays which do not use a descriptor pass with -fcoarray=lib the
- token and the offset as hidden arguments. */
+ /* Coarrays which are descriptorless or assumed-shape pass with
+ -fcoarray=lib the token and the offset as hidden arguments. */
if (f->sym->attr.codimension
&& gfc_option.coarray == GFC_FCOARRAY_LIB
- && !f->sym->attr.allocatable
- && f->sym->as->type != AS_ASSUMED_SHAPE)
+ && !f->sym->attr.allocatable)
{
tree caf_type;
tree token;
@@ -2119,12 +2119,24 @@ create_function_arglist (gfc_symbol * sym)
&& !sym->attr.is_bind_c);
caf_type = TREE_TYPE (f->sym->backend_decl);
- gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
token = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_token"),
build_qualified_type (pvoid_type_node,
TYPE_QUAL_RESTRICT));
- GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+ if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
+ || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
+ if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
+ gfc_allocate_lang_decl (f->sym->backend_decl);
+ GFC_DECL_TOKEN (f->sym->backend_decl) = token;
+ }
+ else
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
+ GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+ }
+
DECL_CONTEXT (token) = fndecl;
DECL_ARTIFICIAL (token) = 1;
DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
@@ -2132,12 +2144,21 @@ create_function_arglist (gfc_symbol * sym)
hidden_arglist = chainon (hidden_arglist, token);
gfc_finish_decl (token);
- gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
offset = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_offset"),
gfc_array_index_type);
- GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+ if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
+ == NULL_TREE);
+ GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
+ }
+ else
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+ GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+ }
DECL_CONTEXT (offset) = fndecl;
DECL_ARTIFICIAL (offset) = 1;
DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 39a83ce..db8a89f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3390,11 +3390,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
VEC_safe_push (tree, gc, stringargs, parmse.string_length);
- /* For descriptorless coarrays, we pass the token and the offset
- as additional arguments. */
+ /* For descriptorless coarrays and assumed-shape coarray dummies, we
+ pass the token and the offset as additional arguments. */
if (fsym && fsym->attr.codimension
&& gfc_option.coarray == GFC_FCOARRAY_LIB
- && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+ && !fsym->attr.allocatable
&& e == NULL)
{
/* Token and offset. */
@@ -3404,7 +3404,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gcc_assert (fsym->attr.optional);
}
else if (fsym && fsym->attr.codimension
- && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+ && !fsym->attr.allocatable
&& gfc_option.coarray == GFC_FCOARRAY_LIB)
{
tree caf_decl, caf_type;
@@ -3413,8 +3413,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
caf_decl = get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
- if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
tmp = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (caf_decl);
else
{
gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
@@ -3424,8 +3428,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
VEC_safe_push (tree, gc, stringargs, tmp);
- if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
offset = build_int_cst (gfc_array_index_type, 0);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+ offset = GFC_DECL_CAF_OFFSET (caf_decl);
else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
else
@@ -3439,7 +3447,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+ if (fsym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+ (TREE_TYPE (parmse.expr))));
+ tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
else
{
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bec2a11..458e947 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1614,10 +1614,12 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
return type;
}
+
/* Return or create the base type for an array descriptor. */
static tree
-gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
+ enum gfc_array_kind akind)
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@@ -1671,7 +1673,8 @@ 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)
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+ && akind == GFC_ARRAY_ALLOCATABLE)
{
decl = gfc_add_field_to_struct_1 (fat_type,
get_identifier ("token"),
@@ -1683,7 +1686,8 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
- if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+ && akind == GFC_ARRAY_ALLOCATABLE)
gfc_array_descriptor_base_caf[idx] = fat_type;
else
gfc_array_descriptor_base[idx] = fat_type;
@@ -1691,6 +1695,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
return fat_type;
}
+
/* Build an array (descriptor) type with given bounds. */
tree
@@ -1703,11 +1708,11 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
const char *type_name;
int n;
- base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
fat_type = build_distinct_type_copy (base_type);
/* Make sure that nontarget and target array type have the same canonical
type (and same stub decl for debug info). */
- base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bb94780..0c249a6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -750,12 +750,16 @@ struct GTY((variable_size)) lang_decl {
tree stringlen;
tree addr;
tree span;
+ /* For assumed-shape coarrays. */
+ tree token, caf_offset;
};
#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
#define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
+#define GFC_DECL_TOKEN(node) DECL_LANG_SPECIFIC(node)->token
+#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
--- /dev/null 2011-08-22 07:33:18.402869820 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 2011-08-22 23:12:24.000000000 +0200
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Check argument passing with assumed-shape coarray dummies
+!
+program test_caf
+ implicit none
+ integer, allocatable :: A(:)[:]
+ integer, save :: B(3)[*]
+ integer :: i
+
+ allocate (A(3)[*])
+ A = [1, 2, 3 ]
+ B = [9, 7, 4 ]
+ call foo (A, A, test=1)
+ call foo (A(2:3), B, test=2)
+ call foo (B, A, test=3)
+contains
+ subroutine foo(x, y, test)
+ integer :: x(:)[*]
+ integer, contiguous :: y(:)[*]
+ integer :: test
+ call bar (x)
+ call expl (y)
+ end subroutine foo
+
+ subroutine bar(y)
+ integer :: y(:)[*]
+ end subroutine bar
+
+ subroutine expl(z)
+ integer :: z(*)[*]
+ end subroutine expl
+end program test_caf
+
+! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(struct array2_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(struct array2_integer\\(kind=4\\) & restrict x, struct array2_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, 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" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+! { d_g-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.data, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&a, &a, &C.\[0-9\]+, a.token, 0, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) a.data, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { cleanup-tree-dump "original" } }
