diff mbox

[Fortran] -fcoarray=lib - support CRITICAL, prepare for locking support

Message ID 53D6B479.7020905@net-b.de
State New
Headers show

Commit Message

Tobias Burnus July 28, 2014, 8:37 p.m. UTC
This patch implements -fcoarray=lib support for CRITICAL blocks and 
includes some preparatory work for locking. In particular:

* Updated the documentation for locking/critical, minor cleanup. The 
patch goes on top of the unreviewed patch 
https://gcc.gnu.org/ml/fortran/2014-07/msg00155.html
* Add libcaf_single implementation for lock/unlock
* Add lock/unlock calls for CRITICAL
* Register static/SAVEd locking variables and locking variables for 
critical sections.

Build and currently regtesting on x86-64-gnu-linux.
OK when it regtested successfully?

  * * *

Still to be done as follow up:
* Handling the registering of lock-type components in statically 
allocated derived types
* Handling the registering of lock-type variables and components with 
allocate and with implicit/explicit deallocate
* Calling lock/unlock function for those
* Test case for locking and critical blocks

Other coarray to-do items:
* Type-conversion test case missing
* Vector subscript library implementation + test cases
* Extending the documentation
* Issues with striding for coarray components of derived types
* Nonallocatable polymophic coarrays and select type/associated
* Allocatable/pointer components of coarrays; co_reduce and co_broadcast

Tobias

Comments

Alessandro Fanfarillo Aug. 1, 2014, 7:57 p.m. UTC | #1
Hello,

I was implementing lock/unlock on the library side when I found a
possible problem in the patch:

if (is_lock_type == GFC_CAF_CRITICAL)
+    reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+  else
+    reg_type = GFC_CAF_COARRAY_STATIC;

the if statement cannot be true since is_lock_type is a boolean and
GFC_CAF_CRITICAL is 4.

Using if (is_lock_type) it produces the right result for the lock registration.


Regards

Alessandro

2014-07-28 14:37 GMT-06:00 Tobias Burnus <burnus@net-b.de>:
> This patch implements -fcoarray=lib support for CRITICAL blocks and includes
> some preparatory work for locking. In particular:
>
> * Updated the documentation for locking/critical, minor cleanup. The patch
> goes on top of the unreviewed patch
> https://gcc.gnu.org/ml/fortran/2014-07/msg00155.html
> * Add libcaf_single implementation for lock/unlock
> * Add lock/unlock calls for CRITICAL
> * Register static/SAVEd locking variables and locking variables for critical
> sections.
>
> Build and currently regtesting on x86-64-gnu-linux.
> OK when it regtested successfully?
>
>  * * *
>
> Still to be done as follow up:
> * Handling the registering of lock-type components in statically allocated
> derived types
> * Handling the registering of lock-type variables and components with
> allocate and with implicit/explicit deallocate
> * Calling lock/unlock function for those
> * Test case for locking and critical blocks
>
> Other coarray to-do items:
> * Type-conversion test case missing
> * Vector subscript library implementation + test cases
> * Extending the documentation
> * Issues with striding for coarray components of derived types
> * Nonallocatable polymophic coarrays and select type/associated
> * Allocatable/pointer components of coarrays; co_reduce and co_broadcast
>
> Tobias
Tobias Burnus Aug. 6, 2014, 6:46 a.m. UTC | #2
* PING * – of the patch with the obvious change mentioned by Alessandro 
(i.e. using "if(is_lock_type)")?

Tobias

