@@ -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);
}
@@ -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);
}
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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