From patchwork Fri Aug 23 08:31:41 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975930 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=OHXIkodv; 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 4Wqtjb70s0z1yXY for ; Fri, 23 Aug 2024 18:37:23 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 403543882123 for ; Fri, 23 Aug 2024 08:37:22 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-210.smtpout.orange.fr [193.252.23.210]) by sourceware.org (Postfix) with ESMTPS id 2C45B3839DC6; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2C45B3839DC6 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 2C45B3839DC6 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.210 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401924; cv=none; b=CptgbRA6QuUW8etKEmyGUFG0d4aA3dxJgZ7rUUXTOGWJXwePnaG/P7oczN8jL48X0VkblnOnBEByEaoVTGcxM03p/aK0LKdNSJk08+MpaG9tWiAjOVCeqIfwhvcK1aLK3yHsQquITGPGY8F4qFma6q3Ru8ALRyi0BZm8++I1y3Y= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401924; c=relaxed/simple; bh=lqj4215wh+myXQZQyDQ9UKoN4TDdhOnWWNDgTkNHvrg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=mMpzJyZlOfgz/zPc7DwcAu8H47dDrI2wVmpFEtZ8ulcnTDy+H4Mg2L4aaca5QT3DLVJiIo/J0fXL/A/lWZalo4WLf0ElyHrHMBzwxzDhooh0kaselwlz4dx2WBPRA35jkx22k/wNmt8SlTONL8y+3g2PAZuuo6MHdkO8xwHEPYg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi7sjylk; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=E0oyB+4lwLkeq8EMfwHZXX9AM6E2J2qRi2DJmlQn9bI=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=OHXIkodv2mMYmqlOCvwfUxxD3iFEQxxO5uIfY8ei1sWgkJ4trrxB/8OuD7zd7sly1 O79yxMgxtguU8hqJeNqsMJ/376UANgKAr7lsWrHCOYV4jO3fKJBkoZnBCgoS+u1lD6 UNAdTS1yBYJ8+k+XWDw2hL2NyStP3oHXwMjfMI5/FOoeyRgkYaBPevrb9edp/Ro/sj Ydy3swCUDx16I5RAKFIDYaSw/ivqG7r/eQomcX0xdgDqUIphXB/nQC8a2VYNo62riU u5/BTumxIt8fBYcxpWSKwaTHwDN3GiNEtVSYvYi85UKmU6FMBGyfpZ2DPhUk99RRuA w1N+o8pZF4aaA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 01/10] fortran: Add tests covering inline MINLOC/MAXLOC without DIM [PR90608] Date: Fri, 23 Aug 2024 10:31:41 +0200 Message-ID: <20240823083150.149099-2-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, 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 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 23 08:31:42 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975925 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=U8weMhVH; 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 4Wqtdj2cSRz1yNm for ; Fri, 23 Aug 2024 18:34:01 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2F327388217B for ; Fri, 23 Aug 2024 08:33:59 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-71.smtpout.orange.fr [80.12.242.71]) by sourceware.org (Postfix) with ESMTPS id 2159E3877039; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2159E3877039 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 2159E3877039 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.71 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401919; cv=none; b=qCnFEv7rQ96bVAABHQUgxYa2hN8e+qKly4lNYJK+8cY0aSFy15J7q2P6wHOFpwxBHo73p9L+3sKDd2CTPgcUiCSW92KCPJNu588qXKBIsGhm2tWEzXSSCzUA7J+UC+3ZBeQzlbtQ/NOwPatPScPQY1Pe6GDT1lWwUeu9RrVBCXM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401919; c=relaxed/simple; bh=m6wms5SwPQl0/ntqh2YbXu0ckr5jVoRpdH36Nwxkwn4=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=GATSNhjvqnX2GxNlVWWNoUhEWgzcCLEPZAh7nhgnuJgdTJpJGZPv8HnW6up2rcAPNBenjZhEK/Pjp+O/HRgx+o6/pDLKfq1QOK1QkI1jFhqnVtRBXhxzOIicz73dmNJdmGlI6oOydCN6hXJHgeWn66YsrrdVU4anAli0sZjMHtE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjyln; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=lpUdpjV+R/MBbTDYC3gEOegNrte1RMB+pKDAO4JBaAk=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=U8weMhVHbF53f7K51j2uUgIT/X0wWcrwRrw4UjRlJOTcbznQ8Y43Bno4ucXsLoSjJ Y2dn3rixOhilNwLdXTZNOL9QOIPhVzSJAPEx1ub25mk5BihwCxUWFNTKOPpXPpM8ZK jgjcw4JgkNshxmq+cunteYUX92XLEvPdSRnZOHcAlqt6HIpO7V1AwESFaAVxzAnIGn nrp++JS/ibcwmbShPbYiMDSm2L8V+f+vTvFF4Pu+dw+9MSi+DF8whc5nQvXxuMFxfO RDYfbI9EK9Kyhk5QBmcPpvtXUNxUYghFlvw3jKICGeCdF7YhxA5wO9dAAxg+5A+QeN ouxSW4yHpWJcg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 02/10] fortran: Disable frontend passes for inlinable MINLOC/MAXLOC [PR90608] Date: Fri, 23 Aug 2024 10:31:42 +0200 Message-ID: <20240823083150.149099-3-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-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 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 104ccb1a4c1..f7f49eea617 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -2281,7 +2281,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 0632e3e4d2f..cf5c8e63a9f 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11662,6 +11662,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 23 08:31:43 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975928 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=LB8TYFJg; 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 4WqtgC5br8z1ydn for ; Fri, 23 Aug 2024 18:35:19 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 033603882124 for ; Fri, 23 Aug 2024 08:35:18 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-17.smtpout.orange.fr [80.12.242.17]) by sourceware.org (Postfix) with ESMTPS id 467E53875446; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 467E53875446 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 467E53875446 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.17 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; cv=none; b=Sx9/bBfgH7JrODHvZI4J8xnbA/K7e6vm0w9LhlDUHDFR63Mj1XLLyu1y5zQtFSjhSy+mgkpdrgj0Sa5WWfv6uJTF2q0BA4UH03Pc2TGQv9Wi45F+YrF48tYYPW8F/2b1G3thK2rfIqZoI3u6pVZNE535+QFI5BaD0Fg7fKpKC5g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; c=relaxed/simple; bh=hTMC6n7PFsVRVtZozd1OGog3Ig6HNyy5Dt/K5iqyl2U=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=jrDsODMjAB81T/c3EmiFbCgmJ2MX5r2869suWnCRGi0aiu6wPATPJzklqIexreLAOAg0jQ5v6xUpjiXWtXLRJNq1iJefrDB/FPNjYx+zQcKjg3r3SUXWA41Z0DdDLYKoy/RHLbCIAcYsasfap4CSxoDB7J4OHoC6AVB1pOBTRW0= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjylp; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=RYlwqkyJEmC3ixGsOzgJhC2/REG57WE7Co9ivXcbemU=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=LB8TYFJgx6fIsL8x9buHnbOuhphCCqwIwZGFBjammRaBmNJtBdIYafjQLIQQjSDcN l3j6yRV8t49cI0vN5WcqwT5zddQcrY0LD0djnYFdFZDhZxTG7Qo99spLMauB+SjMWC pjPVWtLH/g9tgmAsgh3W2d1K9jKNiZA83b/1PW6EV5qiWqsU/Q3wDgF8nOicpnh6Zg P15kN0EGfKsZE9fUjPOIBnVxSRbCODyZ25mRhpk/ucrEe/XM9V2z2mtxWSSU64bm+a MVojZJ17DBDrssZjf+wXhSm01ESKJgGAelmfHZg1tXBqWfR9jQ0e0c3d3peN5CKCey 5i41jFfg5Pipw== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 03/10] fortran: Inline MINLOC/MAXLOC with no DIM and ARRAY of rank 1 [PR90608] Date: Fri, 23 Aug 2024 10:31:43 +0200 Message-ID: <20240823083150.149099-4-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-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, RCVD_IN_MSPIKE_H3, 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 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 ea5fff2e0c2..3c4831b6089 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 cf5c8e63a9f..695c3591837 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5276,66 +5276,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 @@ -5349,7 +5378,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) @@ -5380,6 +5409,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; @@ -5395,8 +5425,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; @@ -5422,10 +5463,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); @@ -5831,7 +5891,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. */ @@ -11547,6 +11618,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) { @@ -11560,6 +11644,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 (); } @@ -11579,6 +11667,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; @@ -11670,16 +11760,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 23 08:31:44 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975923 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=pJTRZvWT; 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 4WqtcZ6j1Rz1yNm for ; Fri, 23 Aug 2024 18:33:02 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C1422388211C for ; Fri, 23 Aug 2024 08:33:00 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (out-68.smtpout.orange.fr [193.252.22.68]) by sourceware.org (Postfix) with ESMTPS id 7BE47386F82C; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 7BE47386F82C 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 7BE47386F82C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.22.68 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401919; cv=none; b=SR3L/c3dpjRPh85zSiB0A2Wzo6mCJJgRt+l0uq8SNmdim+FkzRa5onXMNKf0yk/wLowRK+fhpjsHolC5zVitnaCUv2r2U2sH1RIUavM7URdW2Ag4DG7udHk2qalu0n+GdIv3fGx2HbpFZlws3DGgZgXO8395XdVtZmXsTUYIqE4= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401919; c=relaxed/simple; bh=nxEIIjvuo7LGZiH4tbdy4kC+yx7wLCZ1LdcNVE3B+DI=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=W30KZrjlvtGxIGibwmPepS0SMdpr6FTc7CuJGTxGRNguYy3QzDfVTpifttYnMIo4PSufO28ODQjvZ7fck06jbHfPulrGhz/QioEJZx70ClgPoEoIRRC5qt2kz5RStE+JzSfQdtO70L3oJ4bexg7NVyNGjW3bxvuW+LeF6Vt36PE= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjylr; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=hkih2jMYnngVl+ERg+2VZKENHlvFyHHeHPbnpPC+HTg=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=pJTRZvWTnpWQKrZzTBFQ153Dkx1fGolYULtsggGSTsbI0/OAFp3rR+0qbnv7LzMl9 GJmQxJh5qjlkv/pksVKJ1xPOVo+c7nVTxRfP0vDs2jdUSwyTaGxr4nOY5Q5Lxm2jdx 8Kun99K5La+xjg/vyF8Hqsm6nkmGFDLYptsgyppULQs6y1LOAysD05v3ohE7Cxo1wv iQVrOFnHVj6uKKfbXHrk/KaNfSY/IieVwuxCElX6HYIzLiCD5l8URj4h52s0GkHVqs 99guYyJvxEcIElgZc+kYVKBFE05l+vhyvWQCUyXLkTlx4sPALc6jT1zx6uZDDPTvHF E63E75IdXp/Xg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 04/10] fortran: Remove MINLOC/MAXLOC frontend optimization Date: Fri, 23 Aug 2024 10:31:44 +0200 Message-ID: <20240823083150.149099-5-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-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, 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 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 | 58 ---------------------------------- 1 file changed, 58 deletions(-) diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index f7f49eea617..c7cb9d2a389 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 --; @@ -2266,52 +2254,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->corank = 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 23 08:31:45 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975924 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=eMeBGuFQ; 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 4Wqtcj64thz1yNm for ; Fri, 23 Aug 2024 18:33:09 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id DE0253882065 for ; Fri, 23 Aug 2024 08:33:07 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-209.smtpout.orange.fr [193.252.23.209]) by sourceware.org (Postfix) with ESMTPS id 9B8113875DDF; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 9B8113875DDF 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 9B8113875DDF Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.209 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; cv=none; b=XQDbcXUXzCr5gidaG39+xMHCY3DyhoG7/AYq6RS34I81pxehcPmkEKhJ0CsSxCjb7oVbNQROg6Z/4+/v8uaBbhRE2ScGj+8JHhBKe3PrXuOR2HApe6yWiTUfhyRORbFykAV2OQfhTjK9BlLntJSiqN4JI5D8sGCWh4PWH1irKR0= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; c=relaxed/simple; bh=gQzorUT1zOm/TYDvVEAaSK4TqLSz/d/s0AD5kALNs5w=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=q97k7W4JxgTfAQ5HEcUaDXEswfCHoHoYHiGMRPywYV9iZReL/znWvrFYXwH3io/ya+dDpbBX6GfGAZiuKdu7zg+iZMyqtmTwN634g2eYZaHBblxFFBeERhLecdloUbn9To3V0skJnhzUm8EiXf0vXCcVL2z2Gf8EtwIPVCHkVPY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjym2; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=IZryzQpnzJmj1bTE0rw6eUHmjfEqw4sdad9dV2308KM=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=eMeBGuFQtEqa0BWCwq6pnlhxKU1Oxv5WWcVZ5mhboHzRQ1cQF7kraZXRd4iEa+e2I oYYGu3IEmvAj3zRRa5VDTCYjb1/hsQd3pVzaHCA5Wpd4NWYDA2c2wL0Fg8zR9gmN4s jr6lewyfEL4TXbryXTI4zDctaeuqkL1mKvem+zmqqvXeLjpVSu8HpJefEp7pLiyq82 v+a2RAMLP11ujmWAbJt9sHdsrMwENCiyZR8+5Bb7xquxZgG7EmyLpGea0ETUgcDwWD nxSqkMjBjx4hP98C/xHVX1YgPqEGDIXvmtd105aqxpmZNuR/HK55i1W65jasIa4XTS bNv2f6PX8qpBg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 05/10] fortran: Outline array bound check generation code Date: Fri, 23 Aug 2024 10:31:45 +0200 Message-ID: <20240823083150.149099-6-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 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. -- >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 3c4831b6089..bc5f5900c6a 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 23 08:31:46 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975927 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=WNM/3jSs; 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 4Wqtg02Zw8z1ybW for ; Fri, 23 Aug 2024 18:35:08 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 87AAB3882121 for ; Fri, 23 Aug 2024 08:35:06 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-17.smtpout.orange.fr [80.12.242.17]) by sourceware.org (Postfix) with ESMTPS id A3211388182C; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A3211388182C 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 A3211388182C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.17 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; cv=none; b=GKmtwR7xmSAKThTQRDvQdHD+nl2UCj8a4WwtuNQbZLd4KxqcuUwTXjalLACSOIHUP3vAUFoYEqNKwvG5baVT+pJP5Gxi0muCzrKGW6vyEUa7hqZN8UEZz8Jz1Ka0h60juiVuOhkmydo2MfqBME0FQ1OmOK8hFt2HYSAje4nt2Uw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; c=relaxed/simple; bh=vuvfyRBQH0+nTbnp7qQfUmJc1DVrQLArUqiCSfhyJ14=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=dsZzv2A8yaG/u34MUPKcDdO37sNeCQECmhjNKqasqi4bIXLVXot0iUlXUOOsJpNCaAuQPV6LHeu4dqRY1pchjR8sFXigZ/R6tqXp3NU58ho6VzvlHToeOm7zZvk8+iynIuT5V5hpKYeRG8JGhQFVcKVPUz3YKOP/56dcoeZiqoQ= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjymL; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=7tIhqriVUcADxv6VlC80s2oPeDgqLoRGoh+qVwZ4nW4=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=WNM/3jSsoViBYGypuc0cW80F68d0WMzzwn54n9gOdEnhPdEnaDWoiVc3AYvRWVyHO 8oggCbMwQOc0OH34JNfwKcR5R2wUidiWIHkGYl0KZde8aDmkDQesMb+dLKEbxWSg91 NeadI4QgRQEGCu6dbzatHYcmEJN9IKP2adA++7+CkV/DK1dnGfWaHu9isRUGLStlCF H6OiURj3AIge00HBGXYex7oVuiPzxGsWdBKtqTl96jXK42DZi+BcodgqJJsjYJXXPX 35TrOC5Uc5/xr1rOE+Wg8/mVRuG/zCHG4njtwuHsLr0DLiBOdhOwyJjWe9dI5wmPiR L/mwGuBxmvrxQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 06/10] fortran: Inline integral MINLOC/MAXLOC with no DIM and no MASK [PR90608] Date: Fri, 23 Aug 2024 10:31:46 +0200 Message-ID: <20240823083150.149099-7-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-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, RCVD_IN_MSPIKE_H3, 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 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 bc5f5900c6a..bb694371b47 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 695c3591837..1215cd89630 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5361,9 +5361,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. @@ -5377,8 +5398,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) @@ -5393,7 +5414,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; @@ -5408,7 +5429,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; @@ -5476,7 +5497,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); @@ -5484,8 +5505,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); @@ -5604,10 +5630,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; @@ -5617,14 +5659,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); @@ -5633,11 +5679,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) @@ -5678,20 +5727,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)); @@ -5755,13 +5807,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); @@ -5798,9 +5852,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); @@ -5863,6 +5917,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); @@ -5877,7 +5932,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); @@ -5891,18 +5946,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. */ @@ -11760,8 +11819,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)) @@ -11770,6 +11833,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 23 08:31:47 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975922 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=PEk4hFlJ; 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 4WqtcX25T8z1yNm for ; Fri, 23 Aug 2024 18:33:00 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 85E99388216F for ; Fri, 23 Aug 2024 08:32:58 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-71.smtpout.orange.fr [80.12.242.71]) by sourceware.org (Postfix) with ESMTPS id D04333881869; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D04333881869 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 D04333881869 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.71 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; cv=none; b=anb2Dp1p/6Pb5Soha1J0/FNdmRzbOwDgpfQg3iA/FwO8vefHaTawbF6IUf+opcrwdstuMtYMvIn0eNDZNx6G5Dcc2QRSbgQJLgYG4ykqs1aMiot2ujL98SYO8PaOtYnu90qqNRMYuwDKGD2TPJvCZYPC+jjsw84qgoBpZyc8Pyg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401921; c=relaxed/simple; bh=hAArn0WTNRFYV6lMsslKvyxf29qW5kipDJe4mVCK1kk=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=jEeqV/qjn9+FpMFgBJTZY1ff5kETbSwjO0UDfYr327+2ewxIf7BbhY3pC1jmuSyuAS/Idj03ABMfaPtxwB8FfAHMxaAExJAhjxTmcY9cMRcLMnoVXzhnVeApLW2/XwefVZdQTktddIj8iYu95cacjB4hl5IxI42kOYHuaIXGnE0= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi8sjymX; Fri, 23 Aug 2024 10:31:57 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401917; bh=P16SFns3iKb8xNdq8SO7o5Cis6uz8DSyCkSAPYt6OTM=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=PEk4hFlJYVL4CR4rGVQQFh87+NcWajx2x8LN8ROhSbke1U0BoFlq9km07cCFzlo1/ zeUkMObbmVEj23vb4yXn1qrM/07hf6t3Fi9bsDI7uoEPUk8A36PEnrROLzZOkao4pT zMe3d6QOntVqRqfE69/08Kx/7/Vijujbk66mW7pwBKjPgm/g/ufBfbEPeqI6QALQdI mqJRDe/7yIkdT0IqyHsf0++D3fhW01eDfzHM62kTd0LyZgmQ6kPBaJZbUJ0Jf6SAaz FxP+9HRZkIN9f61uv65vE5DB5MK2n+IXgVjostvDRxw1uQQ/lyY45DsA02XYK8rS3+ 7if3SMHK63XIQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:57 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 07/10] fortran: Inline integral MINLOC/MAXLOC with no DIM and scalar MASK [PR90608] Date: Fri, 23 Aug 2024 10:31:47 +0200 Message-ID: <20240823083150.149099-8-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-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 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 1215cd89630..45f5a7b6977 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5917,7 +5917,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); @@ -5932,7 +5931,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); @@ -11833,9 +11833,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 23 08:31:48 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975929 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=jJRIwOBg; 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 4WqthN0Dpmz1ydn for ; Fri, 23 Aug 2024 18:36:20 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D8B063882104 for ; Fri, 23 Aug 2024 08:36:17 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-70.smtpout.orange.fr [80.12.242.70]) by sourceware.org (Postfix) with ESMTPS id 012393839DD6; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 012393839DD6 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 012393839DD6 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.70 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; cv=none; b=cBrinEfQOnT/m2GOxqpxKC2w+pkJv7LSVHT/UEsDqPicyP9+vIucQcU/MLa0LJH7PRqACEpZWOKSRVKJTeiFMQLxJlAAWr8/0XWdT+QokopZXXtkIFA0p+feMZNJD/5+3Ic8b90gRsANh73q14T3+VAne50Noyj8Jh61CAGuj4U= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; c=relaxed/simple; bh=4wpOH3DfxA+AqhVqSiJqUiMNjx016rxRDaDgztodmNM=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Fq0VMEzVwfde6k7m30XYHvvkV7ODsG1RqUUsSdu58od8zArV4jfqCTZogJpHznp7+pcZmjnABkmoP81ExYlt7urVZYIIGxQBAx0/81FpZUofxAdypD1w4DU6z+iH/AXx9U+46nAcAxb+vSyEegU+vvHPVbsDqIl/3lOrZCnlSYU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi9sjyms; Fri, 23 Aug 2024 10:31:57 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401917; bh=JC1Gs3xhnLk89JsrHJCXi+MTzoClftaTrdSFGuPYsn4=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=jJRIwOBgpEpV3C0P49eFZB80YRqPfIdTvqRlKHW6DHYv4Q54oL/U/uk21PMzdaxfx DlLgfEeR7l54IBVWpJwfnUGx/o6G72mXSymUr46iOfosT2gXQECYzRj6nHSHlSFkFk DigiPA7qThUp/QDQXT7TKRKK4K1KIjXacAcrWp91eoq3owVGSXF1Y9qT3pQmPLzMGG g98I8ccFyD3Tb7ILfm+3wqKFT24QgZ0MW6G8sEpNsDXlkiEL+3lWZjlAhPAOhT9Hkf AKV8L23/bFRZImmxPT/KsL6wSCFKDhVqbTZMQic/CHn/jIxZxcMemVC81FzSnT9Pnh cx/yZrpCFxBew== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:57 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 08/10] fortran: Inline non-character MINLOC/MAXLOC with no DIM [PR90608] Date: Fri, 23 Aug 2024 10:31:48 +0200 Message-ID: <20240823083150.149099-9-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 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, 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 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 45f5a7b6977..3d29bcaf590 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5361,12 +5361,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; @@ -5384,7 +5427,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. @@ -5615,18 +5658,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); @@ -5669,8 +5705,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); @@ -5727,10 +5763,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, @@ -5807,23 +5847,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) @@ -5852,9 +5898,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); @@ -5904,9 +5953,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); @@ -11820,11 +11866,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)) @@ -11833,12 +11877,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 23 08:31:49 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975926 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=cXelFSSi; 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 4WqtfD3Lc7z1yNm for ; Fri, 23 Aug 2024 18:34:28 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4D7A238754AB for ; Fri, 23 Aug 2024 08:34:26 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-18.smtpout.orange.fr [80.12.242.18]) by sourceware.org (Postfix) with ESMTPS id 5A2723882052; Fri, 23 Aug 2024 08:31:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 5A2723882052 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 5A2723882052 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.18 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; cv=none; b=SStOVzMn20NEzsuR4/Fu0MkKSygGDufTnGMgRa2m26/ubRNHP4f/ZB8nKsveVAn8y9zDUW6lptMh0K/UC6UhmnLCH+go5x2HWdMweXy8ASjbVYEiQaLA/e+6pOqGik14gXP7VsNO/+o7YL2r9ZAFLeKC5hQcZym+sU/kMzZ3lFQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401923; c=relaxed/simple; bh=rRI87S/rJSM0M99U3WGD7mvhCMD3QjTCVt8bYcZrPyc=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=hAEpCcqG1ToptGq5tViEq/rjbriW+WomlulDY9RtUozdAKkroz++z+HN4W6hjoV0qUf+NFbPKIsPU92AJHuqWhBmStR3l+B2WE7NAYAjSyiPlDNkrZpfNpMqnjvFORx3NBmpuOHeiHVtHY9TgjrNfDHvzAA3NsEUOE/VWM2X+34= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi9sjyn1; Fri, 23 Aug 2024 10:31:57 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401917; bh=UKi0rC3MXCf3nVbepFA/8CKOkCnSx65XzDzZXzA+isY=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=cXelFSSiQFuqfTJ9GSWLXdiths9vtzocZ6KdO3jgT5t0LjL+xhKzZmGTQ97IoW59q gsdKPrxUWu5QXI2G0tiU2QwruMEiG1+MEgQSpceBHlr0oQ/OsngTjcae0vbf8GoxOK 2tRQf0TiZa5CUCsgc9v13hVrMOZTooPnUN+EglNq4Ei4/7QZlikyB3lTc7OnmdJM9s wjMN7WVoE9ALC/1/MzzYgn0xQ6foJDJna0GtMSveAhFnWU0aEC6WYPiouXu4PvvRKY yEPoWkl5rmbNzx0gK3gzpHklTScKX81APKwMwdX3ua9GpFuqEgPSqHBdOAF2PRVN0D FsTT4XW1XpWcA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:57 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 09/10] fortran: Continue MINLOC/MAXLOC second loop where the first stopped [PR90608] Date: Fri, 23 Aug 2024 10:31:49 +0200 Message-ID: <20240823083150.149099-10-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, 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 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 3d29bcaf590..f490e795c02 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5371,6 +5371,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 { @@ -5383,6 +5384,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; } } @@ -5392,9 +5394,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) { @@ -5402,6 +5404,7 @@ strip_kind_from_actual (gfc_actual_arglist * actual) pos0 = S + (1 - from0); pos1 = S + (1 - from1); } + second_loop_entry = false; S0++; } S1++; @@ -5473,6 +5476,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; @@ -5554,6 +5558,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. */ @@ -5640,6 +5646,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); @@ -5783,8 +5801,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)); @@ -5847,6 +5868,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]; @@ -5952,7 +5979,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 23 08:31:50 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975931 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=QkIN32Gg; 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 4Wqtkq1n2Vz1yXY for ; Fri, 23 Aug 2024 18:38:23 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 84E483882078 for ; Fri, 23 Aug 2024 08:38:18 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (smtp-73.smtpout.orange.fr [80.12.242.73]) by sourceware.org (Postfix) with ESMTPS id B1747388204D; Fri, 23 Aug 2024 08:31:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org B1747388204D 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 B1747388204D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.73 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401927; cv=none; b=e+ijXeFtBVOEccEgSqZRAvYzT+h4lm6hsIb37YwpezxFU9KctR1QOnZXInYYBFMdMWksRm9KDe306ArH6xxmJDYkWn4WFisF67sGeOTak6ZXi+coqqCBHw6mDTnyoyTf0Wy4Rx+E/XpsyBdScZ1e5lXfo9jvGHnNrj+suYDcrQo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401927; c=relaxed/simple; bh=QcJuqAmglpWII56J2N4Vq24QkflhMtP5FdMVdShxPPg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=Xg6kx6tb3aqumEjn7wURYuyP9l4WoOy7LLnXr4bs2U+wOu90j0jMi67FQaDUGyPAXukaX/QIbBE8qkfOV/spwJDbC9HFvEqaluuCqxbMBtQdLMMYWJbL2A1YEUWOrSQqwVAOMrxgPQ7ZzOssbPDBcNkvbk2PpRaCOTDkCOvuT2w= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi9sjynE; Fri, 23 Aug 2024 10:31:57 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401917; bh=hvlOhKKdWvepSRNRJC6Xo3opN0duC0FfYM2/+sPHpd8=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=QkIN32GgPP/2c3ofFVbf+31Q69ysxfwddaQDFMzVXD4KhTS8xd9cijy1VIW5BAbnZ xF9NMleKudNdr5pRtqXA+pJQK/XDEe7ZaJ3Sn0yi0rRekOf/Bknrlv8n9r5fCXLUCw O+DZA2DApcKA1GCAzLSeR9hHPEKOmoNDVI+netZBmvkDkX8ShbNu0AhT/lNH5+jXYg Rh+Fhtpop8ZlI5nfZ+Jt5pbnAHKpCCdpOh+Z544OAVeh2HEpaEJcAypM66rjpxduEd c/i7Y6h0PzWjTNmfeqs15DN7Awax7wEOpafWLC7/JKmKzkH7JvVZxWUrS5hqTbuYLn Wv9Y/s6j8kNxg== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:57 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Cc: Joseph Myers Subject: [PATCH v3 10/10] fortran: Add -finline-intrinsics flag for MINLOC/MAXLOC [PR90608] Date: Fri, 23 Aug 2024 10:31:50 +0200 Message-ID: <20240823083150.149099-11-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-10.5 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_SHORT, KAM_STOCKGEN, 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 The documentation in this patch was partly reworded, compared to the previous version posted at: https://gcc.gnu.org/pipermail/gcc-patches/2024-August/660607.html The rest of the patch is unchanged, just rebased to a more recent master. Joseph is in CC as I need a ack for the new option. 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 set or not 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 | 31 + 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, 929 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..3d59728f433 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,36 @@ 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},... +Prefer generating inline code over calls to libgfortran functions to implement +intrinscs. + +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 allowed as argument to @code{-finline-intrinsics=} +is currently limited to @code{MAXLOC} and @code{MINLOC}. The effect of +the flag is moreover limited to calls of those intrinsics without +@code{DIM} argument and with @code{ARRAY} of a non-@code{CHARACTER} type. +The case of rank-1 argument and @code{DIM} argument present, i.e. +@code{MAXLOC(A(:),DIM=1)} or @code{MINLOC(A(:),DIM=1)} is inlined +unconditionally for numeric rank-1 array argument @code{A}. + @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 f490e795c02..054b2b297fd 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11850,10 +11850,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: @@ -11889,8 +11890,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"