On 1 August 2014 21:57, Alessandro Fanfarillo wrote:
> Hello,
>
> I was implementing lock/unlock on the library side when I found a
> possible problem in the patch:
>
> if (is_lock_type == GFC_CAF_CRITICAL)
> +    reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
> +  else
> +    reg_type = GFC_CAF_COARRAY_STATIC;
>
> the if statement cannot be true since is_lock_type is a boolean and
> GFC_CAF_CRITICAL is 4.
>
> Using if (is_lock_type) it produces the right result for the lock registration.
>
>
> Regards
>
> Alessandro
>
> 2014-07-28 14:37 GMT-06:00 Tobias Burnus <burnus@net-b.de>:
>> This patch implements -fcoarray=lib support for CRITICAL blocks and includes
>> some preparatory work for locking. In particular:
>>
>> * Updated the documentation for locking/critical, minor cleanup. The patch
>> goes on top of the unreviewed patch
>> https://gcc.gnu.org/ml/fortran/2014-07/msg00155.html
>> * Add libcaf_single implementation for lock/unlock
>> * Add lock/unlock calls for CRITICAL
>> * Register static/SAVEd locking variables and locking variables for critical
>> sections.
>>
>> Build and currently regtesting on x86-64-gnu-linux.
>> OK when it regtested successfully?
>>
>>   * * *
>>
>> Still to be done as follow up:
>> * Handling the registering of lock-type components in statically allocated
>> derived types
>> * Handling the registering of lock-type variables and components with
>> allocate and with implicit/explicit deallocate
>> * Calling lock/unlock function for those
>> * Test case for locking and critical blocks
>>
>> Other coarray to-do items:
>> * Type-conversion test case missing
>> * Vector subscript library implementation + test cases
>> * Extending the documentation
>> * Issues with striding for coarray components of derived types
>> * Nonallocatable polymophic coarrays and select type/associated
>> * Allocatable/pointer components of coarrays; co_reduce and co_broadcast
>>
>> Tobias
Tobias Burnus Aug. 13, 2014, 5:51 a.m. UTC | #3
*PING**2

Tobias

PS: Now being back from vacation, I will try to review pending patches 
this evening.

On 6 August 2014 08:46, Tobias Burnus wrote:
> * PING * – of the patch with the obvious change mentioned by 
> Alessandro (i.e. using "if(is_lock_type)")?
>
> Tobias
>
> On 1 August 2014 21:57, Alessandro Fanfarillo wrote:
>> Hello,
>>
>> I was implementing lock/unlock on the library side when I found a
>> possible problem in the patch:
>>
>> if (is_lock_type == GFC_CAF_CRITICAL)
>> +    reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : 
>> GFC_CAF_LOCK_STATIC;
>> +  else
>> +    reg_type = GFC_CAF_COARRAY_STATIC;
>>
>> the if statement cannot be true since is_lock_type is a boolean and
>> GFC_CAF_CRITICAL is 4.
>>
>> Using if (is_lock_type) it produces the right result for the lock 
>> registration.
>>
>>
>> Regards
>>
>> Alessandro
>>
>> 2014-07-28 14:37 GMT-06:00 Tobias Burnus <burnus@net-b.de>:
>>> This patch implements -fcoarray=lib support for CRITICAL blocks and 
>>> includes
>>> some preparatory work for locking. In particular:
>>>
>>> * Updated the documentation for locking/critical, minor cleanup. The 
>>> patch
>>> goes on top of the unreviewed patch
>>> https://gcc.gnu.org/ml/fortran/2014-07/msg00155.html
>>> * Add libcaf_single implementation for lock/unlock
>>> * Add lock/unlock calls for CRITICAL
>>> * Register static/SAVEd locking variables and locking variables for 
>>> critical
>>> sections.
>>>
>>> Build and currently regtesting on x86-64-gnu-linux.
>>> OK when it regtested successfully?
>>>
>>>   * * *
>>>
>>> Still to be done as follow up:
>>> * Handling the registering of lock-type components in statically 
>>> allocated
>>> derived types
>>> * Handling the registering of lock-type variables and components with
>>> allocate and with implicit/explicit deallocate
>>> * Calling lock/unlock function for those
>>> * Test case for locking and critical blocks
>>>
>>> Other coarray to-do items:
>>> * Type-conversion test case missing
>>> * Vector subscript library implementation + test cases
>>> * Extending the documentation
>>> * Issues with striding for coarray components of derived types
>>> * Nonallocatable polymophic coarrays and select type/associated
>>> * Allocatable/pointer components of coarrays; co_reduce and 
>>> co_broadcast
>>>
>>> Tobias
>
>
Paul Richard Thomas Aug. 14, 2014, 9:33 a.m. UTC | #4
Dear Tobias, dear all,

This patch and the documentation patch are OK for trunk.

Many thanks

Paul


