2011-07-26 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.
        (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  <burnus@net-b.de>

        * gfortran.dg/coarray_lib_token_2.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@176784 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 533c28c..9537bbf 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2011-07-26  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.
+       (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  <burnus@net-b.de>
 
        * resolve.c (resolve_symbol): Fix coarray var decl check.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b959b36..ff059a3 100644 (file)
--- 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 75704ad..61f7042 100644 (file)
--- 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 7622910..96510c2 100644 (file)
--- 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 01587eb..b66941f 100644 (file)
--- 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 a3623ec..1e351fe 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2011-07-26  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray_lib_token_2.f90: New.
+
 2011-07-26  Ira Rosen  <ira.rosen@linaro.org>
 
        * 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 (file)
index 0000000..dd37875
--- /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_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" } }