trans-stmt.c (gfc_trans_lock_unlock): Implement -fcoarray=lib version; reject…

trans-stmt.c (gfc_trans_lock_unlock): Implement -fcoarray=lib version; reject not-yet-implemented variants.

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.

From-SVN: r221973

gcc/fortran/ChangeLog

+2015-04-10  Tobias Burnus  <burnus@net-b.de>
+
+	* 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.
+
 2015-04-10  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/56674

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));

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

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;

gcc/testsuite/ChangeLog

+2015-04-10  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/coarray_lock_6.f90: New.
+	* gfortran.dg/coarray_lock_7.f90: New.
+	* gfortran.dg/coarray/lock_2.f90: New.
+
 2015-04-10  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/56674

gcc/testsuite/gfortran.dg/coarray/lock_2.f90

+! { 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
+

gcc/testsuite/gfortran.dg/coarray_lock_6.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_lock_7.f90

+! { 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" } }