On 6 August 2014 08:46, Tobias Burnus <burnus@net-b.de> wrote:
> * PING * – of the patch with the obvious change mentioned by Alessandro
> (i.e. using "if(is_lock_type)")?
>
> Tobias
>
> On 1 August 2014 21:57, Alessandro Fanfarillo wrote:
>>
>> Hello,
>>
>> I was implementing lock/unlock on the library side when I found a
>> possible problem in the patch:
>>
>> if (is_lock_type == GFC_CAF_CRITICAL)
>> +    reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL :
>> GFC_CAF_LOCK_STATIC;
>> +  else
>> +    reg_type = GFC_CAF_COARRAY_STATIC;
>>
>> the if statement cannot be true since is_lock_type is a boolean and
>> GFC_CAF_CRITICAL is 4.
>>
>> Using if (is_lock_type) it produces the right result for the lock
>> registration.
>>
>>
>> Regards
>>
>> Alessandro
>>
>> 2014-07-28 14:37 GMT-06:00 Tobias Burnus <burnus@net-b.de>:
>>>
>>> This patch implements -fcoarray=lib support for CRITICAL blocks and
>>> includes
>>> some preparatory work for locking. In particular:
>>>
>>> * Updated the documentation for locking/critical, minor cleanup. The
>>> patch
>>> goes on top of the unreviewed patch
>>> https://gcc.gnu.org/ml/fortran/2014-07/msg00155.html
>>> * Add libcaf_single implementation for lock/unlock
>>> * Add lock/unlock calls for CRITICAL
>>> * Register static/SAVEd locking variables and locking variables for
>>> critical
>>> sections.
>>>
>>> Build and currently regtesting on x86-64-gnu-linux.
>>> OK when it regtested successfully?
>>>
>>>   * * *
>>>
>>> Still to be done as follow up:
>>> * Handling the registering of lock-type components in statically
>>> allocated
>>> derived types
>>> * Handling the registering of lock-type variables and components with
>>> allocate and with implicit/explicit deallocate
>>> * Calling lock/unlock function for those
>>> * Test case for locking and critical blocks
>>>
>>> Other coarray to-do items:
>>> * Type-conversion test case missing
>>> * Vector subscript library implementation + test cases
>>> * Extending the documentation
>>> * Issues with striding for coarray components of derived types
>>> * Nonallocatable polymophic coarrays and select type/associated
>>> * Allocatable/pointer components of coarrays; co_reduce and co_broadcast
>>>
>>> Tobias
>
>
diff mbox

Patch

2014-07-28  Tobias Burnus  <burnus@net-b.de>

	* gfortran.texi (caf_register_t): Add CAF_REGTYPE_CRITICAL.
	(_gfortran_caf_register): Update for locking/critical.
	(_gfortran_caf_lock, _gfortran_caf_unlock): Add.
	* resolve.c (resolve_critical): New.
	(gfc_resolve_code): Call it.
	* trans-decl.c (gfor_fndecl_caf_critical,
	gfor_fndecl_caf_end_critical): Remove.
	(gfor_fndecl_caf_lock, gfor_fndecl_caf_unlock): Add.
	(gfc_build_builtin_function_decls): Remove critical,
	assign locking declarations.
	(generate_coarray_sym_init): Handle locking and
	critical variables.
	* trans-stmt.c (gfc_trans_critical): Add calls to
	lock/unlock libcaf functions.
	* trans.h (gfc_coarray_type): Update locking, add
	critical enum values.
	(gfor_fndecl_caf_critical, gfor_fndecl_caf_end_critical): Remove.
	(gfor_fndecl_caf_lock, gfor_fndecl_caf_unlock): Add.

2014-07-28  Tobias Burnus  <burnus@net-b.de>

	* caf/libcaf.h (caf_register_t): Update for critical.
	(_gfortran_caf_critical, _gfortran_caf_end_critical): Remove.
	(_gfortran_caf_lock, _gfortran_caf_unlock): Add.
	* caf/single.c (_gfortran_caf_register): Handle locking
	variables.
	(_gfortran_caf_sendget): Re-name args for consistency.
	(_gfortran_caf_lock, _gfortran_caf_unlock): Add.

diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 5f6bf5d..2d49b2b 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -157,7 +157,7 @@  Boston, MA 02110-1301, USA@*
 @top Introduction
 @cindex Introduction
 
