94 lines · plain
1! Test analysis of pointer assignment inside FORALL with lower bounds or bounds2! remapping.3! The analysis must detect if the evaluation of the LHS or RHS may be impacted4! by the pointer assignments, or if the forall can be lowered into a single5! loop without any temporary copy.6 7! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \8! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only %s 2>&1 | FileCheck %s9! REQUIRES: asserts10module forall_pointers_bounds11 type ptr_wrapper12 integer, pointer :: p(:, :)13 end type14contains15 16! Simple case that can be lowered into a single loop.17subroutine test_lb_no_conflict(a, iarray)18 type(ptr_wrapper) :: a(:)19 integer, target :: iarray(:, :)20 forall(i=lbound(a,1):ubound(a,1)) a(i)%p(2*(i-1)+1:,2*i:) => iarray21end subroutine22 23subroutine test_remapping_no_conflict(a, iarray)24 type(ptr_wrapper) :: a(:)25 integer, target :: iarray(6)26 ! Reshaping 6 to 2x3 with custom lower bounds.27 forall(i=lbound(a,1):ubound(a,1)) a(i)%p(2*(i-1)+1:2*(i-1)+2,2*i:2*i+2) => iarray28end subroutine29! CHECK: ------------ scheduling forall in _QMforall_pointers_boundsPtest_remapping_no_conflict ------------30! CHECK-NEXT: run 1 evaluate: forall/region_assign131 32! Bounds expression conflict. Note that even though they are syntactically on33! the LHS,they are saved with the RHS because they are applied when preparing the34! new descriptor value pointing to the RHS.35subroutine test_lb_conflict(a, iarray)36 type(ptr_wrapper) :: a(:)37 integer, target :: iarray(:, :)38 integer :: n39 n = ubound(a,1)40 forall(i=lbound(a,1):ubound(a,1)) a(i)%p(a(n+1-i)%p(1,1):,a(n+1-i)%p(2,1):) => iarray41end subroutine42! CHECK: ------------ scheduling forall in _QMforall_pointers_boundsPtest_lb_conflict ------------43! CHECK-NEXT: conflict: R/W44! CHECK-NEXT: run 1 save : forall/region_assign1/rhs45! CHECK-NEXT: run 2 evaluate: forall/region_assign146 47end module48 49! End to end test provided for debugging purpose (not run by lit).50program end_to_end51 use forall_pointers_bounds52 integer, parameter :: n = 553 integer, target, save :: data(2, 2, n) = reshape([(i, i=1,size(data))], shape=shape(data))54 integer, target, save :: data2(6) = reshape([(i, i=1,size(data2))], shape=shape(data2))55 type(ptr_wrapper) :: pointers(n)56 ! Print pointer/target mapping baseline.57 call reset_pointers(pointers)58 if (.not.check_equal(pointers, [17,18,19,20,13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4])) stop 159 60 call reset_pointers(pointers)61 call test_lb_no_conflict(pointers, data(:, :, 1))62 if (.not.check_equal(pointers, [([1,2,3,4],i=1,n)])) stop 263 if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[(i, i=1,2*n)])) stop 364 65 call reset_pointers(pointers)66 call test_remapping_no_conflict(pointers, data2)67 if (.not.check_equal(pointers, [([1,2,3,4,5,6],i=1,n)])) stop 468 if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[(i, i=1,2*n)])) stop 569 if (.not.all([(ubound(pointers(i)%p), i=1,n)].eq.[([2*(i-1)+2, 2*i+2], i=1,n)])) stop 670 71 call reset_pointers(pointers)72 call test_lb_conflict(pointers, data(:, :, 1))73 if (.not.check_equal(pointers, [([1,2,3,4],i=1,n)])) stop 774 if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[([data(1,1,i), data(2,1,i)], i=1,n)])) stop 875 76 print *, "PASS"77contains78subroutine reset_pointers(a)79 type(ptr_wrapper) :: a(:)80 do i=1,n81 a(i)%p => data(:, :, n+1-i)82 end do83end subroutine84logical function check_equal(a, expected)85 type(ptr_wrapper) :: a(:)86 integer :: expected(:)87 check_equal = all([(a(i)%p, i=1,n)].eq.expected)88 if (.not.check_equal) then89 print *, "expected:", expected90 print *, "got:", [(a(i)%p, i=1,n)]91 end if92end function93end94