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 <ja...@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 <ja...@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