-This manual documents the use of @command{gfortran}, 
+This manual documents the use of @command{gfortran},
 the GNU Fortran compiler.  You can find in this manual how to invoke
 @command{gfortran}, as well as its features and incompatibilities.
 
@@ -290,13 +290,13 @@  It also helps developers to find bugs in the compiler itself.
 @item
 Provide information in the generated machine code that can
 make it easier to find bugs in the program (using a debugging tool,
-called a @dfn{debugger}, such as the GNU Debugger @command{gdb}). 
+called a @dfn{debugger}, such as the GNU Debugger @command{gdb}).
 
 @item
 Locate and gather machine code already generated to
 perform actions requested by statements in the user's program.
 This machine code is organized into @dfn{modules} and is located
-and @dfn{linked} to the user program. 
+and @dfn{linked} to the user program.
 @end itemize
 
 The GNU Fortran compiler consists of several components:
@@ -2714,7 +2714,8 @@  are in a shared library.  The following attributes are available:
 
 @itemize
 @item @code{DLLEXPORT} -- provide a global pointer to a pointer in the DLL
-@item @code{DLLIMPORT} -- reference the function or variable using a global pointer 
+@item @code{DLLIMPORT} -- reference the function or variable using a
+global pointer
 @end itemize
 
 For dummy arguments, the @code{NO_ARG_CHECK} attribute can be used; in
@@ -2864,7 +2865,7 @@  if e.g. an input-output edit descriptor is invalid in a given standard.
 Possible values are (bitwise or-ed) @code{GFC_STD_F77} (1),
 @code{GFC_STD_F95_OBS} (2), @code{GFC_STD_F95_DEL} (4), @code{GFC_STD_F95}
 (8), @code{GFC_STD_F2003} (16), @code{GFC_STD_GNU} (32),
-@code{GFC_STD_LEGACY} (64), @code{GFC_STD_F2008} (128), 
+@code{GFC_STD_LEGACY} (64), @code{GFC_STD_F2008} (128),
 @code{GFC_STD_F2008_OBS} (256) and GFC_STD_F2008_TS (512). Default:
 @code{GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F95 | GFC_STD_F2003
 | GFC_STD_F2008 | GFC_STD_F2008_TS | GFC_STD_F2008_OBS | GFC_STD_F77
@@ -3103,7 +3104,7 @@  by-reference argument.  Note that with the @option{-ff2c} option,
 the argument passing is modified and no longer completely matches
 the platform ABI.  Some other Fortran compilers use @code{f2c}
 semantic by default; this might cause problems with
-interoperablility. 
+interoperablility.
 
 GNU Fortran passes most arguments by reference, i.e. by passing a
 pointer to the data.  Note that the compiler might use a temporary
@@ -3215,7 +3216,8 @@  typedef enum caf_register_t {
   CAF_REGTYPE_COARRAY_STATIC,
   CAF_REGTYPE_COARRAY_ALLOC,
   CAF_REGTYPE_LOCK_STATIC,
-  CAF_REGTYPE_LOCK_ALLOC
+  CAF_REGTYPE_LOCK_ALLOC,
+  CAF_REGTYPE_CRITICAL
 }
 caf_register_t;
 @end verbatim
@@ -3234,6 +3236,8 @@  caf_register_t;
 * _gfortran_caf_send:: Sending data from a local image to a remote image
 * _gfortran_caf_get:: Getting data from a remote image
 * _gfortran_caf_sendget:: Sending data between remote images
+* _gfortran_caf_lock:: Locking a lock variable
+* _gfortran_caf_unlock:: Unlocking a lock variable
 @end menu
 
 
@@ -3360,17 +3364,26 @@  value and, if not-@code{NULL}, @var{ERRMSG} shall be set to a string describing
 the failure. The function shall return a pointer to the requested memory
 for the local image as a call to @code{malloc} would do.
 
+For @code{CAF_REGTYPE_COARRAY_STATIC} and @code{CAF_REGTYPE_COARRAY_ALLOC},
+the passed size is the byte size requested.  For @code{CAF_REGTYPE_LOCK_STATIC},
+@code{CAF_REGTYPE_LOCK_ALLOC} and @code{CAF_REGTYPE_CRITICAL} it is the array
+size or one for a scalar.
+
+
 @item @emph{Syntax}:
 @code{void *caf_register (size_t size, caf_register_t type, caf_token_t *token,
 int *stat, char *errmsg, int errmsg_len)}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{size} @tab byte size of the coarray to be allocated
+@item @var{size} @tab For normal coarrays, the byte size of the coarray to be
+allocated; for lock types, the number of elements.
 @item @var{type} @tab one of the caf_register_t types.
 @item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=; may be NULL
-@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to an error message; may be NULL
+@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
+may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
 @item @var{errmsg_len} @tab the buffer size of errmsg.
 @end multitable
 
@@ -3383,6 +3396,13 @@  static memory is used.  The token permits to identify the coarray; to the
 processor, the token is a nonaliasing pointer. The library can, for instance,
 store the base address of the coarray in the token, some handle or a more
 complicated struct.
+
+For normal coarrays, the returned pointer is used for accesses on the local
+image. For lock types, the value shall only used for checking the allocation
+status. Note that for critical blocks, the locking is only required on one
+image; in the locking statement, the processor shall always pass always an
+image index of one for critical-block lock variables
+(@code{CAF_REGTYPE_CRITICAL}).
 @end table
 
 
@@ -3402,8 +3422,10 @@  int errmsg_len)}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=; may be NULL
-@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to an error message; may be NULL
+@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
+may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set
+to an error message; may be NULL
 @item @var{errmsg_len} @tab the buffer size of errmsg.
 @end multitable
 
