Re: [Patch, Fortran] (coarray) Add LOCK_TYPE

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

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

Dear Paul,

Paul Richard Thomas wrote:
> I have checked out the code for any obvious style or other minor
> errors and all looks well.  However, I had a look at 8.5.6 "LOCK and
> UNLOCK statements" in the standard and can only confess to feeling
> very stupid tonight because I could not make head nor tail of the
> example.  Thus, I can offer no judgement on the functionality of your
> patch.

Well, for a single image - and more the current patch does not support - 
it is very simple: LOCK and UNLOCK do not do anything. If there is a 
STAT=, it is set to 0 and if there is a LOCK_ACQUIRED= it is set to true.

But in general, a LOCK/UNLOCK pair allows to create a critical section, 
where only one process at a time processes a certain block. Mostly one 
image (process) can hold a lock at any given time.

The simplest case for LOCK is a CRITICAL block where only one process 
(image) at a time can execute code in the block. However, LOCK allows more:
* With LOCK_ACQUIRED, it allows to perform some alternative action when 
it cannot get the lock (otherwise, LOCK waits until it can obtain the lock)
* As the example in the standard shows: One can use one lock (variable) 
to lock different section of the code.

In the example (Example 8.45): Each image (process) has a work queue. 
This queue is filled (remotely) by its neighbour, i.e. "this_image()-1", 
which is possible as the work queue is a coarray. In the first block, 
each process checks whether there is a new item in its own 
("this_image()") workqueue - in the second block, it adds a new item to 
the neighbouring queue. While an item is being added or removed from the 
queue, no parallel access should be happen - thus the access is guarded 
via a lock. The lock is also a coarray, thus, there are num_image() locks.
In the example "work_queue" is the local arrays and thus semantically 
identical to "work_queue[this_image()]" while "work_queue[me+1]" refers 
to the remote coarray on image "me+1".

> OK for trunk

Thanks for the review! And good that you asked about the trans part. 
There was actually a bug in it:

+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, lock_acquired,
+                   build_int_cst (TREE_TYPE (lock_acquired), 0));

The check in "if" should be "lock_acquired" not "stat". Corrected in the 
committed version (Rev. 175228). I have now also added a run-test (cf. 
attachment) to make sure that it actually works.

> PS Please give me a co-array tutorial sometime!

I will, though I think for the real fun, one needs to have a working 
mult-image support.

Tobias

[-- Attachment #2: lock_1.f90 --]
[-- Type: text/plain, Size: 476 bytes --]

! { dg-do run }
!
! LOCK/UNLOCK check
!
! PR fortran/18918
!

use iso_fortran_env
implicit none

type(lock_type) :: lock[*]
integer :: stat
logical :: acquired

LOCK(lock)
UNLOCK(lock)

stat = 99
LOCK(lock, stat=stat)
if (stat /= 0) call abort()
stat = 99
UNLOCK(lock, stat=stat)
if (stat /= 0) call abort()

if (this_image() == 1) then
  acquired = .false.
  LOCK (lock[this_image()], acquired_lock=acquired)
  if (.not. acquired) call abort()
  UNLOCK (lock[1])
end if
end


[-- Attachment #3: lock-changes.diff --]
[-- Type: text/x-patch, Size: 9242 bytes --]

Index: trans-stmt.c
===================================================================
--- trans-stmt.c	(Revision 175227)
+++ trans-stmt.c	(Arbeitskopie)
@@ -653,6 +653,48 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
 
 
 tree
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
+{
+  gfc_se se, argse;
+  tree stat = NULL_TREE, lock_acquired = 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 && gfc_option.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);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr2);
+      stat = argse.expr;
+    }
+
+  if (code->expr4)
+    {
+      gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr4);
+      lock_acquired = argse.expr;
+    }
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+  if (lock_acquired != NULL_TREE)
+    gfc_add_modify (&se.pre, lock_acquired,
+		    fold_convert (TREE_TYPE (lock_acquired),
+				  boolean_true_node));
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+tree
 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
 {
   gfc_se se, argse;
Index: resolve.c
===================================================================
--- resolve.c	(Revision 175227)
+++ resolve.c	(Arbeitskopie)
@@ -6235,7 +6235,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool rea
       == FAILURE)
     return FAILURE;
 
-  if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+  if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
       == FAILURE)
     return FAILURE;
 
@@ -6502,9 +6502,11 @@ resolve_deallocate_expr (gfc_expr *e)
     }
 
   if (pointer
-      && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+      && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+	 == FAILURE)
     return FAILURE;
-  if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+  if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+      == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -6796,6 +6798,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
 		      &e->where, &code->expr3->where);
 	  goto failure;
 	}
+
+      /* Check F2008, C642.  */
+      if (code->expr3->ts.type == BT_DERIVED
+	  && ((codimension &&  gfc_expr_attr (code->expr3).lock_comp)
+	      || (code->expr3->ts.u.derived->from_intmod
+		     == INTMOD_ISO_FORTRAN_ENV
+		  && code->expr3->ts.u.derived->intmod_sym_id
+		     == ISOFORTRAN_LOCK_TYPE)))
+	{
+	  gfc_error ("The source-expr at %L shall neither be of type "
+		     "LOCK_TYPE nor have a LOCK_TYPE component if "
+		      "allocate-object at %L is a coarray",
+		      &code->expr3->where, &e->where);
+	  goto failure;
+	}
     }
 
   /* Check F08:C629.  */
