161 lines · plain
1! Test analysis of pointer assignment inside FORALL.2! The analysis must detect if the evaluation of the LHS or RHS may be impacted3! by the pointer assignments, or if the forall can be lowered into a single4! loop without any temporary copy.5 6! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \7! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only %s 2>&1 | FileCheck %s8! REQUIRES: asserts9module forall_pointers10 type t11 integer :: i12 end type13 type ptr_wrapper14 type(t), pointer :: p15 end type16contains17 18! Simple case that can be lowered into a single loop.19subroutine test_no_conflict(n, a, somet)20 integer :: n21 type(ptr_wrapper), allocatable :: a(:)22 type(t), target :: somet23 forall(i=1:n) a(i)%p => somet24end subroutine25! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_no_conflict ------------26! CHECK-NEXT: run 1 evaluate: forall/region_assign127 28subroutine test_null_no_conflict(n, a)29 integer :: n30 type(ptr_wrapper), allocatable :: a(:)31 forall(i=1:n) a(i)%p => null()32end subroutine33! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_null_no_conflict ------------34! CHECK-NEXT: run 1 evaluate: forall/region_assign135 36! Case where the pointer target evaluations are impacted by the pointer37! assignments and should be evaluated for each iteration before doing38! any pointer assignment.39! The test is transposing an array of (wrapped) pointers.40subroutine test_need_to_save_rhs(n, a)41 integer :: n42 type(ptr_wrapper) :: a(:)43 forall(i=1:n) a(i)%p => a(n+1-i)%p44end subroutine45! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_need_to_save_rhs ------------46! CHECK-NEXT: conflict: R/W47! CHECK-NEXT: run 1 save : forall/region_assign1/rhs48! CHECK-NEXT: run 2 evaluate: forall/region_assign149 50! Case where the pointer descriptor address evaluations are impacted by the51! assignments and should be evaluated for each iteration before doing52! any pointer assignment.53subroutine test_need_to_save_lhs(n, a, somet)54 integer :: n55 type(ptr_wrapper) :: a(:)56 type(t), target :: somet57 forall(i=1:n) a(a(n+1-i)%p%i)%p => somet58end subroutine59! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_need_to_save_lhs ------------60! CHECK-NEXT: conflict: R/W61! CHECK-NEXT: run 1 save : forall/region_assign1/lhs62! CHECK-NEXT: run 2 evaluate: forall/region_assign163 64subroutine test_null_need_to_save_lhs(n, a)65 integer :: n66 type(ptr_wrapper) :: a(:)67 forall(i=1:n) a(a(n+1-i)%p%i)%p => null()68end subroutine69! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_null_need_to_save_lhs ------------70! CHECK-NEXT: conflict: R/W71! CHECK-NEXT: run 1 save : forall/region_assign1/lhs72! CHECK-NEXT: run 2 evaluate: forall/region_assign173 74! Case where both the computation of the target and descriptor addresses are75! impacted by the assignment and need to be all evaluated before doing any76! assignment.77subroutine test_need_to_save_lhs_and_rhs(n, a)78 integer :: n79 type(ptr_wrapper) :: a(:)80 forall(i=1:n) a(a(n+1-i)%p%i)%p => a(modulo(-2*i, n+1))%p81end subroutine82! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_need_to_save_lhs_and_rhs ------------83! CHECK-NEXT: conflict: R/W84! CHECK-NEXT: run 1 save : forall/region_assign1/rhs85! CHECK-NEXT: conflict: R/W86! CHECK-NEXT: run 1 save : forall/region_assign1/lhs87! CHECK-NEXT: run 2 evaluate: forall/region_assign188 89subroutine test_character_no_conflict(c)90 type tc91 character(10), pointer :: p92 end type93 character(10), target :: c(10)94 integer(8) :: i95 type(tc) a(10)96 forall(i=1:10)97 a(i)%p => c(i)98 end forall99end subroutine100! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_character_no_conflict ------------101! CHECK-NEXT: run 1 evaluate: forall/region_assign1102 103end module104 105! End to end test provided for debugging purpose (not run by lit).106program end_to_end107 use forall_pointers108 integer, parameter :: n = 10109 type(t), target, save :: data(n) = [(t(i), i=1,n)]110 type(ptr_wrapper) :: pointers(n)111 ! Print pointer/target mapping baseline.112 call reset_pointers(pointers)113 if (.not.check_equal(pointers, [10,9,8,7,6,5,4,3,2,1])) stop 1114 115 ! Test case where RHS target addresses must be saved in FORALL.116 call test_need_to_save_rhs(n, pointers)117 if (.not.check_equal(pointers, [1,2,3,4,5,6,7,8,9,10])) stop 2118 119 ! Test case where LHS pointer addresses must be saved in FORALL.120 call reset_pointers(pointers)121 call test_need_to_save_lhs(n, pointers, data(1))122 if (.not.check_equal(pointers, [(1,i=1,10)])) stop 3123 124 ! Test case where bot RHS target addresses and LHS pointer addresses must be125 ! saved in FORALL.126 call reset_pointers(pointers)127 call test_need_to_save_lhs_and_rhs(n, pointers)128 if (.not.check_equal(pointers, [2,4,6,8,10,1,3,5,7,9])) stop 4129 130 call reset_pointers(pointers)131 call test_null_need_to_save_lhs(n, pointers)132 if (.not.check_associated(pointers, [(.false., i=1,n)])) stop 5133 134 print *, "PASS"135contains136subroutine reset_pointers(a)137 type(ptr_wrapper) :: a(:)138 do i=1,n139 a(i)%p => data(n+1-i)140 end do141end subroutine142logical function check_equal(a, expected)143 type(ptr_wrapper) :: a(:)144 integer :: expected(:)145 check_equal = all([(a(i)%p%i, i=1,10)].eq.expected)146 if (.not.check_equal) then147 print *, "expected:", expected148 print *, "got:", [(a(i)%p%i, i=1,10)]149 end if150end function151logical function check_associated(a, expected)152 type(ptr_wrapper) :: a(:)153 logical :: expected(:)154 check_associated = all([(associated(a(i)%p), i=1,10)].eqv.expected)155 if (.not.check_associated) then156 print *, "expected:", expected157 print *, "got:", [(associated(a(i)%p), i=1,10)]158 end if159end function160end161