https://gcc.gnu.org/bugzilla/show_bug.cgi?id=118896
Bug ID: 118896
Summary: The fortran compiler is unable to devirtualize
typebound indirect calls
Product: gcc
Version: 15.0
Status: UNCONFIRMED
Severity: normal
Priority: P3
Component: fortran
Assignee: unassigned at gcc dot gnu.org
Reporter: mikael at gcc dot gnu.org
Target Milestone: ---
With the following example (which is a simplified class_assign_4.f90 from the
testsuite), I can see in the -O2 .optimized dump:
<bb 4> [local count: 79480924]:
...
_223 = MEM[(struct __vtype_m_T1 * {ref-all})&__vtab_m_T1]._copy;
...
_223 (_231, _228);
...
all this in the same basic block.
The compiler should obviously be able to simplify the indirect call to a direct
call, but it is unfortunately not the case. In this case the copy function is
a simple integral copy, so devirtualizing and inlining the devirtualized
function would have an important cascading effect to simplify the finally
generated code.
Testcase:
module m
implicit none
type :: t1
integer :: i
CONTAINS
end type
type, extends(t1) :: t2
real :: r
end type
end module m
subroutine test_t1
use m
implicit none
class(t1), dimension(:), allocatable :: x, y
x = [t1(3), t1(2), t1(1)]
x = realloc_t1 (x)
if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
contains
function realloc_t1 (arg) result (res)
class(t1), dimension(:), allocatable :: arg
class(t1), dimension(:), allocatable :: res
select type (arg)
type is (t2)
allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
type is (t1)
allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
end select
end function realloc_t1
logical function check_t1 (arg, array, t, array2)
class(t1) :: arg(:)
integer :: array (:), t
integer, optional :: array2(:)
check_t1 = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 2) check_t1 = .false.
type is (t2)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 1) check_t1 = .false.
if (present (array2)) then
if (any(int (arg%r) .ne. array2)) check_t1 = .false.
end if
class default
check_t1 = .false.
end select
end function check_t1
end subroutine test_t1
call test_t1
end
