[gomp3.1] Allow pointers and cray pointers in firstprivate/lastprivate, handle not allocated allocatable in firstprivate

[Jakub Jelinek <jakub at redhat dot com>]

Hi!

This patch includes assorted OpenMP 3.1 changes for Fortran.
Haven't changed COPYIN with not allocated allocatables yet, waiting
for explanation on OpenMP forum there.

2011-04-19  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/46752
	* trans-openmp.c (gfc_omp_clause_copy_ctor): Handle
	non-allocated allocatable.

	* openmp.c (resolve_omp_clauses): Allow POINTERs and
	Cray pointers in clauses other than REDUCTION.
	* trans-openmp.c (gfc_omp_predetermined_sharing): Adjust
	comment.

	* gfortran.dg/gomp/crayptr1.f90: Don't expect error
	about Cray pointer in FIRSTPRIVATE/LASTPRIVATE.

	* testsuite/libgomp.fortran/crayptr3.f90: New test.
	* testsuite/libgomp.fortran/allocatable7.f90: New test.
	* testsuite/libgomp.fortran/pointer1.f90: New test.
	* testsuite/libgomp.fortran/pointer2.f90: New test.

--- gcc/fortran/openmp.c	(revision 170933)
+++ gcc/fortran/openmp.c	(working copy)
@@ -1,5 +1,5 @@
 /* OpenMP directive matching and resolving.
-   Copyright (C) 2005, 2006, 2007, 2008, 2010
+   Copyright (C) 2005, 2006, 2007, 2008, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Jakub Jelinek
 
@@ -940,15 +940,20 @@ resolve_omp_clauses (gfc_code *code)
 			    n->sym->name, name, &code->loc);
 		if (list != OMP_LIST_PRIVATE)
 		  {
-		    if (n->sym->attr.pointer)
+		    if (n->sym->attr.pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
 		      gfc_error ("POINTER object '%s' in %s clause at %L",
 				 n->sym->name, name, &code->loc);
 		    /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
-		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
-		        n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
+		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
+			 && n->sym->ts.type == BT_DERIVED
+			 && n->sym->ts.u.derived->attr.alloc_comp)
 		      gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
 				 name, n->sym->name, &code->loc);
-		    if (n->sym->attr.cray_pointer)
+		    if (n->sym->attr.cray_pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
 		      gfc_error ("Cray pointer '%s' in %s clause at %L",
 				 n->sym->name, name, &code->loc);
 		  }
--- gcc/fortran/trans-openmp.c	(revision 170933)
+++ gcc/fortran/trans-openmp.c	(working copy)
@@ -1,5 +1,5 @@
 /* OpenMP directive translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Jakub Jelinek <jakub@redhat.com>
 
@@ -88,9 +88,7 @@ gfc_omp_predetermined_sharing (tree decl
   if (GFC_DECL_CRAY_POINTEE (decl))
     return OMP_CLAUSE_DEFAULT_PRIVATE;
 
-  /* Assumed-size arrays are predetermined to inherit sharing
-     attributes of the associated actual argument, which is shared
-     for all we care.  */
+  /* Assumed-size arrays are predetermined shared.  */
   if (TREE_CODE (decl) == PARM_DECL
       && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
@@ -214,7 +212,8 @@ tree
 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
 {
   tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
-  stmtblock_t block;
+  tree cond, then_b, else_b;
+  stmtblock_t block, cond_block;
 
   if (! GFC_DESCRIPTOR_TYPE_P (type)
       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
@@ -226,7 +225,9 @@ gfc_omp_clause_copy_ctor (tree clause, t
      and copied from SRC.  */
   gfc_start_block (&block);
 
-  gfc_add_modify (&block, dest, src);
+  gfc_init_block (&cond_block);
+
+  gfc_add_modify (&cond_block, dest, src);
   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
   size = gfc_conv_descriptor_ubound_get (dest, rank);
   size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
@@ -240,17 +241,29 @@ gfc_omp_clause_copy_ctor (tree clause, t
 			TYPE_SIZE_UNIT (gfc_get_element_type (type)));
   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			  size, esize);
-  size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-  ptr = gfc_allocate_array_with_status (&block,
+  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
+  ptr = gfc_allocate_array_with_status (&cond_block,
 					build_int_cst (pvoid_type_node, 0),
 					size, NULL, NULL);
-  gfc_conv_descriptor_data_set (&block, dest, ptr);
+  gfc_conv_descriptor_data_set (&cond_block, dest, ptr);
   call = build_call_expr_loc (input_location,
 			  built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
 			  fold_convert (pvoid_type_node,
 					gfc_conv_descriptor_data_get (src)),
 			  size);
-  gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+  gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
+  then_b = gfc_finish_block (&cond_block);
+
+  gfc_init_block (&cond_block);
+  gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node);
+  else_b = gfc_finish_block (&cond_block);
+
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  fold_convert (pvoid_type_node,
+					gfc_conv_descriptor_data_get (src)),
+			  null_pointer_node);
+  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+			 void_type_node, cond, then_b, else_b));
 
   return gfc_finish_block (&block);
 }