@@ -6814,9 +6831,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
   e2 = remove_last_array_ref (e);
   t = SUCCESS;
   if (t == SUCCESS && pointer)
-    t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+    t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
   if (t == SUCCESS)
-    t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+    t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
   gfc_free_expr (e2);
   if (t == FAILURE)
     goto failure;
@@ -6992,7 +7009,7 @@ resolve_allocate_deallocate (gfc_code *code, const
   /* Check the stat variable.  */
   if (stat)
     {
-      gfc_check_vardef_context (stat, false, _("STAT variable"));
+      gfc_check_vardef_context (stat, false, false, _("STAT variable"));
 
       if ((stat->ts.type != BT_INTEGER
 	   && !(stat->ref && (stat->ref->type == REF_ARRAY
@@ -7035,7 +7052,7 @@ resolve_allocate_deallocate (gfc_code *code, const
 	gfc_warning ("ERRMSG at %L is useless without a STAT tag",
 		     &errmsg->where);
 
-      gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
+      gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
 
       if ((errmsg->ts.type != BT_CHARACTER
 	   && !(errmsg->ref
@@ -8100,7 +8117,8 @@ resolve_transfer (gfc_code *code)
      code->ext.dt may be NULL if the TRANSFER is related to
      an INQUIRE statement -- but in this case, we are not reading, either.  */
   if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
-      && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+      && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+	 == FAILURE)
     return;
 
   sym = exp->symtree->n.sym;
@@ -8201,13 +8219,15 @@ find_reachable_labels (gfc_code *block)
 static void
 resolve_lock_unlock (gfc_code *code)
 {
-  /* FIXME: Add more lock-variable checks. For now, always reject it.
-     Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available.  */
-  /* if (code->expr2->ts.type != BT_DERIVED
-	 || code->expr2->rank != 0
-	 || code->expr2->expr_type != EXPR_VARIABLE)  */
-  gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
-	     &code->expr1->where);
+  if (code->expr1->ts.type != BT_DERIVED
+      || code->expr1->expr_type != EXPR_VARIABLE
+      || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+      || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+      || code->expr1->rank != 0
+      || !(gfc_expr_attr (code->expr1).codimension
+	   || gfc_is_coindexed (code->expr1)))
+    gfc_error ("Lock variable at %L must be a scalar coarray of type "
+	       "LOCK_TYPE", &code->expr1->where);
 
   /* Check STAT.  */
   if (code->expr2
@@ -8216,6 +8236,11 @@ resolve_lock_unlock (gfc_code *code)
     gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
 	       &code->expr2->where);
 
+  if (code->expr2
+      && gfc_check_vardef_context (code->expr2, false, false,
+				   _("STAT variable")) == FAILURE)
+    return;
+
   /* Check ERRMSG.  */
   if (code->expr3
       && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
@@ -8223,12 +8248,22 @@ resolve_lock_unlock (gfc_code *code)
     gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
 	       &code->expr3->where);
 
+  if (code->expr3
+      && gfc_check_vardef_context (code->expr3, false, false,
+				   _("ERRMSG variable")) == FAILURE)
+    return;
+
   /* Check ACQUIRED_LOCK.  */
   if (code->expr4
       && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
 	  || code->expr4->expr_type != EXPR_VARIABLE))
     gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
 	       "variable", &code->expr4->where);
+
+  if (code->expr4
+      && gfc_check_vardef_context (code->expr4, false, false,
+				   _("ACQUIRED_LOCK variable")) == FAILURE)
+    return;
 }
 
 
@@ -9143,8 +9178,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
-	  if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
-		== FAILURE)
+	  if (gfc_check_vardef_context (code->expr1, false, false,
+					_("assignment")) == FAILURE)
 	    break;
 
 	  if (resolve_ordinary_assign (code, ns))
@@ -9182,9 +9217,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	       array ref may be present on the LHS and fool gfc_expr_attr
 	       used in gfc_check_vardef_context.  Remove it.  */
 	    e = remove_last_array_ref (code->expr1);
-	    t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+	    t = gfc_check_vardef_context (e, true, false,
+					  _("pointer assignment"));
 	    if (t == SUCCESS)
-	      t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+	      t = gfc_check_vardef_context (e, false, false,
+					    _("pointer assignment"));
 	    gfc_free_expr (e);
 	    if (t == FAILURE)
 	      break;
@@ -12340,6 +12377,17 @@ resolve_symbol (gfc_symbol *sym)
 			 sym->ts.u.derived->name) == FAILURE)
     return;
 
+  /* F2008, C1302.  */
+  if (sym->ts.type == BT_DERIVED
+      && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+      && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
+      && !sym->attr.codimension)
+    {
+      gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray",
+		 sym->name, &sym->declared_at);
+      return;
+    }
+
   /* An assumed-size array with INTENT(OUT) shall not be of a type for which
      default initialization is defined (5.1.2.4.4).  */
   if (sym->ts.type == BT_DERIVED
@@ -12360,6 +12408,12 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  /* F2008, C542.  */
+  if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+      && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+    gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+	       "INTENT(OUT)", sym->name, &sym->declared_at);
+
   /* F2008, C526.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
        || sym->attr.codimension)