From patchwork Tue Apr 19 16:37:52 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jakub Jelinek X-Patchwork-Id: 92031 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8C1511007E0 for ; Wed, 20 Apr 2011 02:38:20 +1000 (EST) Received: (qmail 19883 invoked by alias); 19 Apr 2011 16:38:16 -0000 Received: (qmail 19847 invoked by uid 22791); 19 Apr 2011 16:38:13 -0000 X-SWARE-Spam-Status: No, hits=-5.1 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_HI, SPF_HELO_PASS, TW_TM, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mx1.redhat.com (HELO mx1.redhat.com) (209.132.183.28) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 19 Apr 2011 16:37:54 +0000 Received: from int-mx10.intmail.prod.int.phx2.redhat.com (int-mx10.intmail.prod.int.phx2.redhat.com [10.5.11.23]) by mx1.redhat.com (8.14.4/8.14.4) with ESMTP id p3JGbrW0020749 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=OK); Tue, 19 Apr 2011 12:37:53 -0400 Received: from tyan-ft48-01.lab.bos.redhat.com (tyan-ft48-01.lab.bos.redhat.com [10.16.42.4]) by int-mx10.intmail.prod.int.phx2.redhat.com (8.14.4/8.14.4) with ESMTP id p3JGbqn5021781 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=NO); Tue, 19 Apr 2011 12:37:53 -0400 Received: from tyan-ft48-01.lab.bos.redhat.com (localhost.localdomain [127.0.0.1]) by tyan-ft48-01.lab.bos.redhat.com (8.14.4/8.14.4) with ESMTP id p3JGbqVb009414; Tue, 19 Apr 2011 18:37:52 +0200 Received: (from jakub@localhost) by tyan-ft48-01.lab.bos.redhat.com (8.14.4/8.14.4/Submit) id p3JGbqDw009413; Tue, 19 Apr 2011 18:37:52 +0200 Date: Tue, 19 Apr 2011 18:37:52 +0200 From: Jakub Jelinek To: fortran@gcc.gnu.org Cc: gcc-patches@gcc.gnu.org Subject: [gomp3.1] Allow pointers and cray pointers in firstprivate/lastprivate, handle not allocated allocatable in firstprivate Message-ID: <20110419163752.GL17079@tyan-ft48-01.lab.bos.redhat.com> Reply-To: Jakub Jelinek MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 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. Jakub --- 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 @@ -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