@@ -3549,6 +3571,79 @@  character kinds.
 @end table
 
 
+@node _gfortran_caf_lock
+@subsection @code{_gfortran_caf_lock} --- Locking a lock variable
+@cindex Coarray, _gfortran_caf_lock
+
+@table @asis
+@item @emph{Description}:
+Acquire a lock on the given image on a scalar locking variable or for the
+given array element for an array-valued variable. If the @var{aquired_lock}
+is @code{NULL}, the function return after having obtained the lock. If it is
+nonnull, the result is is assigned the value true (one) when the lock could be
+obtained and false (zero) otherwise.  Locking a lock variable which has already
+been locked by the same image is an error.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_lock (caf_token_t token, size_t index, int image_index,
+int *aquired_lock, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number.
+@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock
+could be obtained
+@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
+may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This function is also called for critical blocks; for those, the array index
+is always zero and the image index is one.  Libraries are permitted to use other
+images for critical-block locking variables.
+@end table
+
+
+@node _gfortran_caf_unlock
+@subsection @code{_gfortran_caf_lock} --- Unlocking a lock variable
+@cindex Coarray, _gfortran_caf_unlock
+
+@table @asis
+@item @emph{Description}:
+Release a lock on the given image on a scalar locking variable or for the
+given array element for an array-valued variable. Unlocking a lock variable
+which is unlocked or has been locked by a different image is an error.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_unlock (caf_token_t token, size_t index, int image_index,
+int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number.
+@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
+may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This function is also called for critical block; for those, the array index
+is always zero and the image index is one.  Libraries are permitted to use other
+images for critical-block locking variables.
+@end table
 
 
 
@@ -3693,7 +3788,7 @@  order.  Most of these are necessary to be fully compatible with
 existing Fortran compilers, but they are not part of the official
 J3 Fortran 95 standard.
 
-@subsection Compiler extensions: 
+@subsection Compiler extensions:
 @itemize @bullet
 @item
 User-specified alignment rules for structures.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 15d8dab..b6ce022 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8475,6 +8475,52 @@  resolve_lock_unlock (gfc_code *code)
 
 
 static void
+resolve_critical (gfc_code *code)
+{
+  gfc_symtree *symtree;
+  gfc_symbol *lock_type;
+  char name[GFC_MAX_SYMBOL_LEN];
+  static int serial = 0;
+
+  if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+    return;
+
+  symtree = gfc_find_symtree (gfc_current_ns->sym_root, "__lock_type@0");
+  if (symtree)
+    lock_type = symtree->n.sym;
+  else
+    {
+      if (gfc_get_sym_tree ("__lock_type@0", gfc_current_ns, &symtree,
+	  false) != 0)
+	gcc_unreachable ();
+      lock_type = symtree->n.sym;
+      lock_type->attr.flavor = FL_DERIVED;
+      lock_type->attr.zero_comp = 1;
+      lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
+      lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
+    }
+
+  sprintf(name, "__lock_var@%d",serial++);
+  if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
+    gcc_unreachable ();
+
+  code->resolved_sym = symtree->n.sym;
+  symtree->n.sym->attr.flavor = FL_VARIABLE;
+  symtree->n.sym->attr.referenced = 1;
+  symtree->n.sym->attr.artificial = 1;
+  symtree->n.sym->attr.codimension = 1;
+  symtree->n.sym->ts.type = BT_DERIVED;
+  symtree->n.sym->ts.u.derived = lock_type;
+  symtree->n.sym->as = gfc_get_array_spec ();
+  symtree->n.sym->as->corank = 1;
+  symtree->n.sym->as->type = AS_EXPLICIT;
+  symtree->n.sym->as->cotype = AS_EXPLICIT;
+  symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+						   NULL, 1);
+}
+
+
+static void
 resolve_sync (gfc_code *code)
 {
   /* Check imageset. The * case matches expr1 == NULL.  */
@@ -9913,7 +9959,10 @@  gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 	case EXEC_CONTINUE:
 	case EXEC_DT_END:
 	case EXEC_ASSIGN_CALL:
+	  break;
+
 	case EXEC_CRITICAL:
+	  resolve_critical (code);
 	  break;
 
 	case EXEC_SYNC_ALL:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 8b56151..916b3e0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -135,8 +135,6 @@  tree gfor_fndecl_caf_deregister;
 tree gfor_fndecl_caf_get;
 tree gfor_fndecl_caf_send;
 tree gfor_fndecl_caf_sendget;
-tree gfor_fndecl_caf_critical;
-tree gfor_fndecl_caf_end_critical;
 tree gfor_fndecl_caf_sync_all;
 tree gfor_fndecl_caf_sync_images;
 tree gfor_fndecl_caf_error_stop;
@@ -145,6 +143,8 @@  tree gfor_fndecl_caf_atomic_def;
 tree gfor_fndecl_caf_atomic_ref;
 tree gfor_fndecl_caf_atomic_cas;
 tree gfor_fndecl_caf_atomic_op;
+tree gfor_fndecl_caf_lock;
+tree gfor_fndecl_caf_unlock;
 tree gfor_fndecl_co_max;
 tree gfor_fndecl_co_min;
 tree gfor_fndecl_co_sum;
@@ -3368,12 +3368,6 @@  gfc_build_builtin_function_decls (void)
 	pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node,
 	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
 
-      gfor_fndecl_caf_critical = gfc_build_library_function_decl (
-	get_identifier (PREFIX("caf_critical")), void_type_node, 0);
-
-      gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
-	get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
-
       gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
 	3, pint_type, pchar_type_node, integer_type_node);
@@ -3417,6 +3411,16 @@  gfc_build_builtin_function_decls (void)
 	integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
 	integer_type_node, integer_type_node);
 
