From patchwork Mon Jul 28 20:37:13 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 374316 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 2B57814011B for ; Tue, 29 Jul 2014 06:37:32 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=D5kolVzWqRl3bAwhj6T7AZxGlb6I5sp952fXg46Z38KOTO LBrgbnVjyWgD1gwAyRouR3vVXyBQaB/yauq1n+MFID6CTk4/3hWPiBteJHUAGWBN 3WyumFp+fi7chnTci9KVqcBdskkMruVjjmfoT7q9oNadQKHaubFqMZiR5p2kw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=T+LxWvwU1pRNPuc9x4aB5DCqKZE=; b=ow2/IKbxRMIhNhHvrqWL offLark6VnEAXs1gCEWy0MyL1FjMPj7HTJLD3X9M65oXngtpbuMy0Dq351lZq74T 7Hqc+lMamrpGKS6ECzAKoPnFFptHhXBCAOHcWd+ES7l2HeFj6646ZUlW+Usg95bN wjT+GnFlWjJXAyuX9GFZpTI= Received: (qmail 23435 invoked by alias); 28 Jul 2014 20:37:25 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 23402 invoked by uid 89); 28 Jul 2014 20:37:23 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx02.qsc.de Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Mon, 28 Jul 2014 20:37:18 +0000 Received: from tux.net-b.de (port-92-194-213-151.dynamic.qsc.de [92.194.213.151]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx02.qsc.de (Postfix) with ESMTPSA id 950F02766F; Mon, 28 Jul 2014 22:37:14 +0200 (CEST) Message-ID: <53D6B479.7020905@net-b.de> Date: Mon, 28 Jul 2014 22:37:13 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.6.0 MIME-Version: 1.0 To: gcc-patches , gfortran Subject: [Patch, Fortran] -fcoarray=lib - support CRITICAL, prepare for locking support 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 2014-07-28 Tobias Burnus * 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 * 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)); +}