2015-04-10 Tobias Burnus <burnus@net-b.de>
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.
@@ -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));
@@ -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
@@ -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;
new file mode 100644
@@ -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
+
new file mode 100644
@@ -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
new file mode 100644
@@ -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" } }