+      gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_lock")), "R..WWW",
+	void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
+	pint_type, pint_type, pchar_type_node, integer_type_node);
+
+      gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_unlock")), "R..WW",
+	void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
+	pint_type, pchar_type_node, integer_type_node);
+
       gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("caf_co_max")), "W.WW",
 	void_type_node, 6, pvoid_type_node, integer_type_node,
@@ -4694,6 +4698,8 @@  static void
 generate_coarray_sym_init (gfc_symbol *sym)
 {
   tree tmp, size, decl, token;
+  bool is_lock_type;
+  int reg_type;
 
   if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
       || sym->attr.use_assoc || !sym->attr.referenced
@@ -4704,11 +4710,20 @@  generate_coarray_sym_init (gfc_symbol *sym)
   TREE_USED(decl) = 1;
   gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
 
+  is_lock_type = 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;
+
   /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
      to make sure the variable is not optimized away.  */
   DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
 
-  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
+  /* For lock types, we pass the array size as only the library knows the
+     size of the variable.  */
+  if (is_lock_type)
+    size = gfc_index_one_node;
+  else
+    size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
 
   /* Ensure that we do not have size=0 for zero-sized arrays.  */
   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
@@ -4725,17 +4740,17 @@  generate_coarray_sym_init (gfc_symbol *sym)
   gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
   token = gfc_build_addr_expr (ppvoid_type_node,
 			       GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
-
+  if (is_lock_type == GFC_CAF_CRITICAL)
+    reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+  else
+    reg_type = GFC_CAF_COARRAY_STATIC;
   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
-			     build_int_cst (integer_type_node,
-					    GFC_CAF_COARRAY_STATIC), /* type.  */
+			     build_int_cst (integer_type_node, reg_type),
 			     token, null_pointer_node, /* token, stat.  */
 			     null_pointer_node, /* errgmsg, errmsg_len.  */
 			     build_int_cst (integer_type_node, 0));
-
   gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
 
-
   /* Handle "static" initializer.  */
   if (sym->value)
     {
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 547e9c1..227e0f8 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1111,13 +1156,18 @@  tree
 gfc_trans_critical (gfc_code *code)
 {
   stmtblock_t block;
-  tree tmp;
+  tree tmp, token = NULL_TREE;
 
   gfc_start_block (&block);
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
     {
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
+      token = gfc_get_symbol_decl (code->resolved_sym);
+      token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
+				 token, integer_zero_node, integer_one_node,
+				 boolean_true_node, null_pointer_node,
+				 null_pointer_node, integer_zero_node);
       gfc_add_expr_to_block (&block, tmp);
     }
 
@@ -1126,8 +1176,10 @@  gfc_trans_critical (gfc_code *code)
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
     {
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
-				 0);
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
+				 token, integer_zero_node, integer_one_node,
+				 null_pointer_node, null_pointer_node,
+				 integer_zero_node);
       gfc_add_expr_to_block (&block, tmp);
     }
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bae51bf..70c794b 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -107,8 +107,9 @@  typedef enum
 {
   GFC_CAF_COARRAY_STATIC,
   GFC_CAF_COARRAY_ALLOC,
-  GFC_CAF_LOCK,
-  GFC_CAF_LOCK_COMP
+  GFC_CAF_LOCK_STATIC,
+  GFC_CAF_LOCK_ALLOC,
+  GFC_CAF_CRITICAL
 }
 gfc_coarray_type;
 
