111 lines · plain
1! Test analysis of polymorphic 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_poly_pointers10 type base11 integer :: i12 end type13 type, extends(base) :: extension14 integer :: j15 end type16 type ptr_wrapper17 class(base), pointer :: p18 end type19contains20 21! Simple case that can be lowered into a single loop.22subroutine test_no_conflict(n, a, somet)23 integer :: n24 type(ptr_wrapper) :: a(:)25 class(base), target :: somet26 forall(i=1:n) a(i)%p => somet27end subroutine28! CHECK: ------------ scheduling forall in _QMforall_poly_pointersPtest_no_conflict ------------29! CHECK-NEXT: run 1 evaluate: forall/region_assign130 31subroutine test_no_conflict2(n, a, somet)32 integer :: n33 type(ptr_wrapper) :: a(:)34 type(base), target :: somet35 forall(i=1:n) a(i)%p => somet36end subroutine37! CHECK: ------------ scheduling forall in _QMforall_poly_pointersPtest_no_conflict2 ------------38! CHECK-NEXT: run 1 evaluate: forall/region_assign139 40subroutine test_rhs_conflict(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_poly_pointersPtest_rhs_conflict ------------46! CHECK-NEXT: conflict: R/W47! CHECK-NEXT: run 1 save : forall/region_assign1/rhs48! CHECK-NEXT: run 2 evaluate: forall/region_assign149end module50 51! End to end test provided for debugging purpose (not run by lit).52program end_to_end53 use forall_poly_pointers54 integer, parameter :: n = 1055 type(extension), target, save :: data(n) = [(extension(i, 100+i), i=1,n)]56 type(ptr_wrapper) :: pointers(n)57 ! Print pointer/target mapping baseline.58 call reset_pointers(pointers)59 if (.not.check_equal(pointers, [10,9,8,7,6,5,4,3,2,1])) stop 160 if (.not.check_type(pointers, [(modulo(i,3).eq.0, i=1,n)])) stop 261 62 ! Test dynamic type is correctly set.63 call test_no_conflict(n, pointers, data(1))64 if (.not.check_equal(pointers, [(1,i=1,10)])) stop 365 if (.not.check_type(pointers, [(.true.,i=1,10)])) stop 466 call test_no_conflict(n, pointers, data(1)%base)67 if (.not.check_equal(pointers, [(1,i=1,10)])) stop 568 if (.not.check_type(pointers, [(.false.,i=1,10)])) stop 669 70 call test_no_conflict2(n, pointers, data(1)%base)71 if (.not.check_equal(pointers, [(1,i=1,10)])) stop 772 if (.not.check_type(pointers, [(.false.,i=1,10)])) stop 873 74 ! Test RHS conflict.75 call reset_pointers(pointers)76 call test_rhs_conflict(n, pointers)77 if (.not.check_equal(pointers, [(i, i=1,10)])) stop 978 if (.not.check_type(pointers, [(modulo(i,3).eq.2, i=1,n)])) stop 1079 80 print *, "PASS"81contains82subroutine reset_pointers(a)83 type(ptr_wrapper) :: a(:)84 do i=1,n85 if (modulo(i,3).eq.0) then86 a(i)%p => data(n+1-i)87 else88 a(i)%p => data(n+1-i)%base89 end if90 end do91end subroutine92logical function check_equal(a, expected)93 type(ptr_wrapper) :: a(:)94 integer :: expected(:)95 check_equal = all([(a(i)%p%i, i=1,10)].eq.expected)96 if (.not.check_equal) then97 print *, "expected:", expected98 print *, "got:", [(a(i)%p%i, i=1,10)]99 end if100end function101logical function check_type(a, expected)102 type(ptr_wrapper) :: a(:)103 logical :: expected(:)104 check_type = all([(same_type_as(a(i)%p, extension(1,1)), i=1,10)].eqv.expected)105 if (.not.check_type) then106 print *, "expected:", expected107 print *, "got:", [(same_type_as(a(i)%p, extension(1,1)), i=1,10)]108 end if109end function110end111