From af232d48a7e011bf85d12634644ce80c1ad6480d Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 26 Jul 2011 09:30:37 +0200 Subject: [PATCH] trans-array.c (CAF_TOKEN_FIELD): New macro constant. 2011-07-26 Tobias Burnus * 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. (gfc_array_descriptor_base_caf): New static variable. * trans-expr.c (gfc_conv_procedure_call): Handle token and * offset when passing a descriptor coarray to a nondescriptor dummy. 2011-07-26 Tobias Burnus * gfortran.dg/coarray_lib_token_2.f90: New. From-SVN: r176784 --- gcc/fortran/ChangeLog | 11 ++ gcc/fortran/trans-array.c | 20 +++ gcc/fortran/trans-array.h | 1 + gcc/fortran/trans-expr.c | 52 +++++--- gcc/fortran/trans-types.c | 23 +++- gcc/testsuite/ChangeLog | 4 + .../gfortran.dg/coarray_lib_token_2.f90 | 115 ++++++++++++++++++ 7 files changed, 205 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 533c28c5e06..9537bbfa73b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2011-07-26 Tobias Burnus + + * 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. + (gfc_array_descriptor_base_caf): New static variable. + * trans-expr.c (gfc_conv_procedure_call): Handle token and offset + when passing a descriptor coarray to a nondescriptor dummy. + 2011-07-23 Tobias Burnus * resolve.c (resolve_symbol): Fix coarray var decl check. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b959b36374c..ff059a3e988 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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 diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 75704ad7454..61f7042c9c0 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 76229102436..96510c2c294 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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_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); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 01587eb5f2b..b66941f366a 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -81,6 +81,7 @@ bool gfc_real16_is_float128 = false; static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS]; +static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS]; /* Arrays for all integral and real kinds. We'll fill this in at runtime after the target has a chance to process command-line options. */ @@ -1623,7 +1624,13 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) int idx = 2 * (codimen + dimen - 1) + restricted; gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); - if (gfc_array_descriptor_base[idx]) + + if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen) + { + if (gfc_array_descriptor_base_caf[idx]) + return gfc_array_descriptor_base_caf[idx]; + } + else if (gfc_array_descriptor_base[idx]) return gfc_array_descriptor_base[idx]; /* Build the type node. */ @@ -1664,11 +1671,23 @@ 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; - gfc_array_descriptor_base[idx] = fat_type; + if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen) + gfc_array_descriptor_base_caf[idx] = fat_type; + else + gfc_array_descriptor_base[idx] = fat_type; + return fat_type; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a3623ec1a2d..1e351fec20e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2011-07-26 Tobias Burnus + + * gfortran.dg/coarray_lib_token_2.f90: New. + 2011-07-26 Ira Rosen * gcc.dg/vect/vect-70.c: Reduce the data size to fit diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 new file mode 100644 index 00000000000..dd378759148 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_2.f90 @@ -0,0 +1,115 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Check whether TOKEN and OFFSET are correctly propagated +! + +! THIS PART FAILED (ICE) DUE TO TYPE SHARING + +module matrix_data + implicit none + type sparse_CSR_matrix + integer, allocatable :: a(:) + end type sparse_CSR_matrix +CONTAINS + +subroutine build_CSR_matrix(CSR) + type(sparse_CSR_matrix), intent(out) :: CSR + integer, allocatable :: CAF_begin[:] + call global_to_local_index(CAF_begin) +end subroutine build_CSR_matrix + +subroutine global_to_local_index(CAF_begin) + integer, intent(out) :: CAF_begin[*] +end subroutine global_to_local_index + +end module matrix_data + + +! DUMP TESTING + +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_token.6, NON_LVALUE_EXPR ); +! +! { 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" } } -- 2.30.2