2011-08-23 Tobias Burnus <burnus@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 <burnus@net-b.de>
* gfortran.dg/coarray_lib_token_4.f90: New.
@@ -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);
@@ -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);
@@ -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
{
@@ -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);
@@ -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)
@@ -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" } }
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