157 lines · plain
1! Test analysis of procedure pointer assignments inside FORALL.2 3! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \4! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s5! REQUIRES: asserts6 7module proc_ptr_forall8 type :: t9 procedure(f1), nopass, pointer :: p10 end type11contains12 pure integer function f1()13 f1 = 114 end function15 pure integer function f2()16 f2 = 217 end function18 pure integer function f3()19 f3 = 320 end function21 pure integer function f4()22 f4 = 423 end function24 pure integer function f5()25 f5 = 526 end function27 pure integer function f6()28 f6 = 629 end function30 pure integer function f7()31 f7 = 732 end function33 pure integer function f8()34 f8 = 835 end function36 pure integer function f9()37 f9 = 938 end function39 pure integer function f10()40 f10 = 1041 end function42 43 subroutine test_no_conflict(x)44 type(t) :: x(10)45 forall(i=1:10) x(i)%p => f146 end subroutine47! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_no_conflict ------------48! CHECK-NEXT: run 1 evaluate: forall/region_assign149 50 subroutine test_need_to_save_rhs(x)51 type(t) :: x(10)52 forall(i=1:10) x(i)%p => x(11-i)%p53 end subroutine54! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_rhs ------------55! CHECK-NEXT: conflict: R/W56! CHECK-NEXT: run 1 save : forall/region_assign1/rhs57! CHECK-NEXT: run 2 evaluate: forall/region_assign158 59 subroutine test_need_to_save_lhs(x)60 type(t) :: x(10)61 forall(i=1:10) x(x(11-i)%p())%p => f162 end subroutine63! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs ------------64! CHECK-NEXT: unknown effect: %{{.*}} = fir.call65! CHECK-NEXT: unknown effect: %{{.*}} = fir.call66! CHECK-NEXT: conflict: R/W67! CHECK-NEXT: run 1 save : forall/region_assign1/lhs68! CHECK-NEXT: run 2 evaluate: forall/region_assign169 70 subroutine test_need_to_save_lhs_and_rhs(x)71 type(t) :: x(10)72 forall(i=1:10) x(x(11-i)%p())%p => x(modulo(-2*i, 11))%p73 end subroutine74! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------75! CHECK-NEXT: unknown effect: %{{.*}} = fir.call76! CHECK-NEXT: conflict: R/W77! CHECK-NEXT: run 1 save : forall/region_assign1/rhs78! CHECK-NEXT: unknown effect: %{{.*}} = fir.call79! CHECK-NEXT: conflict: R/W80! CHECK-NEXT: run 1 save : forall/region_assign1/lhs81! CHECK-NEXT: run 2 evaluate: forall/region_assign182 83 subroutine test_null_no_conflict(x)84 type(t) :: x(10)85 forall(i=1:10) x(i)%p => null()86 end subroutine87! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_null_no_conflict ------------88! CHECK-NEXT: run 1 evaluate: forall/region_assign189 90 subroutine test_null_need_to_save_lhs(x)91 type(t) :: x(10)92 forall(i=1:10) x(x(11-i)%p())%p => null()93 end subroutine94! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_null_need_to_save_lhs ------------95! CHECK-NEXT: unknown effect: %{{.*}} = fir.call96! CHECK-NEXT: unknown effect: %{{.*}} = fir.call97! CHECK-NEXT: conflict: R/W98! CHECK-NEXT: run 1 save : forall/region_assign1/lhs99! CHECK-NEXT: run 2 evaluate: forall/region_assign1100 101! End-to-end test utilities for debugging purposes.102 103 subroutine reset(a)104 type(t) :: a(:)105 a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)]106 end subroutine107 108 subroutine print(a)109 type(t) :: a(:)110 print *, [(a(i)%p(), i=1,10)]111 end subroutine112 113 logical function check_equal(a, expected)114 type(t) :: a(:)115 integer :: expected(:)116 check_equal = all([(a(i)%p(), i=1,10)].eq.expected)117 if (.not.check_equal) then118 print *, "expected:", expected119 print *, "got:", [(a(i)%p(), i=1,10)]120 end if121 end function122 123 logical function check_association(a, expected)124 type(t) :: a(:)125 logical :: expected(:)126 check_association = all([(associated(a(i)%p), i=1,10)].eqv.expected)127 if (.not.check_association) then128 print *, "expected:", expected129 print *, "got:", [(associated(a(i)%p), i=1,10)]130 end if131 end function132 133end module134 135! End-to-end test for debugging purposes (not verified by lit).136 use proc_ptr_forall137 type(t) :: a(10)138 139 call reset(a)140 call test_need_to_save_rhs(a)141 if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1142 143 call reset(a)144 call test_need_to_save_lhs(a)145 if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2146 147 call reset(a)148 call test_need_to_save_lhs_and_rhs(a)149 if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3150 151 call reset(a)152 call test_null_need_to_save_lhs(a)153 if (.not.check_association(a, [(.false., i=1,10)])) stop 4154 155 print *, "PASS"156end157