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" } }