From patchwork Mon Oct 14 15:08:16 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1997027 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=orange.fr header.i=@orange.fr header.a=rsa-sha256 header.s=t20230301 header.b=MRSMIaaV; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4XS13Z1WLnz1xsc for ; Tue, 15 Oct 2024 02:14:18 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5FD59385AE63 for ; Mon, 14 Oct 2024 15:14:16 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (out-67.smtpout.orange.fr [193.252.22.67]) by sourceware.org (Postfix) with ESMTPS id 90D0B385AE42; Mon, 14 Oct 2024 15:08:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 90D0B385AE42 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=orange.fr Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=orange.fr ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 90D0B385AE42 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.22.67 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728918532; cv=none; b=gxQsz/GRFqtcR7ExmDioanYTgsewQpAVp3XuF5ACxYLHKM0ZimfwLyIpNRmDkjAeZKO/vqKVPTcGAh8WvK9TH+zvYMPDaAvyjFWbxGkWh48cfjJvvmC0RYgLpUfq0Uybz/nSeFPTfAUoC3TDgVcN0KCOZcIkweFf1NP5/IntDII= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728918532; c=relaxed/simple; bh=QLZbKK72nPU8u1CbPeC5BhFzS7zLidYxzxLYjnr6nGU=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=tVjqWyt4gmK490rplMUyvJizpN1TBBNSys+/UfGtDRkopOxEEUv/1jSTmZ7A3J+sn1H01LKX+5f8BAqfAY2ilubIYPLoBWUeyI/AStnullvsmvMqLsY3Dfk0x45ynZyUS7WTJzenqenjlYmwYn5nkpUDk50bm7un0e6+D0+5UBs= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id 0MgBtHlyUIPG80MgQtVhMU; Mon, 14 Oct 2024 17:08:30 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1728918510; bh=nJnBeS0uPhipJDoVfeOqIvDZg7g43SSqU7zAaf0q9p8=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=MRSMIaaV4VnbeCVfsjl5OT2Pn46or8Pk9YD/MPQfG5xi+BtjKiL/bcyRAydi3zL/b C7g0oUZDMsyRZ6YPU36MHXKBm+KKlt3pyLKP85ezOQB4OwuR2muBJFy4W1q3CVDabK I8e+lZpk/lKApWQabGBdj/BeG++YchlxEHsgXyBLlss6YsJJyLEaM9XvcAgTEKM2rX 35z7G7nhhLIaMrEf2yvpn8Je0JjREflfyUQ1tibDKPGCHfaSrXz9QJzIi5haUhxkQu Im4xZYToDEHRal96b0s1yg6Rz379OmT/x+MRsiTiv/CtZsHuyKM0IvycJOJglhc+5T OxkL2VtTNAfGQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Mon, 14 Oct 2024 17:08:30 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH 7/7] fortran: Evaluate once BACK argument of MINLOC/MAXLOC with DIM [PR90608] Date: Mon, 14 Oct 2024 17:08:16 +0200 Message-ID: <20241014150816.315478-8-morin-mikael@orange.fr> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20241014150816.315478-1-morin-mikael@orange.fr> References: <20241014150816.315478-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Mikael Morin Bootstrapped and regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Evaluate the BACK argument of MINLOC/MAXLOC once before the scalarization loops in the case where the DIM argument is present. This is a follow-up to r15-1994-ga55d24b3cf7f4d07492bb8e6fcee557175b47ea3 which added knowledge of BACK to the scalarizer, to r15-2701-ga10436a8404ad2f0cc5aa4d6a0cc850abe5ef49e which removed it to handle it out of scalarization instead, and to more immediate previous patches that added inlining support for MINLOC/MAXLOC with DIM. The inlining support for MINLOC/MAXLOC with DIM introduced nested loops, which made the evaluation of BACK (removed from the scalarizer knowledge by the forementionned commit) wrapped in a loop, so possibly executed more than once. This change adds BACK to the scalarization chain if MINLOC/MAXLOC will use nested loops, so that it is evaluated by the scalarizer only once before the outermost loop in that case. PR fortran/90608 gcc/fortran/ChangeLog: * trans-intrinsic.cc (walk_inline_intrinsic_minmaxloc): Add a scalar element for BACK as first item of the chain if BACK is present and there will be nested loops. (gfc_conv_intrinsic_minmaxloc): Evaluate BACK using an inherited scalarization chain if there is a nested loop. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_8.f90: New test. * gfortran.dg/minloc_9.f90: New test. --- gcc/fortran/trans-intrinsic.cc | 21 +- gcc/testsuite/gfortran.dg/maxloc_8.f90 | 349 +++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/minloc_9.f90 | 349 +++++++++++++++++++++++++ 3 files changed, 717 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/maxloc_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_9.f90 diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index e1a5fdef26c..4cd4f4b1977 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5594,7 +5594,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) && maskexpr->symtree->n.sym->attr.optional; backexpr = back_arg->expr; - gfc_init_se (&backse, NULL); + gfc_init_se (&backse, nested_loop ? se : nullptr); if (backexpr == nullptr) back = logical_false_node; else if (maybe_absent_optional_variable (backexpr)) @@ -11885,10 +11885,13 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED) gfc_actual_arglist *array_arg = expr->value.function.actual; gfc_actual_arglist *dim_arg = array_arg->next; gfc_actual_arglist *mask_arg = dim_arg->next; + gfc_actual_arglist *kind_arg = mask_arg->next; + gfc_actual_arglist *back_arg = kind_arg->next; gfc_expr *array = array_arg->expr; gfc_expr *dim = dim_arg->expr; gfc_expr *mask = mask_arg->expr; + gfc_expr *back = back_arg->expr; if (dim == nullptr) return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); @@ -11916,7 +11919,21 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED) chain, "hiding" that dimension from the outer scalarization. */ int dim_val = mpz_get_si (dim->value.integer); gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1); - tail->next = ss; + + if (back && array->rank > 1) + { + /* If there are nested scalarization loops, include BACK in the + scalarization chains to avoid evaluating it multiple times in a loop. + Otherwise, prefer to handle it outside of scalarization. */ + gfc_ss *back_ss = gfc_get_scalar_ss (ss, back); + back_ss->info->type = GFC_SS_REFERENCE; + if (maybe_absent_optional_variable (back)) + back_ss->info->can_be_null_ref = true; + + tail->next = back_ss; + } + else + tail->next = ss; if (scalar_mask) { diff --git a/gcc/testsuite/gfortran.dg/maxloc_8.f90 b/gcc/testsuite/gfortran.dg/maxloc_8.f90 new file mode 100644 index 00000000000..20f63a84bbe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_8.f90 @@ -0,0 +1,349 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check that the evaluation of MAXLOC's BACK argument is made only once +! before the scalarization loops, when the DIM argument is present. + +program p + implicit none + integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, & + 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /) + logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., & + .true. , .false., .true. , .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .true. , & + .true. , .false., .false., .true. , & + .true. , .true. , .true. , .false., & + .false., .false., .true. , .false., & + .true. , .false., .true. , .true. , & + .true. , .false., .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .true. , & + .false., .true. , .false., .true. /) + integer :: calls_count = 0 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_scalar_mask + call check_int_const_shape_rank_3_optional_mask_present + call check_int_const_shape_rank_3_optional_mask_absent + call check_int_const_shape_rank_3_array_mask + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_scalar_mask + call check_int_alloc_rank_3_array_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_scalar_mask + call check_real_const_shape_rank_3_optional_mask_present + call check_real_const_shape_rank_3_optional_mask_absent + call check_real_const_shape_rank_3_array_mask + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_scalar_mask + call check_real_alloc_rank_3_array_mask + call check_real_alloc_empty_4 +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape_rank_3() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 12 + r = maxloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 15 + r = maxloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 18 + end subroutine + subroutine check_int_const_shape_rank_3_scalar_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 22 + r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 25 + r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 28 + end subroutine + subroutine call_maxloc_int(r, a, m, b) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + logical, optional :: b + integer, allocatable :: r(:,:) + r = maxloc(a, dim = 2, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + call call_maxloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) error stop 45 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + call call_maxloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) error stop 55 + end subroutine + subroutine check_int_const_shape_rank_3_array_mask() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 62 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 65 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 68 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 72 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 74 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 76 + r = maxloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 78 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 82 + r = maxloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 85 + r = maxloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 88 + end subroutine + subroutine check_int_alloc_rank_3_scalar_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 92 + r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 95 + r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 98 + end subroutine + subroutine check_int_alloc_rank_3_array_mask() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 102 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 105 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 108 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 112 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 114 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 116 + r = maxloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 118 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 122 + r = maxloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 125 + r = maxloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 128 + end subroutine + subroutine check_real_const_shape_rank_3_scalar_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 132 + r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 135 + r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 138 + end subroutine + subroutine check_real_const_shape_rank_3_array_mask() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 142 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 145 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 148 + end subroutine + subroutine call_maxloc_real(r, a, m, b) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + logical, optional :: b + integer, allocatable :: r(:,:) + r = maxloc(a, dim = 2, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + call call_maxloc_real(r, a, m, get_scalar_false()) + if (calls_count /= 1) error stop 155 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + call call_maxloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) error stop 165 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 172 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 174 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 176 + r = maxloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 178 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 182 + r = maxloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 185 + r = maxloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 188 + end subroutine + subroutine check_real_alloc_rank_3_scalar_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 192 + r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 195 + r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 198 + end subroutine + subroutine check_real_alloc_rank_3_array_mask() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 202 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 205 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 208 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical :: /), shape(m)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 212 + r = maxloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 214 + r = maxloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 216 + r = maxloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 218 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_9.f90 b/gcc/testsuite/gfortran.dg/minloc_9.f90 new file mode 100644 index 00000000000..335b48a5909 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_9.f90 @@ -0,0 +1,349 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check that the evaluation of MINLOC's BACK argument is made only once +! before the scalarization loops, when the DIM argument is present. + +program p + implicit none + integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, & + 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /) + logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., & + .true. , .false., .true. , .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .true. , & + .true. , .false., .false., .true. , & + .true. , .true. , .true. , .false., & + .false., .false., .true. , .false., & + .true. , .false., .true. , .true. , & + .true. , .false., .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .true. , & + .false., .true. , .false., .true. /) + integer :: calls_count = 0 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_scalar_mask + call check_int_const_shape_rank_3_optional_mask_present + call check_int_const_shape_rank_3_optional_mask_absent + call check_int_const_shape_rank_3_array_mask + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_scalar_mask + call check_int_alloc_rank_3_array_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_scalar_mask + call check_real_const_shape_rank_3_optional_mask_present + call check_real_const_shape_rank_3_optional_mask_absent + call check_real_const_shape_rank_3_array_mask + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_scalar_mask + call check_real_alloc_rank_3_array_mask + call check_real_alloc_empty_4 +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape_rank_3() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 12 + r = minloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 15 + r = minloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 18 + end subroutine + subroutine check_int_const_shape_rank_3_scalar_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 22 + r = minloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 25 + r = minloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 28 + end subroutine + subroutine call_minloc_int(r, a, m, b) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + logical, optional :: b + integer, allocatable :: r(:,:) + r = minloc(a, dim = 2, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + call call_minloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) error stop 45 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + calls_count = 0 + call call_minloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) error stop 55 + end subroutine + subroutine check_int_const_shape_rank_3_array_mask() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 62 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 65 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 68 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 72 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 74 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 76 + r = minloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 78 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 82 + r = minloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 85 + r = minloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 88 + end subroutine + subroutine check_int_alloc_rank_3_scalar_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 92 + r = minloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 95 + r = minloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 98 + end subroutine + subroutine check_int_alloc_rank_3_array_mask() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 102 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 105 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 108 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 112 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 114 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 116 + r = minloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 118 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 122 + r = minloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 125 + r = minloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 128 + end subroutine + subroutine check_real_const_shape_rank_3_scalar_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 132 + r = minloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 135 + r = minloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 138 + end subroutine + subroutine check_real_const_shape_rank_3_array_mask() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 142 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 145 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 148 + end subroutine + subroutine call_minloc_real(r, a, m, b) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + logical, optional :: b + integer, allocatable :: r(:,:) + r = minloc(a, dim = 2, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + calls_count = 0 + call call_minloc_real(r, a, m, get_scalar_false()) + if (calls_count /= 1) error stop 155 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + call call_minloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) error stop 165 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 172 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 174 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 176 + r = minloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 178 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) error stop 182 + r = minloc(a, dim = 2, back = get_scalar_false()) + if (calls_count /= 2) error stop 185 + r = minloc(a, dim = 3, back = get_scalar_false()) + if (calls_count /= 3) error stop 188 + end subroutine + subroutine check_real_alloc_rank_3_scalar_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) error stop 192 + r = minloc(a, dim = 2, mask = .true., back = get_scalar_false()) + if (calls_count /= 2) error stop 195 + r = minloc(a, dim = 3, mask = .true., back = get_scalar_false()) + if (calls_count /= 3) error stop 198 + end subroutine + subroutine check_real_alloc_rank_3_array_mask() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 202 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 205 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 208 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical :: /), shape(m)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) error stop 212 + r = minloc(a, dim = 2, mask = m, back = get_scalar_false()) + if (calls_count /= 2) error stop 214 + r = minloc(a, dim = 3, mask = m, back = get_scalar_false()) + if (calls_count /= 3) error stop 216 + r = minloc(a, dim = 4, mask = m, back = get_scalar_false()) + if (calls_count /= 4) error stop 218 + end subroutine +end program p