From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 7333 invoked by alias); 10 Apr 2015 06:58:21 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 7312 invoked by uid 89); 10 Apr 2015 06:58:20 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.5 required=5.0 tests=AWL,BAYES_50,KAM_LAZY_DOMAIN_SECURITY,RCVD_IN_DNSWL_LOW autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx02.qsc.de Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Fri, 10 Apr 2015 06:58:10 +0000 Received: from tux.net-b.de (port-92-194-96-200.dynamic.qsc.de [92.194.96.200]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx02.qsc.de (Postfix) with ESMTPSA id 109072767A; Fri, 10 Apr 2015 08:58:05 +0200 (CEST) Message-ID: <5527747D.6030908@net-b.de> Date: Fri, 10 Apr 2015 06:58:00 -0000 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.4.0 MIME-Version: 1.0 To: gfortran , gcc-patches CC: Alessandro Fanfarillo , Paul Richard Thomas Subject: [Patch, Fortran] Fix (serious) issue with Coarray's (UN)LOCK Content-Type: multipart/mixed; boundary="------------090007090402050102030509" X-SW-Source: 2015-04/txt/msg00433.txt.bz2 This is a multi-part message in MIME format. --------------090007090402050102030509 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit Content-length: 571 This patch does two things: a) It finally implements locking/unlocking with -fcoarray=lib. Before it was effectively a no op operation always succeeding. - The implementation only works for "normal" locking variables - and neither for CLASS, type extension or lock components of derived types. b) It adds a compile-time error for the cases not supported, avoiding race conditions due to an only apparently working locking (as it would be the case with the implementation before the patch). Build and regtested on x86-64-gnu-linux. OK for the GCC 5 trunk? Tobias --------------090007090402050102030509 Content-Type: text/x-patch; name="lock.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="lock.diff" Content-length: 15960 2015-04-10 Tobias Burnus gcC/fortran/ * trans-stmt.c (gfc_trans_lock_unlock): Implement -fcoarray=lib version; reject not-yet-implemented variants. * trans-types.c (gfc_get_derived_type): For lock_type with -fcoarray=lib, use a void pointer as type. * trans.c (gfc_allocate_using_lib, gfc_allocate_allocatable): Handle lock_type with -fcoarray=lib. gcc/testsuite/ * gfortran.dg/coarray_lock_6.f90: New. * gfortran.dg/coarray_lock_7.f90: New. * gfortran.dg/coarray/lock_2.f90: New. diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 619564b..91d2a85 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -682,19 +682,17 @@ gfc_trans_stop (gfc_code *code, bool error_stop) tree -gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) +gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) { gfc_se se, argse; - tree stat = NULL_TREE, lock_acquired = NULL_TREE; + tree stat = NULL_TREE, stat2 = NULL_TREE; + tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE; /* Short cut: For single images without STAT= or LOCK_ACQUIRED return early. (ERRMSG= is always untouched for -fcoarray=single.) */ if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB) return NULL_TREE; - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - if (code->expr2) { gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); @@ -702,6 +700,8 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) gfc_conv_expr_val (&argse, code->expr2); stat = argse.expr; } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; if (code->expr4) { @@ -710,6 +710,136 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) gfc_conv_expr_val (&argse, code->expr4); lock_acquired = argse.expr; } + else if (flag_coarray == GFC_FCOARRAY_LIB) + lock_acquired = null_pointer_node; + + gfc_start_block (&se.pre); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree tmp, token, image_index, errmsg, errmsg_len; + tree index = size_zero_node; + tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); + + if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED + || code->expr1->symtree->n.sym->ts.u.derived->from_intmod + != INTMOD_ISO_FORTRAN_ENV + || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id + != ISOFORTRAN_LOCK_TYPE) + { + gfc_error ("Sorry, the lock component of derived type at %L is not " + "yet supported", &code->expr1->where); + return NULL_TREE; + } + + gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1); + + if (gfc_is_coindexed (code->expr1)) + image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); + else + image_index = integer_zero_node; + + /* For arrays, obtain the array index. */ + if (gfc_expr_attr (code->expr1).dimension) + { + tree desc, tmp, extent, lbound, ubound; + gfc_array_ref *ar, ar2; + int i; + + /* TODO: Extend this, once DT components are supported. */ + ar = &code->expr1->ref->u.ar; + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + + gfc_init_se (&argse, NULL); + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, code->expr1); + gfc_add_block_to_block (&se.pre, &argse.pre); + desc = argse.expr; + *ar = ar2; + + extent = integer_one_node; + for (i = 0; i < ar->dimen; i++) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, ar->start[i], integer_type_node); + gfc_add_block_to_block (&argse.pre, &argse.pre); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + integer_type_node, argse.expr, + fold_convert(integer_type_node, lbound)); + tmp = fold_build2_loc (input_location, MULT_EXPR, + integer_type_node, extent, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + integer_type_node, index, tmp); + if (i < ar->dimen - 1) + { + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); + tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); + tmp = fold_convert (integer_type_node, tmp); + extent = fold_build2_loc (input_location, MULT_EXPR, + integer_type_node, extent, tmp); + } + } + } + + /* errmsg. */ + if (code->expr3) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->expr3); + gfc_add_block_to_block (&se.pre, &argse.pre); + errmsg = argse.expr; + errmsg_len = fold_convert (integer_type_node, argse.string_length); + } + else + { + errmsg = null_pointer_node; + errmsg_len = integer_zero_node; + } + + if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) + { + stat2 = stat; + stat = gfc_create_var (integer_type_node, "stat"); + } + + if (lock_acquired != null_pointer_node + && TREE_TYPE (lock_acquired) != integer_type_node) + { + lock_acquired2 = lock_acquired; + lock_acquired = gfc_create_var (integer_type_node, "acquired"); + } + + if (op == EXEC_LOCK) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, index, image_index, + lock_acquired != null_pointer_node + ? gfc_build_addr_expr (NULL, lock_acquired) + : lock_acquired, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, + token, index, image_index, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + + if (stat2 != NULL_TREE) + gfc_add_modify (&se.pre, stat2, + fold_convert (TREE_TYPE (stat2), stat)); + + if (lock_acquired2 != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired2, + fold_convert (TREE_TYPE (lock_acquired2), + lock_acquired)); + + return gfc_finish_block (&se.pre); + } if (stat != NULL_TREE) gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 708289f..0ad8ac2 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2376,7 +2376,10 @@ gfc_get_derived_type (gfc_symbol * derived) gfc_dt_list *dt; gfc_namespace *ns; - if (derived->attr.unlimited_polymorphic) + if (derived->attr.unlimited_polymorphic + || (flag_coarray == GFC_FCOARRAY_LIB + && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)) return ptr_type_node; if (derived && derived->attr.flavor == FL_PROCEDURE diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index b7ec0e5..549e921 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -700,7 +700,8 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, } */ static void gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, - tree token, tree status, tree errmsg, tree errlen) + tree token, tree status, tree errmsg, tree errlen, + bool lock_var) { tree tmp, pstat; @@ -730,7 +731,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)), build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC), + lock_var ? GFC_CAF_LOCK_ALLOC + : GFC_CAF_COARRAY_ALLOC), token, pstat, errmsg, errlen); tmp = fold_build2_loc (input_location, MODIFY_EXPR, @@ -787,9 +789,22 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, && gfc_expr_attr (expr).codimension) { tree cond; + bool lock_var = expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE; + /* In the front end, we represent the lock variable as pointer. However, + the FE only passes the pointer around and leaves the actual + representation to the library. Hence, we have to convert back to the + number of elements. */ + if (lock_var) + size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, + size, TYPE_SIZE_UNIT (ptr_type_node)); gfc_allocate_using_lib (&alloc_block, mem, size, token, status, - errmsg, errlen); + errmsg, errlen, lock_var); + if (status != NULL_TREE) { TREE_USED (label_finish) = 1; diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 new file mode 100644 index 0000000..3afd824 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! LOCK/UNLOCK check +! +! PR fortran/18918 +! + +use iso_fortran_env +implicit none + +type(lock_type), allocatable :: lock1[:] +type(lock_type), allocatable :: lock2(:,:)[:] +type(lock_type) :: lock3(4)[*] +integer :: stat +logical :: acquired + +allocate(lock1[*]) +allocate(lock2(2,2)[*]) + +LOCK(lock1) +UNLOCK(lock1) + +LOCK(lock2(1,1)) +LOCK(lock2(2,2)) +UNLOCK(lock2(1,1)) +UNLOCK(lock2(2,2)) + +LOCK(lock3(3)) +LOCK(lock3(4)) +UNLOCK(lock3(3)) +UNLOCK(lock3(4)) + +stat = 99 +LOCK(lock1, stat=stat) +if (stat /= 0) call abort() + +LOCK(lock2(1,1), stat=stat) +if (stat /= 0) call abort() +LOCK(lock2(2,2), stat=stat) +if (stat /= 0) call abort() + +LOCK(lock3(3), stat=stat) +if (stat /= 0) call abort() +LOCK(lock3(4), stat=stat) +if (stat /= 0) call abort() + +stat = 99 +UNLOCK(lock1, stat=stat) +if (stat /= 0) call abort() + +UNLOCK(lock2(1,1), stat=stat) +if (stat /= 0) call abort() +UNLOCK(lock2(2,2), stat=stat) +if (stat /= 0) call abort() + +UNLOCK(lock3(3), stat=stat) +if (stat /= 0) call abort() +UNLOCK(lock3(4), stat=stat) +if (stat /= 0) call abort() + +if (this_image() == 1) then + acquired = .false. + LOCK (lock1[this_image()], acquired_lock=acquired) + if (.not. acquired) call abort() + + acquired = .false. + LOCK (lock2(1,1)[this_image()], acquired_lock=acquired) + if (.not. acquired) call abort() + + acquired = .false. + LOCK (lock2(2,2)[this_image()], acquired_lock=acquired) + if (.not. acquired) call abort() + + acquired = .false. + LOCK (lock3(3)[this_image()], acquired_lock=acquired) + if (.not. acquired) call abort() + + acquired = .false. + LOCK (lock3(4)[this_image()], acquired_lock=acquired) + if (.not. acquired) call abort() + + UNLOCK (lock1[1]) + UNLOCK (lock2(1,1)[1]) + UNLOCK (lock2(2,2)[1]) + UNLOCK (lock3(3)[1]) + UNLOCK (lock3(4)[1]) +end if +end + diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_6.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_6.f90 new file mode 100644 index 0000000..f1f674e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lock_6.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! +use iso_fortran_env +implicit none + +type t1 + type(lock_type), allocatable :: x[:] +end type t1 + +type t2 + type(lock_type) :: x +end type t2 + +type(t1) :: a +type(t2) :: b[*] +!class(lock_type), allocatable :: cl[:] + +lock(a%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +lock(b%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +!lock(cl) + +unlock(a%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +unlock(b%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +!unlock(cl) +end diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 new file mode 100644 index 0000000..d489b84 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lock_7.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +use iso_fortran_env +implicit none + +type(lock_type) :: one[*] +type(lock_type) :: two(5,5)[*] +type(lock_type), allocatable :: three[:] +type(lock_type), allocatable :: four(:)[:] +integer :: ii +logical :: ll + +allocate(three[*], stat=ii) +allocate(four(7)[*], stat=ii) + +lock(one) +unlock(one) + +lock(two(3,3), stat=ii) +unlock(two(2,3), stat=ii) + +lock(three[4], acquired_lock=ll) +unlock(three[7], stat=ii) + +lock(four(1)[6], acquired_lock=ll, stat=ii) +unlock(four(2)[7]) +end + +! { dg-final { scan-tree-dump-times "one = \\(void \\* \\* restrict\\) _gfortran_caf_register \\(1, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "two = \\(void \\*\\\[25\\\] \\* restrict\\) _gfortran_caf_register \\(25, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "three.data = \\(void \\* restrict\\) _gfortran_caf_register \\(1, 3, &three.token, &stat.., 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "four.data = \\(void \\* restrict\\) _gfortran_caf_register \\(7, 3, &four.token, &stat.., 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., 0, 0, 0B, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., 0, 0, 0B, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);|_gfortran_caf_lock \\(caf_token.1, \\(3 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., \\(2 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(caf_token.., \\(2 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, 5 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &acquired.8, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lbound, &acquired.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(three.token, 0, 8 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(three.token, 0, 8 - three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, 1 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 7 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, 1 - four.dim\\\[0\\\].lbound, 7 - four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(four.token, 2 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 8 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);|_gfortran_caf_unlock \\(four.token, 2 - four.dim\\\[0\\\].lbound, 8 - four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } --------------090007090402050102030509--