--- libgomp/testsuite/libgomp.fortran/crayptr3.f90	(revision 0)
+++ libgomp/testsuite/libgomp.fortran/crayptr3.f90	(revision 0)
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+  use omp_lib
+  integer :: a, b, c, i, p
+  logical :: l
+  pointer (ip, p)
+  a = 1
+  b = 2
+  c = 3
+  l = .false.
+  ip = loc (a)
+
+!$omp parallel num_threads (2) reduction (.or.:l) firstprivate (ip)
+  l = p .ne. 1
+  ip = loc (b)
+  if (omp_get_thread_num () .eq. 1) ip = loc (c)
+  l = l .or. (p .ne. (2 + omp_get_thread_num ()))
+!$omp end parallel
+
+  if (l) call abort
+
+  l = .false.
+  ip = loc (a)
+!$omp parallel do num_threads (2) reduction (.or.:l) &
+!$omp & firstprivate (ip) lastprivate (ip)
+  do i = 0, 1
+    l = l .or. (p .ne. 1)
+    ip = loc (b)
+    if (i .eq. 1) ip = loc (c)
+    l = l .or. (p .ne. (2 + i))
+  end do
+
+  if (l) call abort
+  if (p .ne. 3) call abort
+end
--- libgomp/testsuite/libgomp.fortran/allocatable7.f90	(revision 0)
+++ libgomp/testsuite/libgomp.fortran/allocatable7.f90	(revision 0)
@@ -0,0 +1,16 @@
+! { dg-do run }
+
+  integer, allocatable :: a(:)
+  logical :: l
+  l = .false.
+!$omp parallel firstprivate (a) reduction (.or.:l)
+  l = allocated (a)
+  allocate (a(10))
+  l = l .or. .not. allocated (a)
+  a = 10
+  if (any (a .ne. 10)) l = .true.
+  deallocate (a)
+  l = l .or. allocated (a)
+!$omp end parallel
+  if (l) call abort
+end
--- libgomp/testsuite/libgomp.fortran/pointer1.f90	(revision 0)
+++ libgomp/testsuite/libgomp.fortran/pointer1.f90	(revision 0)
@@ -0,0 +1,77 @@
+! { dg-do run }
+  integer, pointer :: a, c(:)
+  integer, target :: b, d(10)
+  b = 0
+  a => b
+  d = 0
+  c => d
+  call foo (a, c)
+  b = 0
+  d = 0
+  call bar (a, c)
+contains
+  subroutine foo (a, c)
+    integer, pointer :: a, c(:), b, d(:)
+    integer :: r, r2
+    r = 0
+    !$omp parallel firstprivate (a, c) reduction (+:r)
+      !$omp atomic
+        a = a + 1
+      !$omp atomic
+        c(1) = c(1) + 1
+      r = r + 1
+    !$omp end parallel
+    if (a.ne.r.or.c(1).ne.r) call abort
+    r2 = r
+    b => a
+    d => c
+    r = 0
+    !$omp parallel firstprivate (b, d) reduction (+:r)
+      !$omp atomic
+        b = b + 1
+      !$omp atomic
+        d(1) = d(1) + 1
+      r = r + 1
+    !$omp end parallel
+    if (b.ne.r+r2.or.d(1).ne.r+r2) call abort
+  end subroutine foo
+  subroutine bar (a, c)
+    integer, pointer :: a, c(:), b, d(:)
+    integer, target :: q, r(5)
+    integer :: i
+    q = 17
+    r = 21
+    b => a
+    d => c
+    !$omp parallel do firstprivate (a, c) lastprivate (a, c)
+      do i = 1, 100
+        !$omp atomic
+          a = a + 1
+        !$omp atomic
+          c((i+9)/10) = c((i+9)/10) + 1
+        if (i.eq.100) then
+          a => q
+          c => r
+	end if
+      end do
+    !$omp end parallel do
+    if (b.ne.100.or.any(d.ne.10)) call abort
+    if (a.ne.17.or.any(c.ne.21)) call abort
+    a => b
+    c => d
+    !$omp parallel do firstprivate (b, d) lastprivate (b, d)
+      do i = 1, 100
+        !$omp atomic
+          b = b + 1
+        !$omp atomic
+          d((i+9)/10) = d((i+9)/10) + 1
+        if (i.eq.100) then
+          b => q
+          d => r
+	end if
+      end do
+    !$omp end parallel do
+    if (a.ne.200.or.any(c.ne.20)) call abort
+    if (b.ne.17.or.any(d.ne.21)) call abort
+  end subroutine bar
+end
--- libgomp/testsuite/libgomp.fortran/pointer2.f90	(revision 0)
+++ libgomp/testsuite/libgomp.fortran/pointer2.f90	(revision 0)
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+  integer, pointer, save :: thr(:)
+!$omp threadprivate (thr)
+  integer, target :: s(3), t(3), u(3)
+  integer :: i
+  logical :: l
+  s = 2
+  t = 7
+  u = 13
+  thr => t
+  l = .false.
+  i = 0
+!$omp parallel copyin (thr) reduction(.or.:l) reduction(+:i)
+  if (any (thr.ne.7)) l = .true.
+  thr => s
+!$omp master
+  thr => u
+!$omp end master
+!$omp atomic
+  thr(1) = thr(1) + 1
+  i = i + 1
+!$omp end parallel
+  if (l) call abort
+  if (thr(1).ne.14) call abort
+  if (s(1).ne.1+i) call abort
+  if (u(1).ne.14) call abort
+end
--- gcc/testsuite/gfortran.dg/gomp/crayptr1.f90	(revision 170933)
+++ gcc/testsuite/gfortran.dg/gomp/crayptr1.f90	(working copy)
@@ -36,10 +36,10 @@
 !$omp end parallel
 
   ip3 = loc (i)
-!$omp parallel firstprivate (ip3) ! { dg-error "Cray pointer 'ip3' in FIRSTPRIVATE clause" }
+!$omp parallel firstprivate (ip3)
 !$omp end parallel
 
-!$omp parallel do lastprivate (ip4) ! { dg-error "Cray pointer 'ip4' in LASTPRIVATE clause" }
+!$omp parallel do lastprivate (ip4)
   do i = 1, 10
     if (i .eq. 10) ip4 = loc (i)
   end do

	Jakub