From patchwork Wed Dec 30 17:09:04 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1421427 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=XODSxy+r; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4D5d7758q6z9sTK for ; Thu, 31 Dec 2020 04:09:18 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id F2044388C032; Wed, 30 Dec 2020 17:09:12 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org F2044388C032 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1609348153; bh=V1TwwsG8TNHoaQHNk3TmIR7mgJI1/qr0BRu/ZHKyXzY=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=XODSxy+raskhBTT532pH6CnyuXY9e0af9CJSl708I4ecxqJAR6co2hFEWiOEfPidh wIZieyhlIjjutF9GP5JEV7ZnfF6+11lYqV6bLXhnVrQOdWHGvzUcIg5rbdFLgOkxXY fyKLzakHfVIiltrey87kvhaJCQGKcmisGwlFFRCI= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout3.netcologne.de (cc-smtpout3.netcologne.de [89.1.8.213]) by sourceware.org (Postfix) with ESMTPS id E13573851C34; Wed, 30 Dec 2020 17:09:07 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org E13573851C34 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id 6162B1230A; Wed, 30 Dec 2020 18:09:06 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id 53CD211DFC; Wed, 30 Dec 2020 18:09:06 +0100 (CET) Received: from [2001:4dd7:542b:0:97c4:7327:973b:657] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.11.6) (envelope-from ) id 5fecb432-02f5-7f0000012729-7f00000183cc-1 for ; Wed, 30 Dec 2020 18:09:06 +0100 Received: from linux-p51k.fritz.box (2001-4dd7-542b-0-97c4-7327-973b-657.ipv6dyn.netcologne.de [IPv6:2001:4dd7:542b:0:97c4:7327:973b:657]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA; Wed, 30 Dec 2020 18:09:04 +0100 (CET) To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, shared coarrays, committed] Fix Message-ID: Date: Wed, 30 Dec 2020 18:09:04 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.6.0 MIME-Version: 1.0 Content-Language: de-DE X-Spam-Status: No, score=-10.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_SHORT, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Thomas Koenig via Gcc-patches From: Thomas Koenig Reply-To: Thomas Koenig Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hello world, I just committed the attached patch to the branch as https://gcc.gnu.org/git/gitweb.cgi?p=gcc.git;h=4726e39b0be3c0bc55e43d2d300f0d0b9529d883 . It is sometimes astonishing, if you shake code a bit, how many bugs came crawling out :-) Best regards Thomas Make STAT and ERRMSG work on ALLOCATE, move error handling to library. This makes STAT and ERRMSG work on ALLOCATE. It also separates the allocation of coarrays into two functions: One without error checking, which is called by compiler-generated code, and one with error checking for call from user code. In the course of looking at this, it was also noticed that allocatable coarrays were not automatically deallocated; this is now also fixed. Also, saved allocatable coarrays are now saved. gcc/fortran/ChangeLog: * trans-array.c (gfc_allocate_shared_coarray): Remove extra arguments, just build the call. (allocate_shared_coarray_chk): New function. (gfc_array_allocate): Adjust where to set the offset. Error handling is done in the library for shared coarrays. (gfc_trans_deferred_array): No early return for allocatable shared coarrays. * trans-array.h (gfc_array_allocate): Adjust prototype. (gfc_allocate_shared_coarray): Likewise. * trans-decl.c: Rename gfor_fndecl_cas_coarray_allocate to gfor_fndecl_cas_coarray_alloc for brevity. Add gfor_fndecl_cas_coarray_alloc_chk. (gfc_build_builtin_function_decls): Likewise. (gfc_trans_shared_coarray): Adjust calling sequence for gfc_allocate_shared_coarray. (gfc_trans_deferred_vars): Correct handling of saved allocatable shared coarrays. * trans-stmt.c (gfc_trans_sync): Adjust whitespace.o (coarray_alloc_p): Remove. (gfc_trans_allocate): Add shared_coarray variable to adjust status and errmsg handling. * trans.h: Rename gfor_fndecl_cas_coarray_allocate to gfor_fndecl_cas_coarray_alloc for brevity. Add gfor_fndecl_cas_coarray_alloc_chk. libgfortran/ChangeLog: * caf_shared/coarraynative.c (test_for_cas_errors): Correct handling of stat. * caf_shared/libcoarraynative.h (STAT_ERRMSG_ENTRY_CHECK): Use unlikely in condition. (STAT_ERRMSG_ENTRY_CHECK_RET): Likewise. * caf_shared/wrapper.c (cas_coarray_alloc): Adjust arguments. Call cas_coarray_alloc_work. (cas_coarray_alloc_chk): New function. (cas_coarray_alloc_work): New function. gcc/testsuite/ChangeLog: * gfortran.dg/caf-shared/allocate_1.f90: Adjust number of calls to sync_all. * gfortran.dg/caf-shared/allocate_status_1.f90: New test. * gfortran.dg/caf-shared/automatic_deallocate_1.f90: New test. * gfortran.dg/caf-shared/save_allocatable_1.f90: New test. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 58aaa5f781d..998ec959402 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5982,12 +5982,29 @@ gfc_cas_get_allocation_type (gfc_symbol * sym) return GFC_NCA_NORMAL_COARRAY; } +/* Allocate a shared coarray from a constructor, without checking. */ + +void +gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank, + int alloc_type) +{ + gfc_add_expr_to_block (b, + build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc, + 4, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type))); +} + +/* Allocate a shared coarray from user space, with checking. */ + void -gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank, - int corank, int alloc_type, tree status, - tree errmsg, tree errlen, bool calc_offset) +allocate_shared_coarray_chk (stmtblock_t *b, tree decl, tree size, int rank, + int corank, int alloc_type, tree status, + tree errmsg, tree errlen) { tree st, err, elen; + int i; + tree offset, stride, lbound, mult; if (status == NULL_TREE) st = null_pointer_node; @@ -5996,28 +6013,25 @@ gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank, err = errmsg == NULL_TREE ? null_pointer_node : errmsg; elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen; + gfc_add_expr_to_block (b, - build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate, - 7, gfc_build_addr_expr (pvoid_type_node, decl), - size, build_int_cst (integer_type_node, corank), - build_int_cst (integer_type_node, alloc_type), - st, err, elen)); - if (calc_offset) - { - int i; - tree offset, stride, lbound, mult; - offset = build_int_cst (gfc_array_index_type, 0); - for (i = 0; i < rank + corank; i++) - { - stride = gfc_conv_array_stride (decl, i); - lbound = gfc_conv_array_lbound (decl, i); - mult = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, lbound); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, mult); - } - gfc_conv_descriptor_offset_set (b, decl, offset); + build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc_chk, + 7, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type), + st, err, elen)); + + offset = build_int_cst (gfc_array_index_type, 0); + for (i = 0; i < rank + corank; i++) + { + stride = gfc_conv_array_stride (decl, i); + lbound = gfc_conv_array_lbound (decl, i); + mult = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + stride, lbound); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, mult); } + gfc_conv_descriptor_offset_set (b, decl, offset); } /* Initializes the descriptor and generates a call to _gfor_allocate. Does @@ -6028,7 +6042,7 @@ bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) + bool e3_has_nodescriptor, bool *shared_coarray) { tree tmp; tree allocation; @@ -6162,6 +6176,16 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, expr3_elem_size, nelems, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size); + /* Update the array descriptor with the offset and the span. */ + if (dimension) + { + gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + tmp = fold_convert (gfc_array_index_type, element_size); + gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); + } + + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (dimension && !(flag_coarray == GFC_FCOARRAY_SHARED && coarray)) { var_overflow = gfc_create_var (integer_type_node, "overflow"); @@ -6224,12 +6248,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, elem_size = expr3_elem_size; else elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr))); + + /* Setting the descriptor needs to be done before allocation of the + shared coarray. */ + gfc_add_expr_to_block (&elseblock, set_descriptor); + int alloc_type = gfc_cas_get_allocation_type (expr->symtree->n.sym); - gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size, + allocate_shared_coarray_chk (&elseblock, se->expr, elem_size, ref->u.ar.as->rank, ref->u.ar.as->corank, - alloc_type, status, errmsg, errlen, - true); + alloc_type, status, errmsg, errlen); + *shared_coarray = true; } /* The allocatable variant takes the old pointer as first argument. */ else if (allocatable) @@ -6255,40 +6284,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else allocation = gfc_finish_block (&elseblock); - - /* Update the array descriptor with the offset and the span. */ - if (dimension) - { - gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); - tmp = fold_convert (gfc_array_index_type, element_size); - gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); - } - - set_descriptor = gfc_finish_block (&set_descriptor_block); - - if (status != NULL_TREE) + if (status != NULL_TREE && !(coarray && flag_coarray == GFC_FCOARRAY_SHARED)) { cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); + logical_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); if (not_prev_allocated != NULL_TREE) cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, not_prev_allocated); + logical_type_node, cond, + not_prev_allocated); - set_descriptor = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, - set_descriptor, - build_empty_stmt (input_location)); + set_descriptor = fold_build3_loc (input_location, COND_EXPR, + void_type_node, cond, + set_descriptor, + build_empty_stmt (input_location)); } /* For native coarrays, the size must be set before the allocation routine can be called. */ if (coarray && flag_coarray == GFC_FCOARRAY_SHARED) - { - gfc_add_expr_to_block (&se->pre, set_descriptor); - gfc_add_expr_to_block (&se->pre, allocation); - } + gfc_add_expr_to_block (&se->pre, allocation); else { gfc_add_expr_to_block (&se->pre, allocation); @@ -10994,7 +11010,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Although static, derived types with default initializers and allocatable components must not be nulled wholesale; instead they are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) + if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer + && !(flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension)) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2168e9dc901..bfd174bd1cd 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, tree, bool); + tree, tree *, gfc_expr *, tree, bool, bool *); enum gfc_coarray_allocation_type { GFC_NCA_NORMAL_COARRAY = 1, @@ -31,8 +31,7 @@ enum gfc_coarray_allocation_type { int gfc_cas_get_allocation_type (gfc_symbol *); -void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int, - tree, tree, tree, bool); +void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ab2725ca6f1..61d5667cf12 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -174,7 +174,8 @@ tree gfor_fndecl_caf_is_present; /* Native coarray functions. */ tree gfor_fndecl_cas_master; -tree gfor_fndecl_cas_coarray_allocate; +tree gfor_fndecl_cas_coarray_alloc; +tree gfor_fndecl_cas_coarray_alloc_chk; tree gfor_fndecl_cas_coarray_free; tree gfor_fndecl_cas_this_image; tree gfor_fndecl_cas_num_images; @@ -4120,16 +4121,25 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_cas_master = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1, build_pointer_type (build_function_type_list (void_type_node, NULL_TREE))); - gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7, - pvoid_type_node, /* desc. */ - size_type_node, /* elem_size. */ - integer_type_node, /* corank. */ - integer_type_node, /* alloc_type. */ - gfc_pint4_type_node, /* stat. */ - pchar1_type_node, /* errmsg. */ - gfc_charlen_type_node, /* errmsg_len. */ - NULL_TREE); + gfor_fndecl_cas_coarray_alloc_chk = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("cas_coarray_alloc_chk")), ". . R R R W W . ", + integer_type_node, 7, + pvoid_type_node, /* desc. */ + size_type_node, /* elem_size. */ + integer_type_node, /* corank. */ + integer_type_node, /* alloc_type. */ + gfc_pint4_type_node, /* stat. */ + pchar1_type_node, /* errmsg. */ + gfc_charlen_type_node); /* errmsg_len. */ + gfor_fndecl_cas_coarray_alloc + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ", + integer_type_node, 4, + pvoid_type_node, /* desc. */ + size_type_node, /* elem_size. */ + integer_type_node, /* corank. */ + integer_type_node); /* alloc_type. */ + gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2, pvoid_type_node, /* Pointer to the descriptor to be deallocated. */ @@ -4699,11 +4709,8 @@ gfc_trans_shared_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol * NULL_TREE, &nelems, NULL, NULL_TREE, true, NULL, &element_size); elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl))); - gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank, - sym->as->corank, alloc_type, - NULL_TREE, NULL_TREE, - build_int_cst (gfc_charlen_type_node, 0), - false); + gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank, + alloc_type); gfc_conv_descriptor_offset_set (init, decl, offset); } @@ -5055,7 +5062,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) else if (flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension) { - gfc_trans_shared_coarray_inline (block, sym); + if (sym->attr.save == SAVE_EXPLICIT) + gfc_trans_shared_coarray_static (sym); + else + gfc_trans_shared_coarray_inline (block, sym); } else { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1f656d43d88..09f63273427 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1336,7 +1336,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (TREE_TYPE (stat) == integer_type_node) stat = gfc_build_addr_expr (NULL, stat); - if(type == EXEC_SYNC_MEMORY) + if (type == EXEC_SYNC_MEMORY) { /* For shared coarrays, there is no need for a memory fence here because that is emitted anyway below. */ @@ -6227,28 +6227,6 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) return NULL; } -/* Helper function - return true if a coarray is allcoated via this - statement. */ - -static bool -coarray_alloc_p (gfc_code *code) -{ - if (code == NULL || code->op != EXEC_ALLOCATE) - return false; - - for (gfc_alloc *al = code->ext.alloc.list; al != NULL; al = al->next) - { - gfc_ref *ref, *last; - for (ref = al->expr->ref, last = ref; ref; last = ref, ref = ref->next) - ; - - ref = last; - if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen) - return true; - } - return false; -} - /* Translate the ALLOCATE statement. */ tree @@ -6284,6 +6262,7 @@ gfc_trans_allocate (gfc_code * code) gfc_symtree *newsym = NULL; symbol_attribute caf_attr; gfc_actual_arglist *param_list; + bool shared_coarray = false; if (!code->ext.alloc.list) return NULL_TREE; @@ -6815,7 +6794,7 @@ gfc_trans_allocate (gfc_code * code) label_finish, tmp, &nelems, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, - e3_has_nodescriptor)) + e3_has_nodescriptor, &shared_coarray)) { /* A scalar or derived type. First compute the size to allocate. @@ -6972,7 +6951,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_block_to_block (&block, &se.pre); /* Error checking -- Note: ERRMSG only makes sense with STAT. */ - if (code->expr1) + if (code->expr1 && !shared_coarray) { tmp = build1_v (GOTO_EXPR, label_errmsg); parm = fold_build2_loc (input_location, NE_EXPR, @@ -7193,14 +7172,14 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (e3rhs); } /* STAT. */ - if (code->expr1) + if (code->expr1 && !shared_coarray) { tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); } /* ERRMSG - only useful if STAT is present. */ - if (code->expr1 && code->expr2) + if (code->expr1 && code->expr2 && !shared_coarray) { const char *msg = "Attempt to allocate an allocated object"; tree slen, dlen, errmsg_str; @@ -7257,12 +7236,6 @@ gfc_trans_allocate (gfc_code * code) zero_size); gfc_add_expr_to_block (&post, tmp); } - else if (flag_coarray == GFC_FCOARRAY_SHARED && coarray_alloc_p (code)) - { - tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_sync_all, - 1, null_pointer_node); - gfc_add_expr_to_block (&post, tmp); - } gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &post); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d3340b302ad..9a3a72c4e98 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -906,7 +906,8 @@ extern GTY(()) tree gfor_fndecl_caf_is_present; /* Native coarray library function decls. */ extern GTY(()) tree gfor_fndecl_cas_this_image; extern GTY(()) tree gfor_fndecl_cas_num_images; -extern GTY(()) tree gfor_fndecl_cas_coarray_allocate; +extern GTY(()) tree gfor_fndecl_cas_coarray_alloc; +extern GTY(()) tree gfor_fndecl_cas_coarray_alloc_chk; extern GTY(()) tree gfor_fndecl_cas_coarray_free; extern GTY(()) tree gfor_fndecl_cas_sync_images; extern GTY(()) tree gfor_fndecl_cas_sync_all; diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 index 0703b42fd65..f2bc8afec94 100644 --- a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 +++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 @@ -5,5 +5,5 @@ program main allocate (a[*]) deallocate (a) end program main -! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 new file mode 100644 index 00000000000..fe66a07ad42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +program main + integer, allocatable :: a[:] + character (len=80) :: errmsg + integer :: st + st = 42 + allocate (a[*],stat=st) + if (st /= 0) stop 1 + allocate (a[*], stat=st) + if (st == 0) stop 1 + allocate (a[*], stat=st,errmsg=errmsg) + if (st == 0) stop 2 + if (errmsg /= "Attempting to allocate already allocated variable") stop 3 +end program main diff --git a/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 new file mode 100644 index 00000000000..3b7374f9d3b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +! { dg-options "-fdump-tree-original" } + +program main + integer :: n + n = 4096 + do i=1,3 + block + integer, allocatable :: a[:] + if (allocated(a)) stop 1 + allocate (a[*]) + a = 42 + n = n * 2 + end block + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_alloc_chk" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_free" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 new file mode 100644 index 00000000000..182e82e2087 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +! { dg-options "-fdump-tree-original" } + +program main + call test(.true.) + call test(.false.) +contains + subroutine test(flag) + logical, intent(in) :: flag + integer, save, dimension(:), allocatable :: a[:] + if (flag) then + allocate (a(4)[*]) + a = this_image() + else + if (size(a,1) /= 4) stop 1 + if (any(a /= this_image())) stop 2 + end if + end subroutine test +end program main diff --git a/libgfortran/caf_shared/coarraynative.c b/libgfortran/caf_shared/coarraynative.c index 1f1f396d245..1ae0c4068ce 100644 --- a/libgfortran/caf_shared/coarraynative.c +++ b/libgfortran/caf_shared/coarraynative.c @@ -103,45 +103,63 @@ int test_for_cas_errors (int *stat, char *errmsg, size_t errmsg_length) { size_t errmsg_written_bytes; - if (!stat) - return 0; /* This rather strange ordering is mandated by the standard. */ if (this_image.m->finished_images) { - *stat = CAS_STAT_STOPPED_IMAGE; - if (errmsg) + if (stat) { - errmsg_written_bytes = snprintf (errmsg, errmsg_length, - "Stopped images present (currently " - "%d)", - this_image.m->finished_images); - if (errmsg_written_bytes > errmsg_length - 1) - errmsg_written_bytes = errmsg_length - 1; - - memset (errmsg + errmsg_written_bytes, ' ', - errmsg_length - errmsg_written_bytes); + *stat = CAS_STAT_STOPPED_IMAGE; + if (errmsg) + { + errmsg_written_bytes + = snprintf (errmsg, errmsg_length, + "Stopped images present (currently %d)", + this_image.m->finished_images); + if (errmsg_written_bytes > errmsg_length - 1) + errmsg_written_bytes = errmsg_length - 1; + + memset (errmsg + errmsg_written_bytes, ' ', + errmsg_length - errmsg_written_bytes); + } + } + else + { + fprintf (stderr, "Stopped images present (currently %d)", + this_image.m->finished_images); + exit(1); } } else if (this_image.m->has_failed_image) { - *stat = CAS_STAT_FAILED_IMAGE; - if (errmsg) + if (stat) { - errmsg_written_bytes = snprintf (errmsg, errmsg_length, - "Failed images present (currently " - "%d)", - this_image.m->has_failed_image); - if (errmsg_written_bytes > errmsg_length - 1) - errmsg_written_bytes = errmsg_length - 1; - - memset (errmsg + errmsg_written_bytes, ' ', - errmsg_length - errmsg_written_bytes); + *stat = CAS_STAT_FAILED_IMAGE; + if (errmsg) + { + errmsg_written_bytes + = snprintf (errmsg, errmsg_length, + "Failed images present (currently %d)", + this_image.m->has_failed_image); + if (errmsg_written_bytes > errmsg_length - 1) + errmsg_written_bytes = errmsg_length - 1; + + memset (errmsg + errmsg_written_bytes, ' ', + errmsg_length - errmsg_written_bytes); + } + } + else + { + fprintf (stderr, "Failed images present (currently %d)\n", + this_image.m->has_failed_image); + exit(1); } } else { - *stat = 0; + if (stat) + *stat = 0; + return 0; } return 1; diff --git a/libgfortran/caf_shared/libcoarraynative.h b/libgfortran/caf_shared/libcoarraynative.h index e4549652d78..3cc01232519 100644 --- a/libgfortran/caf_shared/libcoarraynative.h +++ b/libgfortran/caf_shared/libcoarraynative.h @@ -109,13 +109,13 @@ internal_proto(error_on_missing_images); #define STAT_ERRMSG_ENTRY_CHECK(stat, errmsg, errmsg_len) \ do { \ - if (test_for_cas_errors(stat, errmsg, errmsg_len))\ + if (unlikely (test_for_cas_errors(stat, errmsg, errmsg_len))) \ return;\ } while(0) #define STAT_ERRMSG_ENTRY_CHECK_RET(stat, errmsg, errmsg_len, retval) \ do { \ - if (test_for_cas_errors(stat, errmsg, errmsg_len))\ + if (unlikely(test_for_cas_errors(stat, errmsg, errmsg_len))) \ return retval;\ } while(0) diff --git a/libgfortran/caf_shared/wrapper.c b/libgfortran/caf_shared/wrapper.c index a3d88660f01..05ee838c243 100644 --- a/libgfortran/caf_shared/wrapper.c +++ b/libgfortran/caf_shared/wrapper.c @@ -44,10 +44,13 @@ enum gfc_coarray_allocation_type GFC_NCA_EVENT_COARRAY, }; -void cas_coarray_alloc (gfc_array_void *, size_t, int, int, int *, - char *, size_t); +void cas_coarray_alloc (gfc_array_void *, size_t, int, int); export_proto (cas_coarray_alloc); +void cas_coarray_alloc_chk (gfc_array_void *, size_t, int, int, int *, + char *, size_t); +export_proto (cas_coarray_alloc_chk); + void cas_coarray_free (gfc_array_void *, int); export_proto (cas_coarray_free); @@ -85,9 +88,9 @@ void cas_collsub_broadcast_scalar (void *restrict, size_t, int, int *, char *, size_t); export_proto (cas_collsub_broadcast_scalar); -void -cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank, - int alloc_type, int *status, char *errmsg, size_t errmsg_len) +static void +cas_coarray_alloc_work (gfc_array_void *desc, size_t elem_size, int corank, + int alloc_type) { int i, last_rank_index; int num_coarray_elems, num_elems; /* Excludes the last dimension, because it @@ -96,10 +99,6 @@ cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank, size_t last_lbound; size_t size_in_bytes; - ensure_initialization (); /* This function might be the first one to be - called, if it is called in a constructor. */ - - STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len); if (alloc_type == GFC_NCA_LOCK_COARRAY) elem_size = sizeof (pthread_mutex_t); else if (alloc_type == GFC_NCA_EVENT_COARRAY) @@ -152,8 +151,53 @@ cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank, else if (alloc_type == GFC_NCA_EVENT_COARRAY) (void)0; // TODO else - desc->base_addr - = get_memory_by_id (&local->ai, size_in_bytes, (intptr_t)desc); + desc->base_addr = + get_memory_by_id (&local->ai, size_in_bytes, (intptr_t) desc); +} + +void +cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank, + int alloc_type) +{ + ensure_initialization (); /* This function might be the first one to be + called, if it is called in a constructor. */ + cas_coarray_alloc_work (desc, elem_size, corank, alloc_type); +} + +void +cas_coarray_alloc_chk (gfc_array_void *desc, size_t elem_size, int corank, + int alloc_type, int *status, char *errmsg, + size_t errmsg_len) +{ + STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len); + if (unlikely(GFC_DESCRIPTOR_DATA (desc) != NULL)) + { + if (status == NULL) + { + fprintf (stderr,"Image %d: Attempting to allocate already allocated " + "variable at %p %p\n", this_image.image_num + 1, (void *) desc, + desc->base_addr); + exit (1); + } + else + { + *status = LIBERROR_ALLOCATION; + if (errmsg) + { + size_t errmsg_written_bytes; + errmsg_written_bytes + = snprintf (errmsg, errmsg_len, "Attempting to allocate already " + "allocated variable"); + if (errmsg_written_bytes > errmsg_len - 1) + errmsg_written_bytes = errmsg_len - 1; + memset (errmsg + errmsg_written_bytes, ' ', + errmsg_len - errmsg_written_bytes); + } + return; + } + } + cas_coarray_alloc_work (desc, elem_size, corank, alloc_type); + sync_all (&local->si); } void