@@ -714,8 +717,6 @@  extern GTY(()) tree gfor_fndecl_caf_deregister;
 extern GTY(()) tree gfor_fndecl_caf_get;
 extern GTY(()) tree gfor_fndecl_caf_send;
 extern GTY(()) tree gfor_fndecl_caf_sendget;
-extern GTY(()) tree gfor_fndecl_caf_critical;
-extern GTY(()) tree gfor_fndecl_caf_end_critical;
 extern GTY(()) tree gfor_fndecl_caf_sync_all;
 extern GTY(()) tree gfor_fndecl_caf_sync_images;
 extern GTY(()) tree gfor_fndecl_caf_error_stop;
@@ -724,6 +725,8 @@  extern GTY(()) tree gfor_fndecl_caf_atomic_def;
 extern GTY(()) tree gfor_fndecl_caf_atomic_ref;
 extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
 extern GTY(()) tree gfor_fndecl_caf_atomic_op;
+extern GTY(()) tree gfor_fndecl_caf_lock;
+extern GTY(()) tree gfor_fndecl_caf_unlock;
 extern GTY(()) tree gfor_fndecl_co_max;
 extern GTY(()) tree gfor_fndecl_co_min;
 extern GTY(()) tree gfor_fndecl_co_sum;
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 0ae7135..85d6811 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -55,8 +55,9 @@  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 typedef enum caf_register_t {
   CAF_REGTYPE_COARRAY_STATIC,
   CAF_REGTYPE_COARRAY_ALLOC,
-  CAF_REGTYPE_LOCK,
-  CAF_REGTYPE_LOCK_COMP
+  CAF_REGTYPE_LOCK_STATIC,
+  CAF_REGTYPE_LOCK_ALLOC,
+  CAF_REGTYPE_CRITICAL
 }
 caf_register_t;
 
@@ -101,15 +102,6 @@  void _gfortran_caf_deregister (caf_token_t *, int *, char *, int);
 void _gfortran_caf_sync_all (int *, char *, int);
 void _gfortran_caf_sync_images (int, int[], int *, char *, int);
 
