[Patch, Fortran] Fix (serious) issue with Coarray's (UN)LOCK

[Tobias Burnus <burnus@net-b.de>]

[-- Attachment #1: Type: text/plain, Size: 571 bytes --]

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

[-- Attachment #2: lock.diff --]
[-- Type: text/x-patch, Size: 15960 bytes --]

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.

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