From patchwork Fri Aug 16 10:22:18 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973200 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=DSxLA5vf; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; 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 [8.43.85.97]) (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 4WldW72dmpz1yYl for ; Fri, 16 Aug 2024 20:28:35 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8380A385DDCE for ; Fri, 16 Aug 2024 10:28:33 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-65.smtpout.orange.fr [80.12.242.65]) by sourceware.org (Postfix) with ESMTPS id 46675385DC32; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 46675385DC32 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 46675385DC32 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.65 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; cv=none; b=dYEbsNKAHjuQTLCAW7u+JFA0sRTU+UEGHVBQfJFBGivO9CpQcqVRa0gk3bO1wckqIjYdZ5I2SgSow1VGa6aeQQDePVRH0KVjR//FNg+GbuVcJPI70i8D6yF+zhCAAJJXHwRGlhANRrv2mmnUsAuufnSEi5P/UdbE4SazVpIk16E= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; c=relaxed/simple; bh=2GfZlx64b3AZxt0rnBwBaN/vE6XR6ky97cPfQKfybjc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=FLch9Rl7HLJDHj9SqvQVEQWNgmNPIBGv3CNQhM/v4Lu9J38ELeQSfSKXJqx6fkn6aWwpkkepVitNKFOx3eErvPTGqCWdf2RPXyuBKsUx3tF7NPWrjXy0DLeuKBJq9C8LL6UD9NB7GLLDI2FZRlx2RQ+wv1UjblxnxK0iu2hBFvI= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ls0CgC; Fri, 16 Aug 2024 12:22:33 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803753; bh=sWx+i5VKLHsCQpyhgZQXBk2sycHTJH8Ar1iKkug0Fks=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=DSxLA5vfivZ+YjSQssS49f5fzV9xCXVEKfHKJj/LmKlzX5dIQhbHol1scbrTuzbxj x4FgXuivpC/ZrDoofx1585N9bGE9JqI93rN4mEFo1EyLwjaTsBv/e4xdjO1kxSxDVO te62fIuImPRTU/H3pURZLNb9D6GJKbeAJZrROfzTd55HuxIkAzxVxc56ry3F5XoTB8 c8bvcyu3KIYp5Eq9ATCtX00S/+1mtNSDPJzD9RxXyw4ZrghIefhB1+78iVE4mItBom 6Wzhl4FpTHbbjtjYtzm3zosT5h4mV8vjZ9rhaOcOj8aXM5ZFAruCz7E4laedH3FQKc xjDebyU+StX6A== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:33 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 01/10] fortran: Add tests covering inline MINLOC/MAXLOC without DIM [PR90608] Date: Fri, 16 Aug 2024 12:22:18 +0200 Message-ID: <20240816102227.189290-2-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_SHORT, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H5, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Compared to the previous version of the patch at https://gcc.gnu.org/pipermail/gcc-patches/2024-July/658916.html this uses the IEEE_ARITHMETIC module to generate NAN values in the tests. This change required to move the affected tests to a separate file in the ieee/ subdirectory, so that the compiler when run has the intrinsic module path correctly provided and can load the intrinsic module. Tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Add the tests covering the various cases for which we are about to implement inline expansion of MINLOC and MAXLOC. Those are cases where the DIM argument is not present. PR fortran/90608 gcc/testsuite/ChangeLog: * gfortran.dg/ieee/maxloc_nan_1.f90: New test. * gfortran.dg/ieee/minloc_nan_1.f90: New test. * gfortran.dg/maxloc_7.f90: New test. * gfortran.dg/maxloc_with_mask_1.f90: New test. * gfortran.dg/minloc_8.f90: New test. * gfortran.dg/minloc_with_mask_1.f90: New test. --- .../gfortran.dg/ieee/maxloc_nan_1.f90 | 44 +++ .../gfortran.dg/ieee/minloc_nan_1.f90 | 44 +++ gcc/testsuite/gfortran.dg/maxloc_7.f90 | 208 ++++++++++ .../gfortran.dg/maxloc_with_mask_1.f90 | 373 ++++++++++++++++++ gcc/testsuite/gfortran.dg/minloc_8.f90 | 208 ++++++++++ .../gfortran.dg/minloc_with_mask_1.f90 | 372 +++++++++++++++++ 6 files changed, 1249 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 diff --git a/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 new file mode 100644 index 00000000000..329b54e8e1f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when ARRAY is filled with NANs. + +program p + implicit none + call check_without_mask + call check_with_mask +contains + subroutine check_without_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + real :: nan + integer, allocatable :: m(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 32 + if (any(m /= (/ 1, 1, 1 /))) stop 35 + end subroutine + subroutine check_with_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + real :: nan + integer, allocatable :: r(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + allocate(m(3,3,3)) + m(:,:,:) = reshape((/ .false., .false., .true. , .true. , .false., & + .true. , .false., .false., .false., .true. , & + .true. , .false., .true. , .true. , .true. , & + .false., .false., .true. , .true. , .false., & + .false., .true. , .false., .false., .true. , & + .true. , .true. /), shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 62 + if (any(r /= (/ 3, 1, 1 /))) stop 65 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 new file mode 100644 index 00000000000..8f71b4c4398 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when ARRAY is filled with NANs. + +program p + implicit none + call check_without_mask + call check_with_mask +contains + subroutine check_without_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + real :: nan + integer, allocatable :: m(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 32 + if (any(m /= (/ 1, 1, 1 /))) stop 35 + end subroutine + subroutine check_with_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + real :: nan + integer, allocatable :: r(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + allocate(m(3,3,3)) + m(:,:,:) = reshape((/ .false., .false., .true. , .true. , .false., & + .true. , .false., .false., .false., .true. , & + .true. , .false., .true. , .true. , .true. , & + .false., .false., .true. , .true. , .false., & + .false., .true. , .false., .false., .true. , & + .true. , .true. /), shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 62 + if (any(r /= (/ 3, 1, 1 /))) stop 65 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_7.f90 b/gcc/testsuite/gfortran.dg/maxloc_7.f90 new file mode 100644 index 00000000000..0e57f0661c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_7.f90 @@ -0,0 +1,208 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when there is no optional argument. + +program p + implicit none + integer, parameter :: data5(*) = (/ 1, 7, 2, 7, 0 /) + integer, parameter :: data64(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, & + 4, 4, 1, 7, 3, 2, 1, 2, & + 5, 4, 6, 0, 9, 3, 5, 4, & + 4, 1, 7, 3, 2, 1, 2, 5, & + 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, & + 6, 0, 9, 3, 5, 4, 4, 1, & + 7, 3, 2, 1, 2, 5, 4, 6 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 + call check_int_lower_bounds + call check_real_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 61 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 62 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 131 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 132 + end subroutine + subroutine check_int_lower_bounds() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 141 + if (any(m /= (/ 2, 2, 1 /))) stop 142 + end subroutine + subroutine check_real_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 151 + if (any(m /= (/ 2, 2, 1 /))) stop 152 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = maxloc(a) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = maxloc(a) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = maxloc(a) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = maxloc(a) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = maxloc(a) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = maxloc(a) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = maxloc(a) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), maxloc(a)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), maxloc(a)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), maxloc(a)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), maxloc(a)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), maxloc(a)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), maxloc(a)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), maxloc(a)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), maxloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 b/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 new file mode 100644 index 00000000000..b8d5dda6761 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 @@ -0,0 +1,373 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when there is a mask argument. + +program p + implicit none + integer, parameter :: data10(*) = (/ 7, 4, 7, 6, 6, 4, 6, 3, 9, 8 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, & + 4, 4, 1, 7, 3, 2, 1, 2, & + 5, 4, 6, 0, 9, 3, 5, 4, & + 4, 1, 7, 3, 2, 1, 2, 5, & + 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, & + 6, 0, 9, 3, 5, 4, 4, 1, & + 7, 3, 2, 1, 2, 5, 4, 6 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_true_mask + call check_int_const_shape_rank_3_false_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_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_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_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask + call check_real_alloc_empty_4 + call check_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_maxloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_maxloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 121 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 122 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_maxloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_maxloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 241 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 242 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(3:6,-1:2,4), m(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 251 + if (any(r /= (/ 2, 3, 1 /))) stop 252 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = maxloc(a, mask=a>1) + print *, a(1,1,:) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = maxloc(a, mask=a>1) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = maxloc(a, mask=a>1) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = maxloc(a, mask=a>1) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = maxloc(a, mask=a>1) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = maxloc(a, mask=a>1) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = maxloc(a, mask=a>1) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), maxloc(a, mask=a>1)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), maxloc(a, mask=a>1)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), maxloc(a, mask=a>1)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), maxloc(a, mask=a>1)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), maxloc(a, mask=a>1)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), maxloc(a, mask=a>1)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), maxloc(a, mask=a>1)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), maxloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_8.f90 b/gcc/testsuite/gfortran.dg/minloc_8.f90 new file mode 100644 index 00000000000..da28df8f133 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_8.f90 @@ -0,0 +1,208 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when there is no optional argument. + +program p + implicit none + integer, parameter :: data5(*) = (/ 8, 2, 7, 2, 9 /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 + call check_int_lower_bounds + call check_real_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 61 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 62 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 131 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 132 + end subroutine + subroutine check_int_lower_bounds() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 141 + if (any(m /= (/ 2, 2, 1 /))) stop 142 + end subroutine + subroutine check_real_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 151 + if (any(m /= (/ 2, 2, 1 /))) stop 152 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = minloc(a) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = minloc(a) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = minloc(a) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = minloc(a) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = minloc(a) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = minloc(a) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = minloc(a) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), minloc(a)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), minloc(a)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), minloc(a)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), minloc(a)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), minloc(a)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), minloc(a)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), minloc(a)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), minloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 b/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 new file mode 100644 index 00000000000..8012652b2bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 @@ -0,0 +1,372 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when there is a mask argument. + +program p + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 3, 3, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_true_mask + call check_int_const_shape_rank_3_false_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_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_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_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask + call check_real_alloc_empty_4 + call check_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_minloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_minloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 121 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 122 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_minloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_minloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 241 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 242 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(3:6,-1:2,4), m(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 251 + if (any(r /= (/ 2, 3, 1 /))) stop 252 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = minloc(a, mask=a<8) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = minloc(a, mask=a<8) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = minloc(a, mask=a<8) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = minloc(a, mask=a<8) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = minloc(a, mask=a<8) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = minloc(a, mask=a<8) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = minloc(a, mask=a<8) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), minloc(a, mask=a<8)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), minloc(a, mask=a<8)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), minloc(a, mask=a<8)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), minloc(a, mask=a<8)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), minloc(a, mask=a<8)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), minloc(a, mask=a<8)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), minloc(a, mask=a<8)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), minloc(a, dim=1)) + end subroutine check_dependencies +end program p From patchwork Fri Aug 16 10:22:19 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973190 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=YeKfKWwj; 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 4WldNv52MDz20Bh for ; Fri, 16 Aug 2024 20:23:11 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 61623385DDED for ; Fri, 16 Aug 2024 10:23:09 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id 655BD385C6D3; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 655BD385C6D3 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 655BD385C6D3 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.14 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803756; cv=none; b=dn8RdVb5AcqhqRBxhtxACgcDXm7A6t8UI8KlDOepD0cdMHpRsaH1IGYRWB8lAaN1LyPaJDFUXiN/f3fbZR/7EcxPeVFUZycHv4pL3lsIYnXZqY2BbnsdCVbZ07SeaC4brqrhvp8QKDIvhwTEhQKhd1a+XukmZGfAJPdh/zor1K8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803756; c=relaxed/simple; bh=YrAMQZVZppy43/QDxZRsp++0Dvyq8QO790DqkFamEcw=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=PNM/pzmdTBwlMGHYYxIZsFIcxEQ9vQ1f8YpFHz6Fd+4ZfoqaRBgh2nXhPrKXt9t9d0nuribxXbF5/8Dl4lKyYQnqadv+WXJOQIrO/tFhq5oW04gb2OXXlU/Xz7lW65ws/CPflQxk2xRZfXdMJP9ZmeRgNdsS6tgdnZukyP4AWCs= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ls0CgI; Fri, 16 Aug 2024 12:22:33 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803753; bh=nrdRcgak3iZWyclO6XVVUmYNZfT9cUORTdnToHtvdhE=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=YeKfKWwjyNH/VD+xX267tVMIFX5g30S/8IXGQAByL4NQv5iagkK/iwhkgvcrH8Mnp orTyGzzbY+ugkZM5CWMGZPh2R2e+mkfzkQ470KFI9UZ8q4Zu2drZgFCl9Jzo+gqc6g jg2PSp2TrO54DDJZdiuvNNnGP8/PMOkbdi8oJxlBfa3X13mN7cNIcXuI1hPz7pI6kz opP4CJVieTqrmJFHCXp3WpG6u2p5w7eDjihKI0/HjE5X6RLpPFlMtKCoquqb+lNqEL yRXPVztD3+kMlg4Bu6KHaRmGcdqlP0fFKGnZcRlV/1E2BZFqwJMChigpKuornxq3t+ 4g7O4eN69NbWg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:33 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 02/10] fortran: Disable frontend passes for inlinable MINLOC/MAXLOC [PR90608] Date: Fri, 16 Aug 2024 12:22:19 +0200 Message-ID: <20240816102227.189290-3-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.0 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_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Disable rewriting of MINLOC/MAXLOC expressions for which inline code generation is supported. Update the gfc_inline_intrinsic_function_p predicate (already existing) for that, with the current state of MINLOC/MAXLOC inlining support, that is only the cases of a scalar result and non-CHARACTER argument for now. This change has no effect currently, as the MINLOC/MAXLOC front-end passes only change expressions of rank 1, but the inlining control predicate gfc_inline_intrinsic_function_p returns false for those. However, later changes will extend MINLOC/MAXLOC inline expansion support to array expressions and update the inlining control predicate, and this will become effective. PR fortran/90608 gcc/fortran/ChangeLog: * frontend-passes.cc (optimize_minmaxloc): Skip if we can generate inline code for the unmodified expression. * trans-intrinsic.cc (gfc_inline_intrinsic_function_p): Add MINLOC and MAXLOC cases. --- gcc/fortran/frontend-passes.cc | 3 ++- gcc/fortran/trans-intrinsic.cc | 23 +++++++++++++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 3c06018fdbb..8e4c6310ba8 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -2277,7 +2277,8 @@ optimize_minmaxloc (gfc_expr **e) || fn->value.function.actual == NULL || fn->value.function.actual->expr == NULL || fn->value.function.actual->expr->ts.type == BT_CHARACTER - || fn->value.function.actual->expr->rank != 1) + || fn->value.function.actual->expr->rank != 1 + || gfc_inline_intrinsic_function_p (fn)) return; *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 84a378ef310..2c8512060cc 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11652,6 +11652,29 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) case GFC_ISYM_TRANSPOSE: return true; + case GFC_ISYM_MINLOC: + case GFC_ISYM_MAXLOC: + { + /* Disable inline expansion if code size matters. */ + if (optimize_size) + return false; + + gfc_actual_arglist *array_arg = expr->value.function.actual; + gfc_actual_arglist *dim_arg = array_arg->next; + + gfc_expr *array = array_arg->expr; + gfc_expr *dim = dim_arg->expr; + + if (!(array->ts.type == BT_INTEGER + || array->ts.type == BT_REAL)) + return false; + + if (array->rank == 1 && dim != nullptr) + return true; + + return false; + } + default: return false; } From patchwork Fri Aug 16 10:22:20 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973199 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=tKKxZ6Un; 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 4WldTy3wb3z1yYl for ; Fri, 16 Aug 2024 20:27:34 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 65D12385DDEB for ; Fri, 16 Aug 2024 10:27:32 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (out-65.smtpout.orange.fr [193.252.22.65]) by sourceware.org (Postfix) with ESMTPS id ABAE6385DDC5; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org ABAE6385DDC5 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 ABAE6385DDC5 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.22.65 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803758; cv=none; b=kBxXBgoHpt78j5uvjurxLakqx070UiJlJLKOuj4RR9DAdOCcZRtit1ppxdliQBQg5my6WuhDzZ2tWBEl/OTXcR633iqf307ptwxotlvOAlos1qj8ZFKueQnsYNc7rFUtzb8lImSiDDNAHl77h0ZQBD2ACuUWD2nTJ1nEvy6bqAI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803758; c=relaxed/simple; bh=4lrbOpvnz8JeFzqhta9DbviKO0Zg8IoEHVzvObiOElk=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=XMWhod4otGoCV5hCT3+0oSsJRKB+2K/n033yhlaUqvz1+FEEkr8+OIGNVrCH0aWe6ypigEhZ5jT3M9/hEFVU8AOuxXKtHyUMTyWMHa66KDdA8iHn4d23liwPCGd5C0LpihT8TfRpVvlpR/MaS+ffTerBcXYk02ryBsO0nX7j040= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ls0CgJ; Fri, 16 Aug 2024 12:22:33 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803753; bh=ntzYmpXfc8qzka0D173tPv6cH7pCxzgEj6VdDNSPN7A=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=tKKxZ6UnWbT5BPJMA4DzOXMBHpn7l3o85aS/eYN8gv9BYO8ThMH7Iu7taOfCaZY7T GCnlle1u2YtARBrJ+oCg5Q2HypT23PkwhoxnmQihubWck0OxPRbj9xlnLP3SRlNEoQ r7090359t+M6Hxc0jE3gdk8gBgEyBI2dWbzEX/nQpU2lJNFvGLQGGlbmy+0m4av/u2 l/BDiTSWo3K5dqU1VY9tslbqz860eRfEIWRJC4NLWcVxH3yo59bX0rBPk+FIWGbutj 7jbiymiBZhPqSYzP/3ZIh8/RwK/wQWxS3WigsC6ukxkns7J+EL/4TKO2r+2AaOGKbW 95vScS/J78lNw== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:33 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 03/10] fortran: Inline MINLOC/MAXLOC with no DIM and ARRAY of rank 1 [PR90608] Date: Fri, 16 Aug 2024 12:22:20 +0200 Message-ID: <20240816102227.189290-4-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-10.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Enable inline code generation for the MINLOC and MAXLOC intrinsic, if the DIM argument is not present and ARRAY has rank 1. This case is similar to the case where the result is scalar (DIM present and rank 1 ARRAY), which already supports inline expansion of the intrinsic. Both cases return the same value, with the difference that the result is an array of size 1 if DIM is absent, whereas it's a scalar if DIM is present. So all there is to do for the new case to work is hook the inline expansion with the scalarizer. PR fortran/90608 gcc/fortran/ChangeLog: * trans-array.cc (gfc_conv_ss_startstride): Set the scalarization rank based on the MINLOC/MAXLOC rank if needed. Call the inline code generation and setup the scalarizer array descriptor info in the MINLOC and MAXLOC cases. * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Return the result array element if the scalarizer is setup and we are inside the loops. Restrict library function call dispatch to the case where inline expansion is not supported. Declare an array result if the expression isn't scalar. Initialize the array result single element and return the result variable if the expression isn't scalar. (walk_inline_intrinsic_minmaxloc): New function. (walk_inline_intrinsic_function): Add MINLOC and MAXLOC cases, dispatching to walk_inline_intrinsic_minmaxloc. (gfc_add_intrinsic_ss_code): Add MINLOC and MAXLOC cases. (gfc_inline_intrinsic_function_p): Return true if ARRAY has rank 1, regardless of DIM. --- gcc/fortran/trans-array.cc | 25 ++++ gcc/fortran/trans-intrinsic.cc | 224 +++++++++++++++++++++++---------- 2 files changed, 181 insertions(+), 68 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 9fb0b2b398d..46e2152d0f0 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -4851,6 +4851,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_UBOUND: case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MINLOC: case GFC_ISYM_SHAPE: case GFC_ISYM_THIS_IMAGE: loop->dimen = ss->dimen; @@ -4900,6 +4902,29 @@ done: case GFC_SS_INTRINSIC: switch (expr->value.function.isym->id) { + case GFC_ISYM_MINLOC: + case GFC_ISYM_MAXLOC: + { + gfc_se se; + gfc_init_se (&se, nullptr); + se.loop = loop; + se.ss = ss; + gfc_conv_intrinsic_function (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + + info->descriptor = se.expr; + + info->data = gfc_conv_array_data (info->descriptor); + info->data = gfc_evaluate_now (info->data, &outer_loop->pre); + + info->offset = gfc_index_zero_node; + info->start[0] = gfc_index_zero_node; + info->end[0] = gfc_index_zero_node; + info->stride[0] = gfc_index_one_node; + continue; + } + /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 2c8512060cc..9fcb57a9cc4 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5273,66 +5273,95 @@ strip_kind_from_actual (gfc_actual_arglist * actual) we need to handle. For performance reasons we sometimes create two loops instead of one, where the second one is much simpler. Examples for minloc intrinsic: - 1) Result is an array, a call is generated - 2) Array mask is used and NaNs need to be supported: - limit = Infinity; - pos = 0; - S = from; - while (S <= to) { - if (mask[S]) { - if (pos == 0) pos = S + (1 - from); - if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } - } - S++; - } - goto lab2; - lab1:; - while (S <= to) { - if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 3) NaNs need to be supported, but it is known at compile time or cheaply - at runtime whether array is nonempty or not: - limit = Infinity; - pos = 0; - S = from; - while (S <= to) { - if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } - S++; - } - if (from <= to) pos = 1; - goto lab2; - lab1:; - while (S <= to) { - if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 4) NaNs aren't supported, array mask is used: - limit = infinities_supported ? Infinity : huge (limit); - pos = 0; - S = from; - while (S <= to) { - if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } - S++; - } - goto lab2; - lab1:; - while (S <= to) { - if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 5) Same without array mask: - limit = infinities_supported ? Infinity : huge (limit); - pos = (from <= to) ? 1 : 0; - S = from; - while (S <= to) { - if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - For 3) and 5), if mask is scalar, this all goes into a conditional, + A: Result is scalar. + 1) Array mask is used and NaNs need to be supported: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { + if (pos == 0) pos = S + (1 - from); + if (a[S] <= limit) { + limit = a[S]; + pos = S + (1 - from); + goto lab1; + } + } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) + if (a[S] < limit) { + limit = a[S]; + pos = S + (1 - from); + } + S++; + } + lab2:; + 2) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (a[S] <= limit) { + limit = a[S]; + pos = S + (1 - from); + goto lab1; + } + S++; + } + if (from <= to) pos = 1; + goto lab2; + lab1:; + while (S <= to) { + if (a[S] < limit) { + limit = a[S]; + pos = S + (1 - from); + } + S++; + } + lab2:; + 3) NaNs aren't supported, array mask is used: + limit = infinities_supported ? Infinity : huge (limit); + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { + limit = a[S]; + pos = S + (1 - from); + goto lab1; + } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) + if (a[S] < limit) { + limit = a[S]; + pos = S + (1 - from); + } + S++; + } + lab2:; + 4) Same without array mask: + limit = infinities_supported ? Infinity : huge (limit); + pos = (from <= to) ? 1 : 0; + S = from; + while (S <= to) { + if (a[S] < limit) { + limit = a[S]; + pos = S + (1 - from); + } + S++; + } + B) ARRAY has rank 1, and DIM is absent. Use the same code as the scalar + case and wrap the result in an array. + C) Otherwise, a call is generated + For 2) and 4), if mask is scalar, this all goes into a conditional, setting pos = 0; in the else branch. Since we now also support the BACK argument, instead of using @@ -5346,7 +5375,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) .... The optimizer is smart enough to move the condition out of the loop. - The are now marked as unlikely to for further speedup. */ + They are now marked as unlikely too for further speedup. */ static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) @@ -5377,6 +5406,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_expr *backexpr; gfc_se backse; tree pos; + tree result_var = NULL_TREE; int n; bool optional_mask; @@ -5392,8 +5422,19 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (se->ss) { - gfc_conv_intrinsic_funcall (se, expr); - return; + if (se->ss->info->useflags) + { + /* The inline implementation of MINLOC/MAXLOC has been generated + before, out of the scalarization loop; now we can just use the + result. */ + gfc_conv_tmp_array_ref (se); + return; + } + else if (!gfc_inline_intrinsic_function_p (expr)) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } } arrayexpr = actual->expr; @@ -5419,10 +5460,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) return; } + type = gfc_typenode_for_spec (&expr->ts); + + if (expr->rank > 0) + { + gfc_array_spec as; + memset (&as, 0, sizeof (as)); + + as.rank = 1; + as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind, + &arrayexpr->where, + HOST_WIDE_INT_1); + as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind, + &arrayexpr->where, + HOST_WIDE_INT_1); + + tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); + + result_var = gfc_create_var (array, "loc_result"); + } + /* Initialize the result. */ pos = gfc_create_var (gfc_array_index_type, "pos"); offset = gfc_create_var (gfc_array_index_type, "offset"); - type = gfc_typenode_for_spec (&expr->ts); /* Walk the arguments. */ arrayss = gfc_walk_expr (arrayexpr); @@ -5828,7 +5888,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } gfc_cleanup_loop (&loop); - se->expr = convert (type, pos); + tree value = convert (type, pos); + if (expr->rank > 0) + { + tree res_arr_ref = gfc_build_array_ref (result_var, gfc_index_zero_node, + NULL_TREE, true); + + gfc_add_modify (&se->pre, res_arr_ref, value); + + se->expr = result_var; + } + else + se->expr = value; } /* Emit code for findloc. */ @@ -11537,6 +11608,19 @@ walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr) } +/* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the + function is to be inlined. */ + +static gfc_ss * +walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED) +{ + if (expr->rank == 0) + return ss; + + return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); +} + + static gfc_ss * walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) { @@ -11550,6 +11634,10 @@ walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) case GFC_ISYM_TRANSPOSE: return walk_inline_intrinsic_transpose (ss, expr); + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MINLOC: + return walk_inline_intrinsic_minmaxloc (ss, expr); + default: gcc_unreachable (); } @@ -11569,6 +11657,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) case GFC_ISYM_LBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_LCOBOUND: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MINLOC: case GFC_ISYM_THIS_IMAGE: case GFC_ISYM_SHAPE: break; @@ -11660,16 +11750,14 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) return false; gfc_actual_arglist *array_arg = expr->value.function.actual; - gfc_actual_arglist *dim_arg = array_arg->next; gfc_expr *array = array_arg->expr; - gfc_expr *dim = dim_arg->expr; if (!(array->ts.type == BT_INTEGER || array->ts.type == BT_REAL)) return false; - if (array->rank == 1 && dim != nullptr) + if (array->rank == 1) return true; return false; From patchwork Fri Aug 16 10:22:21 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973194 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=m3UwSX0n; 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 4WldQx3Zqkz20Bh for ; Fri, 16 Aug 2024 20:24:57 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 59E3C385DDFE for ; Fri, 16 Aug 2024 10:24:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id 88D47385DDC4; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 88D47385DDC4 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 88D47385DDC4 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.14 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803757; cv=none; b=Z7Z/5pqGD3i4EPReeg6/5x3IJhqxBXcA83a8PihXo2zcVrFoUqny76g07jMVVdJmiHzsmVQfZybGpdbyJnA6mUk0Ihe2LQB4FYr7D8qY0fSPTfzklxDilWgw4hR2+ayZehFJw46drVScv3hcM97Ti2eR2BamvdPKdlncmbpt6qY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803757; c=relaxed/simple; bh=Opkxnn84x3VQS1MVHOwzXhZJZhWWiFVWrB60ulwtqzQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=JxvnBGkNA9hrnpWO4yzvzJvh9dLyU94BtFFF/VANMgvUVKDAiObXK6HsWH+v01p0tf9OSmRi91SORSsNJm3LZtnxT0h6URG6NN8qt3pzHbry8kp2fy136nWfZdqVEfrzWdVzqzkKJP01jaMJ1lJtT3Q2Mgr66mPWDvN9iZA815o= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ls0CgL; Fri, 16 Aug 2024 12:22:33 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803753; bh=qTy4gMVA8P8ecXexAaz/ZlnMEB8uSmx5bOLzUSZHS0g=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=m3UwSX0nCp7JvmMm9ZfDS0vL/n03dlhtGCxonoidpPe9xCX3g6VyX0g9BOR0UTzPs olcJpmImqvJR+aNCl6TdELQyu44sBbALN0JLB7xI7NO/NeETPJYNaHJoSGRHusqc91 hkXqKxUu3ox+E49DfU8ftvEp1xX3MpfBfiFLltxGAFvZtxlv4ghT60D12uRP8B80xR Wb6RbCq/v0HRNECIJxgbTPgn/mFKLDrG/33mzS9x972uZfBUZ5aUigflrki24SwR0c LHSJ2uGHIBlS9xSJVDP9vETcozglYo4fSFebCeLQYqLitK3l7XUYE9NuG93Zb5ja+q 786vkyeHxhrrw== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:33 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 04/10] fortran: Remove MINLOC/MAXLOC frontend optimization Date: Fri, 16 Aug 2024 12:22:21 +0200 Message-ID: <20240816102227.189290-5-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-10.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 This patch is new in the V2 series. Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Remove the frontend pass rewriting calls of MINLOC/MAXLOC without DIM to calls with one-valued DIM enclosed in an array constructor. This transformation was circumventing the limitation of inline MINLOC/MAXLOC code generation to scalar cases only, allowing inline code to be generated if ARRAY had rank 1 and DIM was absent. As MINLOC/MAXLOC has gained support of inline code generation in that case, the limitation is no longer effective, and the transformation no longer necessary. gcc/fortran/ChangeLog: * frontend-passes.cc (optimize_minmaxloc): Remove. (optimize_expr): Remove dispatch to optimize_minmaxloc. --- gcc/fortran/frontend-passes.cc | 57 ---------------------------------- 1 file changed, 57 deletions(-) diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 8e4c6310ba8..31d553e9844 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -36,7 +36,6 @@ static bool optimize_op (gfc_expr *); static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); static bool optimize_trim (gfc_expr *); static bool optimize_lexical_comparison (gfc_expr *); -static void optimize_minmaxloc (gfc_expr **); static bool is_empty_string (gfc_expr *e); static void doloop_warn (gfc_namespace *); static int do_intent (gfc_expr **); @@ -356,17 +355,6 @@ optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) gfc_simplify_expr (*e, 0); - if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) - switch ((*e)->value.function.isym->id) - { - case GFC_ISYM_MINLOC: - case GFC_ISYM_MAXLOC: - optimize_minmaxloc (e); - break; - default: - break; - } - if (function_expr) count_arglist --; @@ -2262,51 +2250,6 @@ optimize_trim (gfc_expr *e) return true; } -/* Optimize minloc(b), where b is rank 1 array, into - (/ minloc(b, dim=1) /), and similarly for maxloc, - as the latter forms are expanded inline. */ - -static void -optimize_minmaxloc (gfc_expr **e) -{ - gfc_expr *fn = *e; - gfc_actual_arglist *a; - char *name, *p; - - if (fn->rank != 1 - || fn->value.function.actual == NULL - || fn->value.function.actual->expr == NULL - || fn->value.function.actual->expr->ts.type == BT_CHARACTER - || fn->value.function.actual->expr->rank != 1 - || gfc_inline_intrinsic_function_p (fn)) - return; - - *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); - (*e)->shape = fn->shape; - fn->rank = 0; - fn->shape = NULL; - gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); - - name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); - strcpy (name, fn->value.function.name); - p = strstr (name, "loc0"); - p[3] = '1'; - fn->value.function.name = gfc_get_string ("%s", name); - if (fn->value.function.actual->next) - { - a = fn->value.function.actual->next; - gcc_assert (a->expr == NULL); - } - else - { - a = gfc_get_actual_arglist (); - fn->value.function.actual->next = a; - } - a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &fn->where); - mpz_set_ui (a->expr->value.integer, 1); -} - /* Data package to hand down for DO loop checks in a contained procedure. */ typedef struct contained_info From patchwork Fri Aug 16 10:22:22 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973193 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=t7Cpg2dg; 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 4WldQ95bBKz20Bh for ; Fri, 16 Aug 2024 20:24:17 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9D3EE385DDD6 for ; Fri, 16 Aug 2024 10:24:15 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-66.smtpout.orange.fr [80.12.242.66]) by sourceware.org (Postfix) with ESMTPS id DBEE5385DDC7; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org DBEE5385DDC7 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 DBEE5385DDC7 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.66 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; cv=none; b=c3Zc/uvigolREduiLBsqKN9wuIm3rCtvMg04xUELgd3U5th6rgbw8gPPQn5Bs6O8eiiNDb9oesNui0m8kIWdi9uahf1U2D6ZiJp+4159bMk1rAJEd1JO5cg46Sr9drTH379cxphBdkdVgwi53qDQlXOuULXjhNaz5eFio6yfeYY= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; c=relaxed/simple; bh=06gs1iR4lEIPb8VMwunCYMd08QGgDdkpRmd9ReRxCRU=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=fb1K/HXCO6RrBimnAfM4Wnf7FYn0hjdnRsF+S6kWkEKC6n5/+9mKRD9IcFWqst0PGyzjefXuVd9Uns794h7DdsnWlSCw2U8983FeTXhuGGeTExNrPXz07grxzfiBaZn7A1OhAPHR3CCvStMHR279NCDjFHYYU7GyO8UxhZzW7cc= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ls0CgM; Fri, 16 Aug 2024 12:22:33 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803753; bh=EtgYlQtFMrg8ap+p9TDI+LniBB/fmGzlxyqMJyvBquo=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=t7Cpg2dgt6haLqyBNTFC/fZqoI5kplGUkxulfXDumUFlTr3wi/Z9WEHGkShIX04sR ysncqX83YSd1NbuyuZAUYJrwSV0LfkGG3LxrLOqKa/xUQ0BXd5iHez2k4mgLMVhY25 wG55liw8stX88dEUnrnLiMabJ1+glyn9rUiHW3+tvdGQqwM8u2POLKBqcaMLtatkuw FyQ0CxIZNo9FEn3FRXpAJ1Jk/3YnAAD80m1gvP8rF6jJPzTg9RuLEe1/F7HrehCICf WFtrcxsTKcbzS4qr3FaEY3DRMsGFTv8PdobHi4ib2qbdRYOZsoSAUpDAntTWOQ+cKb ogW0xvozHCskQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:33 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 05/10] fortran: Outline array bound check generation code Date: Fri, 16 Aug 2024 12:22:22 +0200 Message-ID: <20240816102227.189290-6-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.0 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_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 The next patch will need reindenting of the array bound check generation code. This outlines it to its own function beforehand, reducing the churn in the next patch. Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- gcc/fortran/ChangeLog: * trans-array.cc (gfc_conv_ss_startstride): Move array bound check generation code... (add_check_section_in_array_bounds): ... here as a new function. --- gcc/fortran/trans-array.cc | 297 ++++++++++++++++++------------------- 1 file changed, 143 insertions(+), 154 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 46e2152d0f0..e578b676fcc 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -4816,6 +4816,146 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) } +/* Generate in INNER the bounds checking code along the dimension DIM for + the array associated with SS_INFO. */ + +static void +add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info, + int dim) +{ + gfc_expr *expr = ss_info->expr; + locus *expr_loc = &expr->where; + const char *expr_name = expr->symtree->name; + + gfc_array_info *info = &ss_info->data.array; + + bool check_upper; + if (dim == info->ref->u.ar.dimen - 1 + && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) + check_upper = false; + else + check_upper = true; + + /* Zero stride is not allowed. */ + tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + info->stride[dim], gfc_index_zero_node); + char * msg = xasprintf ("Zero stride is not allowed, for dimension %d " + "of array '%s'", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg); + free (msg); + + tree desc = info->descriptor; + + /* This is the run-time equivalent of resolve.cc's + check_dimension. The logical is more readable there + than it is here, with all the trees. */ + tree lbound = gfc_conv_array_lbound (desc, dim); + tree end = info->end[dim]; + tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE; + + /* non_zerosized is true when the selected range is not + empty. */ + tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + info->start[dim], end); + stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, stride_pos, tmp); + + tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + info->start[dim], end); + stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, stride_neg, tmp); + tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, stride_pos, + stride_neg); + + /* Check the start of the range against the lower and upper + bounds of the array, if the range is not empty. + If upper bound is present, include both bounds in the + error message. */ + if (check_upper) + { + tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + non_zerosized, tmp); + tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + info->start[dim], ubound); + tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + non_zerosized, tmp2); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of " + "expected range (%%ld:%%ld)", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); + gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); + free (msg); + } + else + { + tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + non_zerosized, tmp); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below " + "lower bound of %%ld", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } + + /* Compute the last element of the range, which is not + necessarily "end" (think 0:5:3, which doesn't contain 5) + and check it against both lower and upper bounds. */ + + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + end, info->start[dim]); + tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type, + tmp, info->stride[dim]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + end, tmp); + tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + tmp, lbound); + tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + non_zerosized, tmp2); + if (check_upper) + { + tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + tmp, ubound); + tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + non_zerosized, tmp3); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of " + "expected range (%%ld:%%ld)", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); + gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } + else + { + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below " + "lower bound of %%ld", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } +} + + /* Calculates the range start and stride for a SS chain. Also gets the descriptor and data pointer. The range of vector subscripts is the size of the vector. Array bounds are also checked. */ @@ -4826,7 +4966,6 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) int n; tree tmp; gfc_ss *ss; - tree desc; gfc_loopinfo * const outer_loop = outermost_loop (loop); @@ -4996,10 +5135,8 @@ done: if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { stmtblock_t block; - tree lbound, ubound; - tree end; tree size[GFC_MAX_DIMENSIONS]; - tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; + tree tmp3; gfc_array_info *info; char *msg; int dim; @@ -5065,163 +5202,15 @@ done: dimensions are checked later. */ for (n = 0; n < loop->dimen; n++) { - bool check_upper; - dim = ss->dim[n]; if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) continue; - if (dim == info->ref->u.ar.dimen - 1 - && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) - check_upper = false; - else - check_upper = true; - - /* Zero stride is not allowed. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - info->stride[dim], gfc_index_zero_node); - msg = xasprintf ("Zero stride is not allowed, for dimension %d " - "of array '%s'", dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg); - free (msg); - - desc = info->descriptor; - - /* This is the run-time equivalent of resolve.cc's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ - lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[dim]; - if (check_upper) - ubound = gfc_conv_array_ubound (desc, dim); - else - ubound = NULL; - - /* non_zerosized is true when the selected range is not - empty. */ - stride_pos = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, info->stride[dim], - gfc_index_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - info->start[dim], end); - stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, stride_pos, tmp); - - stride_neg = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - info->start[dim], end); - stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - stride_neg, tmp); - non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, - stride_pos, stride_neg); - - /* Check the start of the range against the lower and upper - bounds of the array, if the range is not empty. - If upper bound is present, include both bounds in the - error message. */ - if (check_upper) - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp); - tmp2 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, - info->start[dim], ubound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp2); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - free (msg); - } - else - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Compute the last element of the range, which is not - necessarily "end" (think 0:5:3, which doesn't contain 5) - and check it against both lower and upper bounds. */ - - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, tmp); - tmp2 = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, lbound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp2); - if (check_upper) - { - tmp3 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp, ubound); - tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp3); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - else - { - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } + add_check_section_in_array_bounds (&inner, ss_info, dim); /* Check the section sizes match. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, + gfc_array_index_type, info->end[dim], info->start[dim]); tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, gfc_array_index_type, tmp, From patchwork Fri Aug 16 10:22:23 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973191 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=XjNQitZk; 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 4WldPb49xgz20Bh for ; Fri, 16 Aug 2024 20:23:47 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 66D97385DDE4 for ; Fri, 16 Aug 2024 10:23:45 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id D9251385DDC6; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D9251385DDC6 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 D9251385DDC6 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.14 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; cv=none; b=CfQzkrjq+zrnk044VEQygofAKuhNwmnMubIfsfCeJv0awK6K+4xvLXaMJttim84hnDHvAyuUgzTjyNoOzegRli63wPuVTTvfwoNqjzRTWuv71VxQDMuhECxlix3MB5GBNR5eTRLhbehVw36IbcAAdm4Lz3iNFwEM6dmAKAA35zU= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; c=relaxed/simple; bh=cjTmv6JLA7pKPHaKCkfx5sax62xE/743gxkmksz7iiA=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=S/Tcp2fyt/27cGTKNNlEdaIM+aGA9x+i9kznbyZAG5s394SYrR9gn1+jM5AyODR41nyjgiBoQu0YSFcjZ9rfroNJIeyJM+rEmt1RBUkAF4R8s2di+6nzJoxIjb3N5JN6px8TwtEaIY1K5dZdZVFe3i/SGn5QWUFo3rVHQ++mfgw= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ms0CgO; Fri, 16 Aug 2024 12:22:34 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803754; bh=FiXBJuqvqcjbnImzw3Z30gmFDSXs7Mk09Sx8vM886vg=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=XjNQitZkyrqPPn+3em1TAeoDikcYIHlvAy6UZ7gLw8vYYctz5WWhUEPkKvb0icSRZ vwrdC84g2iZu+r9owNFyTDtIiWcRUrOUkv7kt4cI/QRsPRVWt5puv6M0fIlkCkhWxy +7mkv5yvv2qvzgfZVIFIyFqviAtU304wQ0Bwwk3DbZ2zRMqMFUPXe8UJtIhn/YFvQ3 FrC2FigaHIJ1/1/RYP9xgyb1xyEyii/ETQrSVz7FODbyGU48Ofog+w/9AN5mKR1wKm EV8ssqIZbpGWrCnfaxRVPp86NqLmaq7i1oKsLxA7ntKdoI63wvRzpSo41TZRwbQOPV Wd/b+XWO8CJ0A== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:34 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 06/10] fortran: Inline integral MINLOC/MAXLOC with no DIM and no MASK [PR90608] Date: Fri, 16 Aug 2024 12:22:23 +0200 Message-ID: <20240816102227.189290-7-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-10.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Enable generation of inline code for the MINLOC and MAXLOC intrinsic, if the ARRAY argument is of integral type and of any rank (only the rank 1 case was previously inlined), and neither DIM nor MASK arguments are present. This needs a few adjustments in gfc_conv_intrinsic_minmaxloc, mainly to replace the single variables POS and OFFSET, with collections of variables, one variable per dimension each. The restriction to integral ARRAY and absent MASK limits the scope of the change to the cases where we generate single loop inline code. The code generation for the second loop is only accessible with ARRAY of rank 1, so it can continue using a single variable. A later change will extend inlining to the double loop cases. There is some bounds checking code that was previously handled by the library, and that needed some changes in the scalarizer to avoid regressing. The bounds check code generation was already supported by the scalarizer, but it was only applying to array reference sections, checking both for array bound violation and for shape conformability between all the involved arrays. With this change, for MINLOC or MAXLOC, enable the conformability check between all the scalarized arrays, and disable the array bound violation check. PR fortran/90608 gcc/fortran/ChangeLog: * trans-array.cc (gfc_conv_ss_startstride): Set the MINLOC/MAXLOC result upper bound using the rank of the ARRAY argument. Ajdust the error message for intrinsic result arrays. Only check array bounds for array references. Move bound check decision code... (bounds_check_needed): ... here as a new predicate. Allow bound check for MINLOC/MAXLOC intrinsic results. * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Change the result array upper bound to the rank of ARRAY. Update the NONEMPTY variable to depend on the non-empty extent of every dimension. Use one variable per dimension instead of a single variable for the position and the offset. Update their declaration, initialization, and update to affect the variable of each dimension. Use the first variable only in areas only accessed with rank 1 ARRAY argument. Set every element of the result using its corresponding variable. (gfc_inline_intrinsic_function_p): Return true for integral ARRAY and absent DIM and MASK. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_bounds_4.f90: Additionally accept the error message emitted by the scalarizer. --- gcc/fortran/trans-array.cc | 70 ++++++-- gcc/fortran/trans-intrinsic.cc | 150 +++++++++++++----- gcc/testsuite/gfortran.dg/maxloc_bounds_4.f90 | 4 +- 3 files changed, 166 insertions(+), 58 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e578b676fcc..1190bfa6c02 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -4956,6 +4956,35 @@ add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info, } +/* Tells whether we need to generate bounds checking code for the array + associated with SS. */ + +bool +bounds_check_needed (gfc_ss *ss) +{ + /* Catch allocatable lhs in f2003. */ + if (flag_realloc_lhs && ss->no_bounds_check) + return false; + + gfc_ss_info *ss_info = ss->info; + if (ss_info->type == GFC_SS_SECTION) + return true; + + if (!(ss_info->type == GFC_SS_INTRINSIC + && ss_info->expr + && ss_info->expr->expr_type == EXPR_FUNCTION)) + return false; + + gfc_intrinsic_sym *isym = ss_info->expr->value.function.isym; + if (!(isym + && (isym->id == GFC_ISYM_MAXLOC + || isym->id == GFC_ISYM_MINLOC))) + return false; + + return gfc_inline_intrinsic_function_p (ss_info->expr); +} + + /* Calculates the range start and stride for a SS chain. Also gets the descriptor and data pointer. The range of vector subscripts is the size of the vector. Array bounds are also checked. */ @@ -5057,10 +5086,17 @@ done: info->data = gfc_conv_array_data (info->descriptor); info->data = gfc_evaluate_now (info->data, &outer_loop->pre); - info->offset = gfc_index_zero_node; + gfc_expr *array = expr->value.function.actual->expr; + tree rank = build_int_cst (gfc_array_index_type, array->rank); + + tree tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, rank, + gfc_index_one_node); + + info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre); info->start[0] = gfc_index_zero_node; - info->end[0] = gfc_index_zero_node; info->stride[0] = gfc_index_one_node; + info->offset = gfc_index_zero_node; continue; } @@ -5178,14 +5214,10 @@ done: const char *expr_name; char *ref_name = NULL; + if (!bounds_check_needed (ss)) + continue; + ss_info = ss->info; - if (ss_info->type != GFC_SS_SECTION) - continue; - - /* Catch allocatable lhs in f2003. */ - if (flag_realloc_lhs && ss->no_bounds_check) - continue; - expr = ss_info->expr; expr_loc = &expr->where; if (expr->ref) @@ -5203,10 +5235,13 @@ done: for (n = 0; n < loop->dimen; n++) { dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - continue; + if (ss_info->type == GFC_SS_SECTION) + { + if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + continue; - add_check_section_in_array_bounds (&inner, ss_info, dim); + add_check_section_in_array_bounds (&inner, ss_info, dim); + } /* Check the section sizes match. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, @@ -5227,9 +5262,14 @@ done: { tmp3 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, size[n]); - msg = xasprintf ("Array bound mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", - dim + 1, expr_name); + if (ss_info->type == GFC_SS_INTRINSIC) + msg = xasprintf ("Extent mismatch for dimension %d of the " + "result of intrinsic '%s' (%%ld/%%ld)", + dim + 1, expr_name); + else + msg = xasprintf ("Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", + dim + 1, expr_name); gfc_trans_runtime_check (true, false, tmp3, &inner, expr_loc, msg, diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 9fcb57a9cc4..b8a7faf5459 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5358,9 +5358,30 @@ strip_kind_from_actual (gfc_actual_arglist * actual) } S++; } - B) ARRAY has rank 1, and DIM is absent. Use the same code as the scalar + B: ARRAY has rank 1, and DIM is absent. Use the same code as the scalar case and wrap the result in an array. - C) Otherwise, a call is generated + C: ARRAY has rank > 1, NANs are not supported, and DIM and MASK are absent. + Generate code similar to the single loop scalar case, but using one + variable per dimension, for example if ARRAY has rank 2: + 4) NAN's aren't supported, no MASK: + limit = infinities_supported ? Infinity : huge (limit); + pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0; + pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0; + S1 = from1; + while (S1 <= to1) { + S0 = from0; + while (S0 <= to0) { + if (a[S1][S0] < limit) { + limit = a[S1][S0]; + pos0 = S + (1 - from0); + pos1 = S + (1 - from1); + } + S0++; + } + S1++; + } + result = { pos0, pos1 }; + D: Otherwise, a call is generated. For 2) and 4), if mask is scalar, this all goes into a conditional, setting pos = 0; in the else branch. @@ -5374,8 +5395,8 @@ strip_kind_from_actual (gfc_actual_arglist * actual) if (cond) { .... - The optimizer is smart enough to move the condition out of the loop. - They are now marked as unlikely too for further speedup. */ + The optimizer is smart enough to move the condition out of the loop. + They are now marked as unlikely too for further speedup. */ static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) @@ -5390,7 +5411,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree cond; tree elsetmp; tree ifbody; - tree offset; + tree offset[GFC_MAX_DIMENSIONS]; tree nonempty; tree lab1, lab2; tree b_if, b_else; @@ -5405,7 +5426,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_expr *maskexpr; gfc_expr *backexpr; gfc_se backse; - tree pos; + tree pos[GFC_MAX_DIMENSIONS]; tree result_var = NULL_TREE; int n; bool optional_mask; @@ -5473,7 +5494,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) HOST_WIDE_INT_1); as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind, &arrayexpr->where, - HOST_WIDE_INT_1); + arrayexpr->rank); tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); @@ -5481,8 +5502,13 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } /* Initialize the result. */ - pos = gfc_create_var (gfc_array_index_type, "pos"); - offset = gfc_create_var (gfc_array_index_type, "offset"); + for (int i = 0; i < arrayexpr->rank; i++) + { + pos[i] = gfc_create_var (gfc_array_index_type, + gfc_get_string ("pos%d", i)); + offset[i] = gfc_create_var (gfc_array_index_type, + gfc_get_string ("offset%d", i)); + } /* Walk the arguments. */ arrayss = gfc_walk_expr (arrayexpr); @@ -5601,10 +5627,26 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) loop.temp_dim = loop.dimen; gfc_conv_loop_setup (&loop, &expr->where); - gcc_assert (loop.dimen == 1); - if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) - nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - loop.from[0], loop.to[0]); + if (nonempty == NULL && maskss == NULL) + { + nonempty = logical_true_node; + + for (int i = 0; i < loop.dimen; i++) + { + if (!(loop.from[i] && loop.to[i])) + { + nonempty = NULL; + break; + } + + tree tmp = fold_build2_loc (input_location, LE_EXPR, + logical_type_node, loop.from[i], + loop.to[i]); + + nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, nonempty, tmp); + } + } lab1 = NULL; lab2 = NULL; @@ -5614,14 +5656,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) is non-empty and no MASK is used, we can initialize to 1 to simplify the inner loop. */ if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) - gfc_add_modify (&loop.pre, pos, - fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, - nonempty, gfc_index_one_node, - gfc_index_zero_node)); + { + tree init = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, nonempty, + gfc_index_one_node, + gfc_index_zero_node); + for (int i = 0; i < loop.dimen; i++) + gfc_add_modify (&loop.pre, pos[i], init); + } else { - gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); + gcc_assert (loop.dimen == 1); + gfc_add_modify (&loop.pre, pos[0], gfc_index_zero_node); lab1 = gfc_build_label_decl (NULL_TREE); TREE_USED (lab1) = 1; lab2 = gfc_build_label_decl (NULL_TREE); @@ -5630,11 +5676,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* An offset must be added to the loop counter to obtain the required position. */ - gcc_assert (loop.from[0]); + for (int i = 0; i < loop.dimen; i++) + { + gcc_assert (loop.from[i]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); - gfc_add_modify (&loop.pre, offset, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[i]); + gfc_add_modify (&loop.pre, offset[i], tmp); + } gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1); if (maskss) @@ -5675,20 +5724,23 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree ifbody2; gfc_start_block (&ifblock2); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock2, pos, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[0]), + loop.loopvar[0], offset[0]); + gfc_add_modify (&ifblock2, pos[0], tmp); ifbody2 = gfc_finish_block (&ifblock2); - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos, - gfc_index_zero_node); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + pos[0], gfc_index_zero_node); tmp = build3_v (COND_EXPR, cond, ifbody2, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock, pos, tmp); + for (int i = 0; i < loop.dimen; i++) + { + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), + loop.loopvar[i], offset[i]); + gfc_add_modify (&ifblock, pos[i], tmp); + } if (lab1) gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); @@ -5752,13 +5804,15 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (lab1) { + gcc_assert (loop.dimen == 1); + gfc_trans_scalarized_loop_boundary (&loop, &body); if (HONOR_NANS (DECL_MODE (limit))) { if (nonempty != NULL) { - ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); + ifbody = build2_v (MODIFY_EXPR, pos[0], gfc_index_one_node); tmp = build3_v (COND_EXPR, nonempty, ifbody, build_empty_stmt (input_location)); gfc_add_expr_to_block (&loop.code[0], tmp); @@ -5795,9 +5849,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Assign the value to the limit... */ gfc_add_modify (&ifblock, limit, arrayse.expr); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock, pos, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[0]), + loop.loopvar[0], offset[0]); + gfc_add_modify (&ifblock, pos[0], tmp); ifbody = gfc_finish_block (&ifblock); @@ -5860,6 +5914,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + gcc_assert (loop.dimen == 1); tree ifmask; gfc_init_se (&maskse, NULL); @@ -5874,7 +5929,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) the pos variable the same way as above. */ gfc_init_block (&elseblock); - gfc_add_modify (&elseblock, pos, gfc_index_zero_node); + gfc_add_modify (&elseblock, pos[0], gfc_index_zero_node); elsetmp = gfc_finish_block (&elseblock); ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); @@ -5888,18 +5943,22 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } gfc_cleanup_loop (&loop); - tree value = convert (type, pos); if (expr->rank > 0) { - tree res_arr_ref = gfc_build_array_ref (result_var, gfc_index_zero_node, - NULL_TREE, true); + for (int i = 0; i < arrayexpr->rank; i++) + { + tree res_idx = build_int_cst (gfc_array_index_type, i); + tree res_arr_ref = gfc_build_array_ref (result_var, res_idx, + NULL_TREE, true); - gfc_add_modify (&se->pre, res_arr_ref, value); + tree value = convert (type, pos[i]); + gfc_add_modify (&se->pre, res_arr_ref, value); + } se->expr = result_var; } else - se->expr = value; + se->expr = convert (type, pos[0]); } /* Emit code for findloc. */ @@ -11750,8 +11809,12 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) return false; 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_expr *array = array_arg->expr; + gfc_expr *dim = dim_arg->expr; + gfc_expr *mask = mask_arg->expr; if (!(array->ts.type == BT_INTEGER || array->ts.type == BT_REAL)) @@ -11760,6 +11823,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) if (array->rank == 1) return true; + if (array->ts.type == BT_INTEGER + && dim == nullptr + && mask == nullptr) + return true; + return false; } diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_4.f90 b/gcc/testsuite/gfortran.dg/maxloc_bounds_4.f90 index b1c7ca752d0..17f6cd86dc2 100644 --- a/gcc/testsuite/gfortran.dg/maxloc_bounds_4.f90 +++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_4.f90 @@ -1,6 +1,6 @@ ! { dg-do run } ! { dg-options "-fbounds-check" } -! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } module tst contains subroutine foo(res) @@ -18,4 +18,4 @@ program main integer :: res(3) call foo(res) end program main -! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } From patchwork Fri Aug 16 10:22:24 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973197 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=Qp7pItag; 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 4WldT45bP7z1yYl for ; Fri, 16 Aug 2024 20:26:48 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8A78A385DDE7 for ; Fri, 16 Aug 2024 10:26:46 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id 03BB0385C6CB; Fri, 16 Aug 2024 10:22:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 03BB0385C6CB 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 03BB0385C6CB Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.14 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; cv=none; b=bhIJYqqQUfQVMoi58EtPvL2pEi8w0S7WTR0Drfs//yxa6NxnkN6KOd5mKjEwVqMrC2et8h3Or5douGsox0ATcIFCGosD94nXYnrffawg2yb15Yaq6EKDmZJrYDUPnjd4XnPLSEcCMVqs1kn/SYs1MS5McLCt5DbtWQ8k32qkaKc= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803760; c=relaxed/simple; bh=njQEUmN7XWbRHjCBcH92SiTYiuR+mUTE32lswOKX5IQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=XBaH/agJ6Xg/uiVRij6s1K6OE5bgrUCnNmySm1MYRjfeletJFzA5hR49AyknzuCJ0KTBibYLb7J8ebuKhHKjinIUSKWkQWY9QWN3A5sfhmuKG+LkMPNkJk0ZeQJtERHCTAxnaslDoO27Cmaq7LUDQzmHGq8tdQMOGYL8IcZSabQ= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ms0CgR; Fri, 16 Aug 2024 12:22:34 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803754; bh=4b4Gx9HcX8Tl5rxbHdHGtMuzkDUnWkjVbd62tJNNAM8=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=Qp7pItagTPddPRbfyNxGQD6QD6LxXJ377efHnoS8XBUE96gdHz3r5fgNbGcxiimOH hsWt45g/h8tPxxl9kFJwv1SSLPwzCV+M7EU0Pa7vqGx1us1wyiOiO+Jg9DdJwEdNz8 uMUcanJTabpwdZYKV/KOPMgzMyuUiSjVICTGDeI1brbBVd2997vNoGE2G22Srf8vLs 8FWJuKy2fKBSDsdT5Zn0nAmwPtryaqxcMJd2Jr0Erh8mZgkmKesN3+ZttMqcgZYIhc Bi44SqocgLO8feI+EkoShdZ6t8kWCSLUrqHX6XgwvbWV3w1MuTrOfgrEUFF+JAjfdB +q7fD3ISXNBRQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:34 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 07/10] fortran: Inline integral MINLOC/MAXLOC with no DIM and scalar MASK [PR90608] Date: Fri, 16 Aug 2024 12:22:24 +0200 Message-ID: <20240816102227.189290-8-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.0 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_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Enable the generation of inline code for MINLOC/MAXLOC when argument ARRAY is of integral type, DIM is not present, and MASK is present and is scalar (only absent MASK or rank 1 ARRAY were inlined before). Scalar masks are implemented with a wrapping condition around the code one would generate if MASK wasn't present, so they are easy to support once inline code without MASK is working. PR fortran/90608 gcc/fortran/ChangeLog: * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Generate variable initialization for each dimension in the else branch of the toplevel condition. (gfc_inline_intrinsic_function_p): Return TRUE for scalar MASK. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_bounds_7.f90: Additionally accept the error message reported by the scalarizer. --- gcc/fortran/trans-intrinsic.cc | 13 ++++++++----- gcc/testsuite/gfortran.dg/maxloc_bounds_7.f90 | 4 ++-- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index b8a7faf5459..cd7a43f58fb 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5914,7 +5914,6 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { - gcc_assert (loop.dimen == 1); tree ifmask; gfc_init_se (&maskse, NULL); @@ -5929,7 +5928,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) the pos variable the same way as above. */ gfc_init_block (&elseblock); - gfc_add_modify (&elseblock, pos[0], gfc_index_zero_node); + for (int i = 0; i < loop.dimen; i++) + gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node); elsetmp = gfc_finish_block (&elseblock); ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); @@ -11823,9 +11823,12 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) if (array->rank == 1) return true; - if (array->ts.type == BT_INTEGER - && dim == nullptr - && mask == nullptr) + if (array->ts.type != BT_INTEGER + || dim != nullptr) + return false; + + if (mask == nullptr + || mask->rank == 0) return true; return false; diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_7.f90 b/gcc/testsuite/gfortran.dg/maxloc_bounds_7.f90 index 206a29b149d..3aa9d3dcebe 100644 --- a/gcc/testsuite/gfortran.dg/maxloc_bounds_7.f90 +++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_7.f90 @@ -1,6 +1,6 @@ ! { dg-do run } ! { dg-options "-fbounds-check" } -! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } module tst contains subroutine foo(res) @@ -18,4 +18,4 @@ program main integer :: res(3) call foo(res) end program main -! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } From patchwork Fri Aug 16 10:22:25 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973195 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=GtcFbNlV; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; 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 [8.43.85.97]) (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 4WldRX2nm1z1yYl for ; Fri, 16 Aug 2024 20:25:28 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 54706385DDF2 for ; Fri, 16 Aug 2024 10:25:26 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-65.smtpout.orange.fr [80.12.242.65]) by sourceware.org (Postfix) with ESMTPS id 32AD1385DDCA; Fri, 16 Aug 2024 10:22:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 32AD1385DDCA 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 32AD1385DDCA Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.65 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803762; cv=none; b=N7ElNgReA9EFRpEPlzk9CXkmVxAx90/uLt9o5yDoOFruJFkt607Iec8FbiLtYXj2tr4hZSDD0BTghyysbBeN4a43+667LhlH4nCvLgr7pFw580y9faUibF90xGq2Yslt6N6iRwKZdtF8QBNfopNHwM1FWuixpm+M+Asys2zMryg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803762; c=relaxed/simple; bh=X6KUFWC2GRZgKiVBzZjxYjkR5tW+ohpCTd9YhZZFVY4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=O0hxxxjHBLm0nKMTrC0DnhpRFPN794DkkuT9/c+KLNUamkfPRv2h1qM0NVGU81eCktmlvwt1YtpvQFUQq1nw8b01HxFifdyyuNAtkMKLNROjbVmPWbnG35u48jGNXubQkroaWjPJtXaTnCP5PyZLkMWi/C3XPorP8IuGZsHp0s4= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ms0CgV; Fri, 16 Aug 2024 12:22:34 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803754; bh=IjeDg2dyi9P9QT/51IyOZJrXpMELCLwhyv9ADTOAiGM=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=GtcFbNlVzCDLQwMo0JPAVvNdmf0VhYdRxjj0Kb8/4q0Ad7GfKdYUUyo5KieYcAixY K2VInEA9OFxuKq0gr1UpHqbf4e8p+sAEuO2aL4LCC13P75O1/kVK7rUO3VMyvc3sfy OAYCIXiA5oqidYEv4oCIqRXTJUTE3KaAK/6A8hZ7cQBKBcsT/vBX6myXannLgM6MES K9EBKr7grHTk/GtaRd5l930/RoTwC7k3UPl3sux9UAuDK5tWLE6lIQD2N/szOrzlNd A1pt+4LYEPXH3U84S1RM6GzU58wAb/3zGAch7o0E2o08JqLIOPioRJWzu1rga6cZRc qHQ0GxCoU0y+Q== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:34 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 08/10] fortran: Inline non-character MINLOC/MAXLOC with no DIM [PR90608] Date: Fri, 16 Aug 2024 12:22:25 +0200 Message-ID: <20240816102227.189290-9-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.1 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_H5, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Enable generation of inline MINLOC/MAXLOC code in the case where DIM is not present, and either ARRAY is of floating point type or MASK is an array. Those cases are the remaining bits to fully support inlining of non-CHARACTER MINLOC/MAXLOC without DIM. They are treated together because they generate similar code, the NANs for REAL types being handled a bit like a second level of masking. These are the cases for which we generate two sets of loops. This change affects the code generating the second loop, that was previously accessible only in the cases ARRAY has rank 1 only. The single variable initialization and update are changed to apply to multiple variables, one per dimension. The code generated is as follows (if ARRAY has rank 2): for (idx11 in lower1..upper1) { for (idx12 in lower2..upper2) { ... if (...) { ... goto second_loop; } } } second_loop: for (idx21 in lower1..upper1) { for (idx22 in lower2..upper2) { ... } } This code leads to processing the first elements redundantly, both in the first set of loops and in the second one. The loop over idx22 could start from idx12 the first time it is run, but as it has to start from lower2 for the rest of the runs, this change uses the same bounds for both set of loops for simplicity. In the rank 1 case, this makes the generated code worse compared to the inline code that was generated before. A later change will introduce conditionals to avoid the duplicate processing and restore the generated code in that case. PR fortran/90608 gcc/fortran/ChangeLog: * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Initialize and update all the variables. Put the label and goto in the outermost scalarizer loop. Don't start the second loop where the first stopped. (gfc_inline_intrinsic_function_p): Also return TRUE for array MASK or for any REAL type. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_bounds_5.f90: Additionally accept error messages reported by the scalarizer. * gfortran.dg/maxloc_bounds_6.f90: Ditto. --- gcc/fortran/trans-intrinsic.cc | 127 ++++++++++++------ gcc/testsuite/gfortran.dg/maxloc_bounds_5.f90 | 4 +- gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 | 4 +- 3 files changed, 87 insertions(+), 48 deletions(-) diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index cd7a43f58fb..a92b733cf2f 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5358,12 +5358,55 @@ strip_kind_from_actual (gfc_actual_arglist * actual) } S++; } - B: ARRAY has rank 1, and DIM is absent. Use the same code as the scalar - case and wrap the result in an array. - C: ARRAY has rank > 1, NANs are not supported, and DIM and MASK are absent. - Generate code similar to the single loop scalar case, but using one - variable per dimension, for example if ARRAY has rank 2: - 4) NAN's aren't supported, no MASK: + B: Array result, non-CHARACTER type, DIM absent + Generate similar code as in the scalar case, using a collection of + variables (one per dimension) instead of a single variable as result. + Picking only cases 1) and 4) with ARRAY of rank 2, the generated code + becomes: + 1) Array mask is used and NaNs need to be supported: + limit = Infinity; + pos0 = 0; + pos1 = 0; + S1 = from1; + while (S1 <= to1) { + S0 = from0; + while (s0 <= to0 { + if (mask[S1][S0]) { + if (pos0 == 0) { + pos0 = S0 + (1 - from0); + pos1 = S1 + (1 - from1); + } + if (a[S1][S0] <= limit) { + limit = a[S1][S0]; + pos0 = S0 + (1 - from0); + pos1 = S1 + (1 - from1); + goto lab1; + } + } + S0++; + } + S1++; + } + goto lab2; + lab1:; + S1 = from1; + while (S1 <= to1) { + S0 = from0; + while (S0 <= to0) { + if (mask[S1][S0]) + if (a[S1][S0] < limit) { + limit = a[S1][S0]; + pos0 = S + (1 - from0); + pos1 = S + (1 - from1); + } + S0++; + } + S1++; + } + lab2:; + result = { pos0, pos1 }; + ... + 4) NANs aren't supported, no array mask. limit = infinities_supported ? Infinity : huge (limit); pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0; pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0; @@ -5381,7 +5424,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) S1++; } result = { pos0, pos1 }; - D: Otherwise, a call is generated. + C: Otherwise, a call is generated. For 2) and 4), if mask is scalar, this all goes into a conditional, setting pos = 0; in the else branch. @@ -5612,18 +5655,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* The code generated can have more than one loop in sequence (see the comment at the function header). This doesn't work well with the scalarizer, which changes arrays' offset when the scalarization loops - are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc - are currently inlined in the scalar case only (for which loop is of rank - one). As there is no dependency to care about in that case, there is no - temporary, so that we can use the scalarizer temporary code to handle - multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used - with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later - to restore offset. - TODO: this prevents inlining of rank > 0 minmaxloc calls, so this - should eventually go away. We could either create two loops properly, - or find another way to save/restore the array offsets between the two - loops (without conflicting with temporary management), or use a single - loop minmaxloc implementation. See PR 31067. */ + are generated (see gfc_trans_preloop_setup). Fortunately, we can use + the scalarizer temporary code to handle multiple loops. Thus, we set + temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and + we use gfc_trans_scalarized_loop_boundary even later to restore + offset. */ loop.temp_dim = loop.dimen; gfc_conv_loop_setup (&loop, &expr->where); @@ -5666,8 +5702,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } else { - gcc_assert (loop.dimen == 1); - gfc_add_modify (&loop.pre, pos[0], gfc_index_zero_node); + for (int i = 0; i < loop.dimen; i++) + gfc_add_modify (&loop.pre, pos[i], gfc_index_zero_node); lab1 = gfc_build_label_decl (NULL_TREE); TREE_USED (lab1) = 1; lab2 = gfc_build_label_decl (NULL_TREE); @@ -5724,10 +5760,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree ifbody2; gfc_start_block (&ifblock2); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[0]), - loop.loopvar[0], offset[0]); - gfc_add_modify (&ifblock2, pos[0], tmp); + for (int i = 0; i < loop.dimen; i++) + { + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), + loop.loopvar[i], offset[i]); + gfc_add_modify (&ifblock2, pos[i], tmp); + } ifbody2 = gfc_finish_block (&ifblock2); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos[0], gfc_index_zero_node); tmp = build3_v (COND_EXPR, cond, ifbody2, @@ -5804,23 +5844,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (lab1) { - gcc_assert (loop.dimen == 1); - gfc_trans_scalarized_loop_boundary (&loop, &body); + stmtblock_t * const outer_block = &loop.code[loop.dimen - 1]; + if (HONOR_NANS (DECL_MODE (limit))) { if (nonempty != NULL) { - ifbody = build2_v (MODIFY_EXPR, pos[0], gfc_index_one_node); + stmtblock_t init_block; + gfc_init_block (&init_block); + + for (int i = 0; i < loop.dimen; i++) + gfc_add_modify (&init_block, pos[i], gfc_index_one_node); + + tree ifbody = gfc_finish_block (&init_block); tmp = build3_v (COND_EXPR, nonempty, ifbody, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&loop.code[0], tmp); + gfc_add_expr_to_block (outer_block, tmp); } } - gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); - gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); + gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2)); + gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1)); /* If we have a mask, only check this element if the mask is set. */ if (maskss) @@ -5849,9 +5895,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Assign the value to the limit... */ gfc_add_modify (&ifblock, limit, arrayse.expr); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[0]), - loop.loopvar[0], offset[0]); - gfc_add_modify (&ifblock, pos[0], tmp); + for (int i = 0; i < loop.dimen; i++) + { + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), + loop.loopvar[i], offset[i]); + gfc_add_modify (&ifblock, pos[i], tmp); + } ifbody = gfc_finish_block (&ifblock); @@ -5901,9 +5950,6 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) else tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&body, tmp); - /* Avoid initializing loopvar[0] again, it should be left where - it finished by the first loop. */ - loop.from[0] = loop.loopvar[0]; } gfc_trans_scalarizing_loops (&loop, &body); @@ -11810,11 +11856,9 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) 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_expr *array = array_arg->expr; gfc_expr *dim = dim_arg->expr; - gfc_expr *mask = mask_arg->expr; if (!(array->ts.type == BT_INTEGER || array->ts.type == BT_REAL)) @@ -11823,12 +11867,7 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) if (array->rank == 1) return true; - if (array->ts.type != BT_INTEGER - || dim != nullptr) - return false; - - if (mask == nullptr - || mask->rank == 0) + if (dim == nullptr) return true; return false; diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_5.f90 b/gcc/testsuite/gfortran.dg/maxloc_bounds_5.f90 index ad93d238e74..071c1c37868 100644 --- a/gcc/testsuite/gfortran.dg/maxloc_bounds_5.f90 +++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_5.f90 @@ -1,6 +1,6 @@ ! { dg-do run } ! { dg-options "-fbounds-check" } -! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } module tst contains subroutine foo(res) @@ -18,4 +18,4 @@ program main integer :: res(3) call foo(res) end program main -! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." } diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 b/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 index 3a63418aef3..0ce0bfcb70c 100644 --- a/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 +++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 @@ -1,6 +1,6 @@ ! { dg-do run } ! { dg-options "-fbounds-check" } -! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } +! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2|Array bound mismatch for dimension 2 of array 'm' .3/2." } program main integer(kind=4), allocatable :: f(:,:) logical, allocatable :: m(:,:) @@ -12,4 +12,4 @@ program main res = maxloc(f,mask=m) write(line,fmt='(80I1)') res end program main -! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } +! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2|Array bound mismatch for dimension 2 of array 'm' .3/2." } From patchwork Fri Aug 16 10:22:26 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973198 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=DQg5M9Y1; 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 4WldTQ0zqfz1yYl for ; Fri, 16 Aug 2024 20:27:06 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 00B03385DDCD for ; Fri, 16 Aug 2024 10:27:04 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-13.smtpout.orange.fr [80.12.242.13]) by sourceware.org (Postfix) with ESMTPS id 7DD30385DC1B; Fri, 16 Aug 2024 10:22:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7DD30385DC1B 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 7DD30385DC1B Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.13 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803764; cv=none; b=SLCcwlxDPJQa+nY/nqWYLOjfeBPTfTaGuYlhpuweOr71XqajAFtbVRmHSqFtSWHwoXnNrGo83KUdPYLqieOjHGzAJ4f/cGJkuvHuphDCu7B3BVKzF9PqDzvWgNyEs7J9IgGZmFoXJJTo6vbNLX3rLRI/jIL7dXbvIKGPyQIST9g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803764; c=relaxed/simple; bh=NTiec1V19wDxsKIlNfkVLsJyf67dQA9UkSPm8Sg/v50=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=VKqG+xcw79zJMwRSy5n6xwmmHFhshF9tw7bpt5TA6GyrrgdpFTSNgNffWFBE2rssDc/X7IJloBm8RDN40lAWg3A8xaJEZB78VJ7BdcwqvuY0AJ7md5Wdaym1BInhTnM2agEbC9Q9PRfJ/Z3fjjNbLgCwO26uEwGjKZX5K73xHsg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ms0CgW; Fri, 16 Aug 2024 12:22:34 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803754; bh=NREN+6Mm5fGBVJJ2iUOJqHG0QqoByWhx/DTLGgD/aQ0=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=DQg5M9Y1FVxxXokcQb0v/b4iRYBbnrgKtOkM6Cm0LzaCZFNygheEnV6tWpwkm/MMy rZwv4M9I1FX4JZhaI4V2E9TMDZTc9KBGb8RavPN1NV5C0MW7i0DE90lR1n+j77/lmo DPy+M054nY4TUxF9SHW8MaFh5ejW0CG7Mb5db14a5Y8g3aWaodzdJKyZZVuHnjeF4d d617VoMwFuWDxO0POpSQ4g5p7Z7uSbGvRH2jegj8iaeACoqTPwse0PRaXPf1ahwOYH I0sd5+NAnqiDArR3xbvJoimz/X/dqVCBAgwA0ZGGkw+Wgb+I3phdiRDxrjxvBjDiLH p8UVsP6kw5NpA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:34 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 09/10] fortran: Continue MINLOC/MAXLOC second loop where the first stopped [PR90608] Date: Fri, 16 Aug 2024 12:22:26 +0200 Message-ID: <20240816102227.189290-10-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.1 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_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Continue the second set of loops where the first one stopped in the generated inline MINLOC/MAXLOC code in the cases where the generated code contains two sets of loops. This fixes a regression that was introduced when enabling the generation of inline MINLOC/MAXLOC code with ARRAY of rank greater than 1, no DIM argument, and either non-scalar MASK or floating- point ARRAY. In the cases where two sets of loops are generated as inline MINLOC/MAXLOC code, we previously generated code such as (for rank 2 ARRAY, so with two levels of nesting): for (idx11 in lower1..upper1) { for (idx12 in lower2..upper2) { ... if (...) { ... goto second_loop; } } } second_loop: for (idx21 in lower1..upper1) { for (idx22 in lower2..upper2) { ... } } which means we process the first elements twice, once in the first set of loops and once in the second one. This change avoids this duplicate processing by using a conditional as lower bound for the second set of loops, generating code like: second_loop_entry = false; for (idx11 in lower1..upper1) { for (idx12 in lower2..upper2) { ... if (...) { ... second_loop_entry = true; goto second_loop; } } } second_loop: for (idx21 in (second_loop_entry ? idx11 : lower1)..upper1) { for (idx22 in (second_loop_entry ? idx12 : lower2)..upper2) { ... second_loop_entry = false; } } It was expected that the compiler optimizations would be able to remove the state variable second_loop_entry. It is the case if ARRAY has rank 1 (so without loop nesting), the variable is removed and the loop bounds become unconditional, which restores previously generated code, fully fixing the regression. For larger rank, unfortunately, the state variable and conditional loop bounds remain, but those cases were previously using library calls, so it's not a regression. PR fortran/90608 gcc/fortran/ChangeLog: * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Generate a set of index variables. Set them using the loop indexes before leaving the first set of loops. Generate a new loop entry predicate. Initialize it. Set it before leaving the first set of loops. Clear it in the body of the second set of loops. For the second set of loops, update each loop lower bound to use the corresponding index variable if the predicate variable is set. --- gcc/fortran/trans-intrinsic.cc | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index a92b733cf2f..b03f7b1653e 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5368,6 +5368,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) pos0 = 0; pos1 = 0; S1 = from1; + second_loop_entry = false; while (S1 <= to1) { S0 = from0; while (s0 <= to0 { @@ -5380,6 +5381,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) limit = a[S1][S0]; pos0 = S0 + (1 - from0); pos1 = S1 + (1 - from1); + second_loop_entry = true; goto lab1; } } @@ -5389,9 +5391,9 @@ strip_kind_from_actual (gfc_actual_arglist * actual) } goto lab2; lab1:; - S1 = from1; + S1 = second_loop_entry ? S1 : from1; while (S1 <= to1) { - S0 = from0; + S0 = second_loop_entry ? S0 : from0; while (S0 <= to0) { if (mask[S1][S0]) if (a[S1][S0] < limit) { @@ -5399,6 +5401,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) pos0 = S + (1 - from0); pos1 = S + (1 - from1); } + second_loop_entry = false; S0++; } S1++; @@ -5470,6 +5473,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_expr *backexpr; gfc_se backse; tree pos[GFC_MAX_DIMENSIONS]; + tree idx[GFC_MAX_DIMENSIONS]; tree result_var = NULL_TREE; int n; bool optional_mask; @@ -5551,6 +5555,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_get_string ("pos%d", i)); offset[i] = gfc_create_var (gfc_array_index_type, gfc_get_string ("offset%d", i)); + idx[i] = gfc_create_var (gfc_array_index_type, + gfc_get_string ("idx%d", i)); } /* Walk the arguments. */ @@ -5637,6 +5643,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_add_modify (&se->pre, limit, tmp); + /* If we are in a case where we generate two sets of loops, the second one + should continue where the first stopped instead of restarting from the + beginning. So nested loops in the second set should have a partial range + on the first iteration, but they should start from the beginning and span + their full range on the following iterations. So we use conditionals in + the loops lower bounds, and use the following variable in those + conditionals to decide whether to use the original loop bound or to use + the index at which the loop from the first set stopped. */ + tree second_loop_entry = gfc_create_var (logical_type_node, + "second_loop_entry"); + gfc_add_modify (&se->pre, second_loop_entry, logical_false_node); + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); @@ -5780,8 +5798,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), loop.loopvar[i], offset[i]); gfc_add_modify (&ifblock, pos[i], tmp); + gfc_add_modify (&ifblock, idx[i], loop.loopvar[i]); } + gfc_add_modify (&ifblock, second_loop_entry, logical_true_node); + if (lab1) gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); @@ -5844,6 +5865,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (lab1) { + for (int i = 0; i < loop.dimen; i++) + loop.from[i] = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (loop.from[i]), + second_loop_entry, idx[i], + loop.from[i]); + gfc_trans_scalarized_loop_boundary (&loop, &body); stmtblock_t * const outer_block = &loop.code[loop.dimen - 1]; @@ -5949,7 +5976,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } else tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + gfc_add_modify (&body, second_loop_entry, logical_false_node); } gfc_trans_scalarizing_loops (&loop, &body); From patchwork Fri Aug 16 10:22:27 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1973201 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=DSKJiLLd; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; 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 [8.43.85.97]) (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 4WldX63Lgqz1yYl for ; Fri, 16 Aug 2024 20:29:26 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 98EE4385DDCF for ; Fri, 16 Aug 2024 10:29:24 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-208.smtpout.orange.fr [193.252.23.208]) by sourceware.org (Postfix) with ESMTPS id B52B1385DDC8; Fri, 16 Aug 2024 10:22:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B52B1385DDC8 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 B52B1385DDC8 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.208 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803765; cv=none; b=rmR/X3x0MLyyGB3JS328IywGThj+dCLkoWI1EZnaYvFvvst8cccYfNXTISAvFO0D1xoEJlTbaZMWIM+YXhNXyx8tPHz77/58SOij2U8QdoaCwOjoWVvJpwc60Ej5C8+kQyD2rFy5HUBfviOsmgmMZPJ5vvQ965Cm+qkkV+YYrpw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1723803765; c=relaxed/simple; bh=26bmZc1q9x62WOV7as1dI2ucvyx8ukOnPWlMgu102c8=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=OrfGdo3DP9BbCFSrCqcR+k4Fwx0FPE8bd4NEhu2QRuREM+OIZgF4+iR0MWgUct80kAwOKbMdvl8iJlDDYVlAolVGGycVpzj+23pZnOb1OS/SMA6tLt9jKNz+6WiyReJ/XC7duKWseHtSR6DQAYEVZ8Nh+ygizyQMAFEfcpAJndY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id eu6FsXj565Qjaeu6Ms0CgX; Fri, 16 Aug 2024 12:22:34 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1723803754; bh=XShuKgdLfeU0mTI3oWdCgwlF4xHM6PgUQkBt5ZdxgxY=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=DSKJiLLdLRwxY7yY1V5+XTaTAjzJhQLZrpEoOQ87Bji1c6iuGIokQKgsOksRwUBAM N5d52DIxcHCt0hurInvs5jLzRUbX2MKW6XosARmmAd2fHUFuRXGu2Itejrdlowue5C sGcawyPgx+uIiCyPvI68Qsls6VOtaCTxunig/4SAfLzrLQhnxOyxrTMFIgYdpKs/9k hUfk9yvs/iBN6YUCR5owS++7etKVM1p9AcdMEoFLmG/MAueMiRcNEb1ShZ2y/8JDTr nTXO0msMFHrh4qDUDxx6zYgvYBKulfR21VIHOqHtx6XGN04tCKZ3ZESru5zaGkM/mA JGKJUFZNpeOaQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 16 Aug 2024 12:22:34 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v2 10/10] fortran: Add -finline-intrinsics flag for MINLOC/MAXLOC [PR90608] Date: Fri, 16 Aug 2024 12:22:27 +0200 Message-ID: <20240816102227.189290-11-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240816102227.189290-1-morin-mikael@orange.fr> References: <20240816102227.189290-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-10.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE 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 This patch is new in the V2 series. Regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Introduce the -finline-intrinsics flag to control from the command line whether to generate either inline code or calls to the functions from the library, for the MINLOC and MAXLOC intrinsics. The flag allows to specify inlining either independently for each intrinsic (either MINLOC or MAXLOC), or all together. For each intrinsic, a default value is set if none was set. The default value depends on the optimization setting: inlining is avoided if not optimizing or if optimizing for size; otherwise inlining is preferred. There is no direct support for this behaviour provided by the .opt options framework. It is obtained by defining three different variants of the flag (finline-intrinsics, fno-inline-intrinsics, finline-intrinsics=) all using the same underlying option variable. Each enum value (corresponding to an intrinsic function) uses two identical bits, and the variable is initialized with alternated bits, so that we can tell whether the value was left initialized by checking whether the two bits have different values. PR fortran/90608 gcc/ChangeLog: * flag-types.h (enum gfc_inlineable_intrinsics): New type. gcc/fortran/ChangeLog: * invoke.texi(finline-intrinsics): Document new flag. * lang.opt (finline-intrinsics, finline-intrinsics=, fno-inline-intrinsics): New flags. * options.cc (gfc_post_options): If the option variable controling the inlining of MAXLOC (respectively MINLOC) has not been set, set it or clear it depending on the optimization option variables. * trans-intrinsic.cc (gfc_inline_intrinsic_function_p): Return false if inlining for the intrinsic is disabled according to the option variable. gcc/testsuite/ChangeLog: * gfortran.dg/minmaxloc_18.f90: New test. * gfortran.dg/minmaxloc_18a.f90: New test. * gfortran.dg/minmaxloc_18b.f90: New test. * gfortran.dg/minmaxloc_18c.f90: New test. * gfortran.dg/minmaxloc_18d.f90: New test. --- gcc/flag-types.h | 30 + gcc/fortran/invoke.texi | 24 + gcc/fortran/lang.opt | 27 + gcc/fortran/options.cc | 21 +- gcc/fortran/trans-intrinsic.cc | 13 +- gcc/testsuite/gfortran.dg/minmaxloc_18.f90 | 772 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/minmaxloc_18a.f90 | 10 + gcc/testsuite/gfortran.dg/minmaxloc_18b.f90 | 10 + gcc/testsuite/gfortran.dg/minmaxloc_18c.f90 | 10 + gcc/testsuite/gfortran.dg/minmaxloc_18d.f90 | 10 + 10 files changed, 922 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_18.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_18a.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_18b.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_18c.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_18d.f90 diff --git a/gcc/flag-types.h b/gcc/flag-types.h index 1e497f0bb91..df56337f7e8 100644 --- a/gcc/flag-types.h +++ b/gcc/flag-types.h @@ -451,6 +451,36 @@ enum gfc_convert }; +/* gfortran -finline-intrinsics= values; + We use two identical bits for each value, and initialize with alternated + bits, so that we can check whether a value has been set by checking whether + the two bits have identical value. */ + +#define GFC_INL_INTR_VAL(idx) (3 << (2 * idx)) +#define GFC_INL_INTR_UNSET_VAL(val) (0x55555555 & (val)) + +enum gfc_inlineable_intrinsics +{ + GFC_FLAG_INLINE_INTRINSIC_NONE = 0, + GFC_FLAG_INLINE_INTRINSIC_MAXLOC = GFC_INL_INTR_VAL (0), + GFC_FLAG_INLINE_INTRINSIC_MINLOC = GFC_INL_INTR_VAL (1), + GFC_FLAG_INLINE_INTRINSIC_ALL = GFC_FLAG_INLINE_INTRINSIC_MAXLOC + | GFC_FLAG_INLINE_INTRINSIC_MINLOC, + + GFC_FLAG_INLINE_INTRINSIC_NONE_UNSET + = GFC_INL_INTR_UNSET_VAL (GFC_FLAG_INLINE_INTRINSIC_NONE), + GFC_FLAG_INLINE_INTRINSIC_MAXLOC_UNSET + = GFC_INL_INTR_UNSET_VAL (GFC_FLAG_INLINE_INTRINSIC_MAXLOC), + GFC_FLAG_INLINE_INTRINSIC_MINLOC_UNSET + = GFC_INL_INTR_UNSET_VAL (GFC_FLAG_INLINE_INTRINSIC_MINLOC), + GFC_FLAG_INLINE_INTRINSIC_ALL_UNSET + = GFC_INL_INTR_UNSET_VAL (GFC_FLAG_INLINE_INTRINSIC_ALL) +}; + +#undef GFC_INL_INTR_UNSET_VAL +#undef GFC_INL_INTR_VAL + + /* Inline String Operations functions. */ enum ilsop_fn { diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 6bc42afe2c4..53b6de1c92b 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -194,6 +194,7 @@ and warnings}. -finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero -finit-derived -finit-logical=@var{} -finit-real=@var{} +-finline-intrinsics[=<@var{minloc},@var{maxloc}>] -finline-matmul-limit=@var{n} -finline-arg-packing -fmax-array-constructor=@var{n} -fmax-stack-var-size=@var{n} -fno-align-commons -fno-automatic @@ -1994,6 +1995,29 @@ geometric mean of the dimensions of the argument and result matrices. The default value for @var{n} is 30. +@opindex @code{finline-intrinsics} +@item -finline-intrinsics +@itemx -finline-intrinsics=@var{intr1},@var{intr2},... +Usage of intrinsics can be implemented either by generating a call to the +libgfortran library function implementing it, or by directly generating the +implementation code inline. For most intrinsics, only a single of those +variants is available and there is no choice of implementation. For some of +them, however, both are available, and for them the @code{-finline-intrinsics} +flag permits the selection of inline code generation in its positive form, or +library call generation in its negative form @code{-fno-inline-intrinsics}. +With @code{-finline-intrinsics=...} or @code{-fno-inline-intrinsics=...}, the +choice applies only to the intrinsics present in the comma-separated list +provided as argument. + +For each intrinsic, if no choice of implementation was made through either of +the flag variants, a default behaviour is chosen depending on optimization: +library calls are generated when not optimizing or when optimizing for size; +otherwise inline code is preferred. + +The set of intrinsics permitting the choice of implementation variant through +@code{-finline-intrinsics} is currently limited to non-scalar @code{MAXLOC} and +@code{MINLOC}. + @opindex @code{finline-matmul-limit} @item -finline-matmul-limit=@var{n} When front-end optimization is active, some calls to the @code{MATMUL} diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 5cf7b492254..ac08a851da4 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -676,6 +676,33 @@ finline-arg-packing Fortran Var(flag_inline_arg_packing) Init(-1) -finline-arg-packing Perform argument packing inline. +finline-intrinsics +Fortran RejectNegative Enum(gfc_inlineable_intrinsics) Var(flag_inline_intrinsics, GFC_FLAG_INLINE_INTRINSIC_ALL) Undocumented + +fno-inline-intrinsics +Fortran RejectNegative Enum(gfc_inlineable_intrinsics) Var(flag_inline_intrinsics, GFC_FLAG_INLINE_INTRINSIC_NONE) Undocumented + +finline-intrinsics= +Fortran Joined Var(flag_inline_intrinsics) Enum(gfc_inlineable_intrinsics) Init(GFC_FLAG_INLINE_INTRINSIC_ALL_UNSET) EnumSet +Enable generation of inline code instead of calls to functions from the library to implement intrinsics. + +Enum +Name(gfc_inlineable_intrinsics) Type(int) UnknownError(%qs is not an inline-controlable intrinsic) + +; This is not part of any set +; EnumValue +; Enum(gfc_inlineable_intrinsics) String(none) Value(GFC_FLAG_INLINE_INTRINSIC_NONE) + +EnumValue +Enum(gfc_inlineable_intrinsics) String(maxloc) Value(GFC_FLAG_INLINE_INTRINSIC_MAXLOC) Set(1) + +EnumValue +Enum(gfc_inlineable_intrinsics) String(minloc) Value(GFC_FLAG_INLINE_INTRINSIC_MINLOC) Set(2) + +; This is not part of any set +; EnumValue +; Enum(gfc_inlineable_intrinsics) String(all) Value(GFC_FLAG_INLINE_INTRINSIC_ALL) + finline-matmul-limit= Fortran RejectNegative Joined UInteger Var(flag_inline_matmul_limit) Init(-1) -finline-matmul-limit= Specify the size of the largest matrix for which matmul will be inlined. diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index d8c5c8e62fc..6f2579ad9de 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -472,7 +472,26 @@ gfc_post_options (const char **pfilename) /* Implement -fno-automatic as -fmax-stack-var-size=0. */ if (!flag_automatic) flag_max_stack_var_size = 0; - + + /* Decide inlining preference depending on optimization if nothing was + specified on the command line. */ + if ((flag_inline_intrinsics & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) + == GFC_FLAG_INLINE_INTRINSIC_MAXLOC_UNSET) + { + if (optimize == 0 || optimize_size != 0) + flag_inline_intrinsics &= ~GFC_FLAG_INLINE_INTRINSIC_MAXLOC; + else + flag_inline_intrinsics |= GFC_FLAG_INLINE_INTRINSIC_MAXLOC; + } + if ((flag_inline_intrinsics & GFC_FLAG_INLINE_INTRINSIC_MINLOC) + == GFC_FLAG_INLINE_INTRINSIC_MINLOC_UNSET) + { + if (optimize == 0 || optimize_size != 0) + flag_inline_intrinsics &= ~GFC_FLAG_INLINE_INTRINSIC_MINLOC; + else + flag_inline_intrinsics |= GFC_FLAG_INLINE_INTRINSIC_MINLOC; + } + /* If the user did not specify an inline matmul limit, inline up to the BLAS limit or up to 30 if no external BLAS is specified. */ diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index b03f7b1653e..456f28eba4e 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11840,10 +11840,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) gfc_actual_arglist *args, *dim_arg, *mask_arg; gfc_expr *maskexpr; - if (!expr->value.function.isym) + gfc_intrinsic_sym *isym = expr->value.function.isym; + if (!isym) return false; - switch (expr->value.function.isym->id) + switch (isym->id) { case GFC_ISYM_PRODUCT: case GFC_ISYM_SUM: @@ -11879,8 +11880,12 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) case GFC_ISYM_MINLOC: case GFC_ISYM_MAXLOC: { - /* Disable inline expansion if code size matters. */ - if (optimize_size) + if ((isym->id == GFC_ISYM_MINLOC + && (flag_inline_intrinsics + & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0) + || (isym->id == GFC_ISYM_MAXLOC + && (flag_inline_intrinsics + & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0)) return false; gfc_actual_arglist *array_arg = expr->value.function.actual; diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_18.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_18.f90 new file mode 100644 index 00000000000..e8cd2d42d8d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_18.f90 @@ -0,0 +1,772 @@ +! { dg-do compile } +! { dg-additional-options "-O -fdump-tree-original" } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } } +! +! PR fortran/90608 +! Check that all MINLOC and MAXLOC calls are inlined with optimizations by default. + +subroutine check_maxloc_without_mask + implicit none + integer, parameter :: data5(*) = (/ 1, 7, 2, 7, 0 /) + integer, parameter :: data64(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, & + 4, 4, 1, 7, 3, 2, 1, 2, & + 5, 4, 6, 0, 9, 3, 5, 4, & + 4, 1, 7, 3, 2, 1, 2, 5, & + 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, & + 6, 0, 9, 3, 5, 4, 4, 1, & + 7, 3, 2, 1, 2, 5, 4, 6 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine +end subroutine check_maxloc_without_mask +subroutine check_minloc_without_mask + implicit none + integer, parameter :: data5(*) = (/ 8, 2, 7, 2, 9 /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine +end subroutine check_minloc_without_mask +subroutine check_maxloc_with_mask + implicit none + integer, parameter :: data10(*) = (/ 7, 4, 7, 6, 6, 4, 6, 3, 9, 8 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, & + 4, 4, 1, 7, 3, 2, 1, 2, & + 5, 4, 6, 0, 9, 3, 5, 4, & + 4, 1, 7, 3, 2, 1, 2, 5, & + 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, & + 6, 0, 9, 3, 5, 4, 4, 1, & + 7, 3, 2, 1, 2, 5, 4, 6 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_true_mask + call check_int_const_shape_rank_3_false_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_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_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_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask +contains + subroutine check_int_const_shape_rank_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_maxloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_maxloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_maxloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_maxloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + end subroutine +end subroutine check_maxloc_with_mask +subroutine check_minloc_with_mask + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 3, 3, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_rank_3_true_mask + call check_int_const_shape_rank_3_false_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_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_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_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask +contains + subroutine check_int_const_shape_rank_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_minloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_minloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_minloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_minloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + end subroutine +end subroutine check_minloc_with_mask diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_18a.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_18a.f90 new file mode 100644 index 00000000000..362d1765c89 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_18a.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-additional-files "minmaxloc_18.f90" } +! { dg-additional-options "-Os -fdump-tree-original" } +! { dg-final { scan-tree-dump-times "gfortran_\[sm\]?minloc" 30 "original" } } +! { dg-final { scan-tree-dump-times "gfortran_\[sm\]?maxloc" 30 "original" } } +! +! PR fortran/90608 +! Check that all MINLOC and MAXLOC intrinsics use the implementation provided +! by the library when optimizing for size. +include "minmaxloc_18.f90" diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_18b.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_18b.f90 new file mode 100644 index 00000000000..068c941110f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_18b.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-additional-files "minmaxloc_18.f90" } +! { dg-additional-options "-O2 -fno-inline-intrinsics=minloc -fdump-tree-original" } +! { dg-final { scan-tree-dump-times "gfortran_\[sm\]?minloc" 30 "original" } } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } } +! +! PR fortran/90608 +! Check that -O2 enables inlining and -fno-inline-intrinsics selectively +! disables it. +include "minmaxloc_18.f90" diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_18c.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_18c.f90 new file mode 100644 index 00000000000..47fe54e20a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_18c.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-additional-files "minmaxloc_18.f90" } +! { dg-additional-options "-O3 -fno-inline-intrinsics=maxloc -fdump-tree-original" } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } } +! { dg-final { scan-tree-dump-times "gfortran_\[sm\]?maxloc" 30 "original" } } +! +! PR fortran/90608 +! Check that -O3 enables inlining and -fno-inline-intrinsics selectively +! disables it. +include "minmaxloc_18.f90" diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_18d.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_18d.f90 new file mode 100644 index 00000000000..eb530f69a2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_18d.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-additional-files "minmaxloc_18.f90" } +! { dg-additional-options "-O0 -finline-intrinsics=maxloc -fdump-tree-original" } +! { dg-final { scan-tree-dump-times "gfortran_\[sm\]?minloc" 30 "original" } } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } } +! +! PR fortran/90608 +! Check that -O0 disables inlining and -finline-intrinsics selectively +! enables it. +include "minmaxloc_18.f90"