-/* FIXME: The CRITICAL functions should be removed;
-   the functionality is better represented using Coarray's lock feature.  */
-void _gfortran_caf_critical (void);
-void _gfortran_caf_critical (void)  { }
-
-void _gfortran_caf_end_critical (void);
-void _gfortran_caf_end_critical (void)  { }
-
-
 void _gfortran_caf_error_stop_str (const char *, int32_t)
      __attribute__ ((noreturn));
 void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
@@ -137,4 +129,8 @@  void _gfortran_caf_atomic_cas (caf_token_t, size_t, int, void *, void *,
 			       void *, int *, int, int);
 void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
 			      int *, int, int);
+
+void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int);
+void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
+
 #endif  /* LIBCAF_H  */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 1f5da72..990953a 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -100,7 +100,11 @@  _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 {
   void *local;
 
-  local = malloc (size);
+  if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
+      || type == CAF_REGTYPE_CRITICAL)
+    local = calloc (size, sizeof (bool));
+  else
+    local = malloc (size);
   *token = malloc (sizeof (single_token_t));
 
   if (unlikely (local == NULL || token == NULL))
@@ -128,7 +132,8 @@  _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
   if (stat)
     *stat = 0;
 
-  if (type == CAF_REGTYPE_COARRAY_STATIC)
+  if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
+      || type == CAF_REGTYPE_CRITICAL)
     {
       caf_static_t *tmp = malloc (sizeof (caf_static_t));
       tmp->prev  = caf_static_list;
@@ -526,7 +531,7 @@  error:
 void
 _gfortran_caf_get (caf_token_t token, size_t offset,
 		   int image_index __attribute__ ((unused)),
-		   gfc_descriptor_t *src ,
+		   gfc_descriptor_t *src,
 		   caf_vector_t *src_vector __attribute__ ((unused)),
 		   gfc_descriptor_t *dest, int src_kind, int dst_kind)
 {
@@ -764,7 +769,7 @@  _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 		       int src_image_index __attribute__ ((unused)),
 		       gfc_descriptor_t *src,
 		       caf_vector_t *src_vector __attribute__ ((unused)),
-		       int dst_len, int src_len)
+		       int dst_kind, int src_kind)
 {
   /* FIXME: Handle vector subscript of 'src_vector'.  */
   /* For a single image, src->base_addr should be the same as src_token + offset
@@ -772,7 +777,7 @@  _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
   void *src_base = GFC_DESCRIPTOR_DATA (src);
   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
-		      src, dst_len, src_len);
+		      src, dst_kind, src_kind);
   GFC_DESCRIPTOR_DATA (src) = src_base;
 }
 
@@ -864,3 +869,80 @@  _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
   if (stat)
     *stat = 0;
 }
+
+
+void
+_gfortran_caf_lock (caf_token_t token, size_t index,
+		    int image_index __attribute__ ((unused)),
+		    int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
+{
+  const char *msg = "Already locked";
+  bool *lock = &((bool *) TOKEN (token))[index];
+
+  if (!*lock)
+    {
+      *lock = true;
+      if (aquired_lock)
+	*aquired_lock = (int) true;
+      if (stat)
+	*stat = 0;
+      return;
+    }
+
+  if (aquired_lock)
+    {
+      *aquired_lock = (int) false;
+      if (stat)
+	*stat = 0;
+    return;
+    }
+
+
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
+						      : (int) sizeof (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      return;
+    }
+  _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+}
+
+
+void
+_gfortran_caf_unlock (caf_token_t token, size_t index,
+		      int image_index __attribute__ ((unused)),
+		      int *stat, char *errmsg, int errmsg_len)
+{
+  const char *msg = "Variable is not locked";
+  bool *lock = &((bool *) TOKEN (token))[index];
+
+  if (*lock)
+    {
+      *lock = false;
+      if (stat)
+	*stat = 0;
+      return;
+    }
+
+  if (stat)
+    {
+      *stat = 1;
+      if (errmsg_len > 0)
+	{
+	  int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
+						      : (int) sizeof (msg);
+	  memcpy (errmsg, msg, len);
+	  if (errmsg_len > len)
+	    memset (&errmsg[len], ' ', errmsg_len-len);
+	}
+      return;
+    }
+  _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+}