From patchwork Wed May 29 11:15:52 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1107088 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-501830-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=quarantine dis=none) header.from=netcologne.de Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="iYCms1VN"; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.b="JEyVDsbJ"; dkim-atps=neutral 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 45DSpR5rZnz9sB8 for ; Wed, 29 May 2019 21:16:38 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=prWU/5IZHK2c5zU38BPkPamUBZTO7hRJoBb0y68gqtMJTnNfMB tDAlDMZnokn1Nm7mxBDug5J7Jw9ZxrduW5Jx7LUyC3brf1gJxVGlaIzDKuSvEjJ2 LyJRYwgSgm1Yb91xAIk/3XqYPNr+Ssxd6ZfnQchNDZ8RVS0MSFPCI/Z0k= 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:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=IM/3Rg4WCzCTN0IUpQMVkKkBzOo=; b=iYCms1VN152H8HHPE0PV 1XkFRbPEQybmdct6Es1ljXQ9Jhj4bxEIo+c7u2gIS+JyuRPuJsjlFQA03gTkpa1d jSt2lipQOBBCxyj25JkehJqbHJ6JD07sxtLrBed9vMNIz6A1HW/BPiQmy55xh2LK ZF4FYTrdtnHsvFBKH9150nU= Received: (qmail 121235 invoked by alias); 29 May 2019 11:16:15 -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 121144 invoked by uid 89); 29 May 2019 11:16:14 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.8 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy=Toon, toon, unpacking, 271629 X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 29 May 2019 11:16:10 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 22D5E1238E; Wed, 29 May 2019 13:16:03 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1559128563; bh=qIlbOtdNM22+HsCS3k/7+eF+mxPc+xZfCrvtcD1EcOg=; h=To:From:Subject:Message-ID:Date:From; b=JEyVDsbJ/vZggZsObILySHqZHoQq7Lo2xUDd1Qfa1xOZA9Ym2oGK9+bUtnyZ0RtXf xYZOXHaTn/PccLu09qMPlllvb5Wv+mWqVHfNAKj8XE10wliDpA2VBqVHuWPHMyYl+A WXYahAp34ZHDDjNrO7fzx7on5XrhnNvWGloah54rnX3B0Vi4fswxkCtbRU9pHJsI3m z5HwW/WZjPKwNLdt7LkA81GcjbZ53ZYF/zsQ1YimrRNptxIRL/X2Xyg34hd7bzduYJ bG4FlHtEP530h1g92TocUdIdkJPjv8dcWc2F3F2h/oLJiq6zObIZ39AhLYqXks1Rhi i4rujU/hhHx3A== Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id 15C3B11E6F; Wed, 29 May 2019 13:16:03 +0200 (CEST) Received: from [2001:4dd7:1a25:0:7285:c2ff:fe6c:992d] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.6.0) (envelope-from ) id 5cee69f3-3975-7f0000012729-7f000001eb86-1 for ; Wed, 29 May 2019 13:16:03 +0200 Received: from [IPv6:2001:4dd7:1a25:0:7285:c2ff:fe6c:992d] (2001-4dd7-1a25-0-7285-c2ff-fe6c-992d.ipv6dyn.netcologne.de [IPv6:2001:4dd7:1a25:0:7285:c2ff:fe6c:992d]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA; Wed, 29 May 2019 13:15:57 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Fix wrong-code regression with netcdf and SPEC due to argument repacking Message-ID: Date: Wed, 29 May 2019 13:15:52 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.6.1 MIME-Version: 1.0 Hello world, the attached patch fixes the wrong-code regression due to the inline argument repacking patch, r271377. What had gone wrong? gfortran used to pack and unpack arrays unconditionally passed to old-style assumed size or . For code like module t2 implicit none contains subroutine foo(a) real, dimension(*) :: a end subroutine foo end module t2 module t1 use t2 implicit none contains subroutine bar(a) real, dimension(:) :: a call foo(a) end subroutine bar end module t1 program main use t1 call bar([1.0, 2.0]) end program main this meant that an (always contiguous) array constructor was passed down to an assumed shape array, which then passed it on to an assumed size, explicit shape or adjustable array. Packing was not problematic (apart from performance), but unpacking tried to write into the array constructor. So, this patch inserts a run-time check for contiguous arrays and does not do packing/unpacking in that case. Thanks to Toon and Martin for finding an open test case which actually failed, and for help with debugging. (Always repacking also likely impacted performance when it didn't lead to wrong code, we will have to see how performance is with this version). OK for trunk? Regards Thomas 2019-05-29 Thomas Koenig PR fortran/90539 * gfortran.h (gfc_has_dimen_vector_ref): Add prototype. * trans.h (gfc_conv_subref_array_arg): Add argument check_contiguous. (gfc_conv_is_contiguous_expr): Add prototype. * frontend-passes.c (has_dimen_vector_ref): Remove prototype, rename to (gfc_has_dimen_vector_ref): New function name. (matmul_temp_args): Use gfc_has_dimen_vector_ref. (inline_matmul_assign): Likewise. * trans-array.c (gfc_conv_array_parameter): Also check for absence of a vector subscript before calling gfc_conv_subref_array_arg. Pass additional argument to gfc_conv_subref_array_arg. * trans-expr.c (gfc_conv_subref_array_arg): Add argument check_contiguous. If that is true, check if the argument is contiguous and do not repack in that case. * trans-intrinsic.c (gfc_conv_intrinsic_is_contiguous): Split away most of the work into, and call (gfc_conv_intrinsic_is_coniguous_expr): New function. 2019-05-29 Thomas Koenig PR fortran/90539 * gfortran.dg/internal_pack_21.f90: Adjust scan patterns. * gfortran.dg/internal_pack_22.f90: New test. * gfortran.dg/internal_pack_23.f90: New test. Index: fortran/gfortran.h =================================================================== --- fortran/gfortran.h (Revision 271629) +++ fortran/gfortran.h (Arbeitskopie) @@ -3532,6 +3532,7 @@ typedef int (*walk_expr_fn_t) (gfc_expr **, int *, int gfc_dummy_code_callback (gfc_code **, int *, void *); int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); +bool gfc_has_dimen_vector_ref (gfc_expr *e); /* simplify.c */ Index: fortran/trans.h =================================================================== --- fortran/trans.h (Revision 271629) +++ fortran/trans.h (Arbeitskopie) @@ -535,8 +535,11 @@ int gfc_conv_procedure_call (gfc_se *, gfc_symbol void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool, const gfc_symbol *fsym = NULL, const char *proc_name = NULL, - gfc_symbol *sym = NULL); + gfc_symbol *sym = NULL, + bool check_contiguous = false); +void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *); + /* Generate code for a scalar assignment. */ tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool, bool c = false); Index: fortran/frontend-passes.c =================================================================== --- fortran/frontend-passes.c (Revision 271629) +++ fortran/frontend-passes.c (Arbeitskopie) @@ -54,7 +54,6 @@ static gfc_code * create_do_loop (gfc_expr *, gfc_ static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, bool *); static int call_external_blas (gfc_code **, int *, void *); -static bool has_dimen_vector_ref (gfc_expr *); static int matmul_temp_args (gfc_code **, int *,void *data); static int index_interchange (gfc_code **, int*, void *); @@ -2868,7 +2867,7 @@ matmul_temp_args (gfc_code **c, int *walk_subtrees { if (matrix_a->expr_type == EXPR_VARIABLE && (gfc_check_dependency (matrix_a, expr1, true) - || has_dimen_vector_ref (matrix_a))) + || gfc_has_dimen_vector_ref (matrix_a))) a_tmp = true; } else @@ -2881,7 +2880,7 @@ matmul_temp_args (gfc_code **c, int *walk_subtrees { if (matrix_b->expr_type == EXPR_VARIABLE && (gfc_check_dependency (matrix_b, expr1, true) - || has_dimen_vector_ref (matrix_b))) + || gfc_has_dimen_vector_ref (matrix_b))) b_tmp = true; } else @@ -3681,8 +3680,8 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, /* Helper function to check for a dimen vector as subscript. */ -static bool -has_dimen_vector_ref (gfc_expr *e) +bool +gfc_has_dimen_vector_ref (gfc_expr *e) { gfc_array_ref *ar; int i; @@ -3838,8 +3837,8 @@ inline_matmul_assign (gfc_code **c, int *walk_subt if (matrix_b == NULL) return 0; - if (has_dimen_vector_ref (expr1) || has_dimen_vector_ref (matrix_a) - || has_dimen_vector_ref (matrix_b)) + if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a) + || gfc_has_dimen_vector_ref (matrix_b)) return 0; /* We do not handle data dependencies yet. */ Index: fortran/trans-array.c =================================================================== --- fortran/trans-array.c (Revision 271629) +++ fortran/trans-array.c (Arbeitskopie) @@ -8139,12 +8139,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * optimizers. */ if (g77 && optimize && !optimize_size && expr->expr_type == EXPR_VARIABLE - && !is_pointer (expr) && (fsym == NULL - || fsym->ts.type != BT_ASSUMED)) + && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr) + && (fsym == NULL || fsym->ts.type != BT_ASSUMED)) { gfc_conv_subref_array_arg (se, expr, g77, fsym ? fsym->attr.intent : INTENT_INOUT, - false, fsym, proc_name, sym); + false, fsym, proc_name, sym, true); return; } Index: fortran/trans-expr.c =================================================================== --- fortran/trans-expr.c (Revision 271629) +++ fortran/trans-expr.c (Arbeitskopie) @@ -4579,7 +4579,7 @@ void gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, sym_intent intent, bool formal_ptr, const gfc_symbol *fsym, const char *proc_name, - gfc_symbol *sym) + gfc_symbol *sym, bool check_contiguous) { gfc_se lse; gfc_se rse; @@ -4602,7 +4602,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional; - if (pass_optional) + if (pass_optional || check_contiguous) { gfc_init_se (&work_se, NULL); parmse = &work_se; @@ -4880,50 +4880,136 @@ class_array_fcn: else parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); - if (pass_optional) + /* Basically make this into + + if (present) + { + if (contiguous) + { + pointer = a; + } + else + { + parmse->pre(); + pointer = parmse->expr; + } + } + else + pointer = NULL; + + foo (pointer); + if (present && !contiguous) + se->post(); + + */ + + if (pass_optional || check_contiguous) { - tree present; tree type; stmtblock_t else_block; tree pre_stmts, post_stmts; tree pointer; tree else_stmt; + tree present_var = NULL_TREE; + tree cont_var = NULL_TREE; + tree post_cond; - /* Make this into + type = TREE_TYPE (parmse->expr); + pointer = gfc_create_var (type, "arg_ptr"); - if (present (a)) - { - parmse->pre; - optional = parse->expr; - } - else - optional = NULL; - call foo (optional); - if (present (a)) - parmse->post; + if (check_contiguous) + { + gfc_se cont_se, array_se; + stmtblock_t if_block, else_block; + tree if_stmt, else_stmt; - */ + cont_var = gfc_create_var (boolean_type_node, "contiguous"); - type = TREE_TYPE (parmse->expr); - pointer = gfc_create_var (type, "optional"); - tmp = gfc_conv_expr_present (sym); - present = gfc_evaluate_now (tmp, &se->pre); - gfc_add_modify (&parmse->pre, pointer, parmse->expr); - pre_stmts = gfc_finish_block (&parmse->pre); + /* cont_var = is_contiguous (expr); . */ + gfc_init_se (&cont_se, parmse); + gfc_conv_is_contiguous_expr (&cont_se, expr); + gfc_add_block_to_block (&se->pre, &(&cont_se)->pre); + gfc_add_modify (&se->pre, cont_var, cont_se.expr); + gfc_add_block_to_block (&se->pre, &(&cont_se)->post); - gfc_init_block (&else_block); - gfc_add_modify (&else_block, pointer, build_int_cst (type, 0)); - else_stmt = gfc_finish_block (&else_block); + /* arrayse->expr = descriptor of a. */ + gfc_init_se (&array_se, se); + gfc_conv_expr_descriptor (&array_se, expr); + gfc_add_block_to_block (&se->pre, &(&array_se)->pre); + gfc_add_block_to_block (&se->pre, &(&array_se)->post); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present, - pre_stmts, else_stmt); - gfc_add_expr_to_block (&se->pre, tmp); + /* if_stmt = { pointer = &a[0]; } . */ + gfc_init_block (&if_block); + tmp = gfc_conv_array_data (array_se.expr); + tmp = fold_convert (type, tmp); + gfc_add_modify (&if_block, pointer, tmp); + if_stmt = gfc_finish_block (&if_block); + /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */ + gfc_init_block (&else_block); + gfc_add_block_to_block (&else_block, &parmse->pre); + gfc_add_modify (&else_block, pointer, parmse->expr); + else_stmt = gfc_finish_block (&else_block); + + /* And put the above into an if statement. */ + pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cont_var, if_stmt, else_stmt); + } + else + { + /* pointer = pramse->expr; . */ + gfc_add_modify (&parmse->pre, pointer, parmse->expr); + pre_stmts = gfc_finish_block (&parmse->pre); + } + + if (pass_optional) + { + present_var = gfc_create_var (boolean_type_node, "present"); + + /* present_var = present(sym); . */ + tmp = gfc_conv_expr_present (sym); + tmp = fold_convert (boolean_type_node, tmp); + gfc_add_modify (&se->pre, present_var, tmp); + + /* else_stmt = { pointer = NULL; } . */ + gfc_init_block (&else_block); + gfc_add_modify (&else_block, pointer, build_int_cst (type, 0)); + else_stmt = gfc_finish_block (&else_block); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present_var, + pre_stmts, else_stmt); + gfc_add_expr_to_block (&se->pre, tmp); + + + } + else + gfc_add_expr_to_block (&se->pre, pre_stmts); + post_stmts = gfc_finish_block (&parmse->post); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present, + + /* Put together the post stuff, plus the optional + deallocation. */ + if (check_contiguous) + { + /* !cont_var. */ + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cont_var, + build_zero_cst (boolean_type_node)); + if (pass_optional) + post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present_var, tmp); + else + post_cond = tmp; + } + else + { + gcc_assert (pass_optional); + post_cond = present_var; + } + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond, post_stmts, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); - se->expr = pointer; } Index: fortran/trans-intrinsic.c =================================================================== --- fortran/trans-intrinsic.c (Revision 271629) +++ fortran/trans-intrinsic.c (Arbeitskopie) @@ -2832,6 +2832,17 @@ static void gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr) { gfc_expr *arg; + arg = expr->value.function.actual->expr; + gfc_conv_is_contiguous_expr (se, arg); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + +/* This function does the work for gfc_conv_intrinsic_is_contiguous, + plus it can be called directly. */ + +void +gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) +{ gfc_ss *ss; gfc_se argse; tree desc, tmp, stride, extent, cond; @@ -2839,8 +2850,6 @@ gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc tree fncall0; gfc_array_spec *as; - arg = expr->value.function.actual->expr; - if (arg->ts.type == BT_CLASS) gfc_add_class_array_ref (arg); @@ -2878,7 +2887,7 @@ gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, stride, build_int_cst (TREE_TYPE (stride), 1)); - for (i = 0; i < expr->value.function.actual->expr->rank - 1; i++) + for (i = 0; i < arg->rank - 1; i++) { tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); @@ -2896,7 +2905,7 @@ gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, cond, tmp); } - se->expr = convert (gfc_typenode_for_spec (&expr->ts), cond); + se->expr = cond; } } Index: testsuite/gfortran.dg/internal_pack_21.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_21.f90 (Revision 271629) +++ testsuite/gfortran.dg/internal_pack_21.f90 (Arbeitskopie) @@ -20,5 +20,5 @@ END MODULE M1 USE M1 CALL S2() END -! { dg-final { scan-tree-dump-times "optional" 4 "original" } } +! { dg-final { scan-tree-dump-times "arg_ptr" 5 "original" } } ! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } }