Internal compiler error

Help
1

Relating to this Program does not return from`deallocate` statement discussion, I wrote a custom allocator (I use this word though it is just a debug layer on top of normal Fortran allocation) since I guess I have some deep memory issues.
Basically I want to track base addresses (and related size) of entities being allocated (to try to see if at some point there is some memory overlapping, resulting in corruption).

Here is the full file code:

module Allocation
   
   implicit none
   private
   public :: delete, alloc, setAllocOutUnit

   logical :: is_unit_set = .false.
   integer :: iunit = 9999

   interface delete
      ! module procedure delete_
      module procedure deleteI
      module procedure deleteR
   end interface

   interface alloc
         module procedure allocI0_
         module procedure allocR0_
         module procedure allocDP0_
         module procedure allocI_
         module procedure allocR_
   end interface



contains




   subroutine setAllocOutUnit(iun)
      integer, intent(in) :: iun

      iunit = iun
      is_unit_set = .true.
   end subroutine setAllocOutUnit



   subroutine printFileAndLine_(file, line)
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional            :: line
      ! character(len = 32) :: fmt = ' '
      character(len = 64) :: buf = ' '
      integer :: ilen

      if (.not. present(file)) return

      ! write(unit=fmt, fmt='(a)') '( " @", a )'
      write(unit=buf, fmt='( " @", a )') file
      if (present(line)) then

         ilen = len_trim(buf)
         ilen = ilen + 1

         write(unit=buf(ilen:), fmt='( "(", i0, ")" )') line
      endif
      ilen = len_trim(buf)
      ilen = ilen + 1
      write(unit=buf(ilen:), fmt='(a)') ':'

      write(iunit, '(a)', advance='no') buf(1 : len_trim(buf) + 2)
   end subroutine printFileAndLine_




   subroutine varIsAllocatedMsg_(name)
      character(len = *), intent(in) :: name

      write(iunit, '(3a)') &
         'variable  "', name, '"  is already allocated at this point in time.'
   end subroutine varIsAllocatedMsg_



   subroutine varIsDeallocatedMsg_(name)
      character(len = *), intent(in) :: name

      write(iunit, '(3a)') &
         'variable  "', name, '"  is already de-allocated at this point in time.'
   end subroutine varIsDeallocatedMsg_




   subroutine printDims_(dims)
      integer, intent(in) :: dims(..)
      integer :: ndims, i

      select rank (dims)

         rank(0)
            write(iunit, fmt='(a, i0)') &
               'Dimensions:  ', dims

         rank (1)

            ndims = size(dims)
            write(iunit, fmt='(a)', advance='no') 'Dimensions:  '

            do i = 1, ndims - 1
               write(iunit, fmt='(i0, " - ")', advance='no') dims(i)
            enddo
            write(iunit, fmt='(i0)') dims(ndims)

      end select
   end subroutine printDims_



   subroutine allocOKMsg_(name, iloc, nbytes)
      character(len = *), intent(in) :: name
      integer(kind = 8), intent(in)  :: iloc, nbytes

      write(iunit, fmt='(2a, 2(a, i0), ". ")', advance='no') &
         'variable  "', name, '"  allocated. Location in memory:  ', iloc, &
         '. Occupancy (bytes):  ', nbytes
   end subroutine allocOKMsg_


   subroutine allocKOMsg_(name, istat, emsg)
      character(len = *), intent(in) :: name, emsg
      integer, intent(in) :: istat

      write(iunit, fmt='(3a)') &
         '[ERROR] variable  "', name, '"  could not be allocated.'
      write(iunit, fmt='(15x, a, i0, 2a)') &
         'Exit code  ', istat, '. Error message:  ', emsg(1 : len_trim(emsg))
   end subroutine allocKOMsg_




   subroutine deallocOKMsg_(name)
      character(len = *), intent(in) :: name

      write(iunit, fmt='(3a)') &
         'variable  "', name, '"  correctly de-allocated.'
   end subroutine deallocOKMsg_


   subroutine deallocKOMsg_(name, istat, emsg)
      character(len = *), intent(in) :: name, emsg
      integer, intent(in) :: istat

      write(iunit, fmt='(3a)') &
         '[ERROR] variable  "', name, '"  could not be de-allocated.'
      write(iunit, fmt='(15x, a, i0, 2a)') &
         'Exit code  ', istat, '. Error message:  ', emsg(1 : len_trim(emsg))
   end subroutine deallocKOMsg_




   subroutine wrongDimsRankMsg_()

      write(*, fmt='(5x, "--", a)') &
         '[ERROR]  When allocating NDrank array, dimensions must be passed as 0D/1D-rank array.'
      write(iunit, fmt='(a)') &
         '[ERROR]  When allocating NDrank array, dimensions must be passed as 0D/1D-rank array.'
   end subroutine wrongDimsRankMsg_



   subroutine dimsMismatchMsg_(irank, ndims)
      integer, intent(in) :: irank, ndims

      write(iunit, fmt='( a, 2(i0, a) )') &
         '[ERROR]   Rank and number of dimensions do not match! (', &
         irank, '  vs.  ', ndims, ')'
   end subroutine dimsMismatchMsg_









   subroutine allocI0_(var, name, file, line)
      integer, allocatable :: var
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: istat
      character(len = 256) :: emsg

      call printFileAndLine_(file, line)

      if (allocated(var)) then
         call varIsAllocatedMsg_(name)
         return
      else
         allocate(var, stat = istat, errmsg=emsg)
      endif

      if (istat == 0) then
         call allocOKMsg_(name, loc(var), sizeof(var))
         write(iunit, *) ''
      else
         call allocKOMsg_(name, istat, emsg)
      endif
   end subroutine allocI0_


   subroutine allocR0_(var, name, file, line)
      real, allocatable :: var
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: istat
      character(len = 256) :: emsg

      call printFileAndLine_(file, line)

      if (allocated(var)) then
         call varIsAllocatedMsg_(name)
         return
      else
         allocate(var, stat = istat, errmsg=emsg)
      endif

      if (istat == 0) then
         call allocOKMsg_(name, loc(var), sizeof(var))
      else
         call allocKOMsg_(name, istat, emsg)
      endif
   end subroutine allocR0_


   subroutine allocDP0_(var, name, file, line)
      double precision, allocatable :: var
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: istat
      character(len = 256) :: emsg

      call printFileAndLine_(file, line)

      if (allocated(var)) then
         call varIsAllocatedMsg_(name)
         return
      else
         allocate(var, stat = istat, errmsg=emsg)
      endif

      if (istat == 0) then
         call allocOKMsg_(name, loc(var), sizeof(var))
      else
         call allocKOMsg_(name, istat, emsg)
      endif
   end subroutine allocDP0_







   subroutine allocI_(var, name, dims, file, line)
      integer, allocatable :: var(..)
      integer, intent(in)  :: dims(..)
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: ndims, irank, istat
      character(len = 256) :: emsg
      integer :: dim_

      call printFileAndLine_(file, line)

      select rank (dims)
         rank (0)
            dim_ = dims
            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     allocate(var(dim_), stat=istat, errmsg=emsg)
                  endif

               rank default
                  irank = rank(var)
                  call dimsMismatchMsg_(irank, 1)
                  error stop
            end select
         
         rank (1)

            ndims = size(dims)

            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 1) then
                        allocate(var(dims(1)), stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(1, ndims)
                        error stop
                     endif
                  endif

               rank (2)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 2) then
                        allocate(var(dims(1), dims(2)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(2, ndims)
                        error stop
                     endif
                  endif

               rank (3)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 3) then
                        allocate(var(dims(1), dims(2), dims(3)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(3, ndims)
                        error stop
                     endif
                  endif
            end select
         
         rank default
            call wrongDimsRankMsg_()
            error stop
      end select

      if (istat == 0) then
         call allocOKMsg_(name, loc(var), sizeof(var))
         call printDims_(dims)
      else
         call allocKOMsg_(name, istat, emsg)
      endif
   end subroutine allocI_





   subroutine allocR_(var, name, dims, file, line)
      real, allocatable   :: var(..)
      integer, intent(in) :: dims(..)
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: ndims, irank, istat
      character(len = 256) :: emsg
      integer :: dim_
      
      ! NOTE: this is a copy from allocI_
      !       Changes only declaration-type of var.
      
      call printFileAndLine_(file, line)

      select rank (dims)
         rank (0)
            dim_ = dims
            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     allocate(var(dim_), stat=istat, errmsg=emsg)
                  endif

               rank default
                  irank = rank(var)
                  call dimsMismatchMsg_(irank, 1)
                  error stop
            end select
         
         rank (1)

            ndims = size(dims)

            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 1) then
                        allocate(var(dims(1)), stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(1, ndims)
                        error stop
                     endif
                  endif

               rank (2)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 2) then
                        allocate(var(dims(1), dims(2)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(2, ndims)
                        error stop
                     endif
                  endif

               rank (3)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 3) then
                        allocate(var(dims(1), dims(2), dims(3)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(3, ndims)
                        error stop
                     endif
                  endif
            end select
         
         rank default
            call wrongDimsRankMsg_()
            error stop
      end select

      if (istat == 0) then
         call allocOKMsg_(name, loc(var), sizeof(var))
         call printDims_(dims)
      else
         call allocKOMsg_(name, istat, emsg)
      endif
   end subroutine allocR_










   ! subroutine delete_(var, name, file, line)
   !    type(*), allocatable :: var(..)
   !    character(len = *), intent(in) :: name
   !    character(len = *), intent(in), optional :: file, line
   !    integer :: istat
   !    character(len = 256) :: emsg

   !    call printFileAndLine_(file, line)

   !    if (allocated(var)) then
   !       deallocate(var, stat=istat, errmsg=emsg)
   !       if (istat == 0) then
   !          call deallocOKMsg_(name)
   !       else
   !          call deallocKOMsg_(name, istat, emsg)
   !       endif
   !    else
   !       call varIsDeallocatedMsg_(name)
   !    endif
   ! end subroutine delete_






   subroutine deleteI( var, name, file, line )
      implicit none
      integer, allocatable :: var(..)
      character( len = * ), intent(in) :: name
      character( len= * ), optional, intent(in) :: file
      integer, optional, intent(in) :: line
      integer :: ist
      character(len = 256) :: emsg

      call printFileAndLine_(file, line)

      if (allocated(var)) then

         deallocate( var, stat=ist, errmsg=emsg)
         if (ist == 0) then
            call deallocOKMsg_(name)
         else
            call deallocKOMsg_(name, ist, emsg)
         endif

      else
         call varIsDeallocatedMsg_(name)
      endif
   end subroutine deleteI


   subroutine deleteR(var, name, file, line)
      implicit none
      real, allocatable                :: var(..)
      character( len = * ), intent(in) :: name
      character( len= * ), optional, intent(in) :: file
      integer, optional, intent(in) :: line
      integer :: ist
      character(len = 256) :: emsg

      call printFileAndLine_(file, line)

      if (allocated(var)) then

         deallocate( var, stat=ist, errmsg=emsg)
         if (ist == 0) then
            call deallocOKMsg_(name)
         else
            call deallocKOMsg_(name, ist, emsg)
         endif

      else
         call varIsDeallocatedMsg_(name)
      endif
   end subroutine deleteR





end module Allocation

In allocI_(), at line

call allocOKMsg_(name, loc(var), sizeof(var))

the compiler (ifort: Version 2021.7.1 Build 20221019_000000) generates:

allocator.f90(355): catastrophic error: **Internal compiler error: internal abort** Please report this error along with the circumstances in which it occurred in a Software Problem Report.  Note: File and line given may not be explicit cause of this error.

Intel Documentation states " If it is an assumed-rank array, it must not be associated with an assumed-size array", which it should not be.

Is the code wrong, or could it be a compiler bug?

Thanks.

2

Internal Compiler Error is ALWAYS a compiler bug, no matter whether your code is valid or not. Please report this to Intel on their forum at Intel® Fortran Compiler - Intel Communities

3

Thanks.
Here is the link for the thread posted on the Intel Community.

6

@kargl ,

thanks for your answer.

I see that gfortran also complains about lines

deallocate(var, stat=ist, errmsg=emsg)

giving

Error: Assumed-rank variable var at (1) may only be used as actual argument

as well as

call allocOKMsg_(name, loc(var), sizeof(var))

giving

Error: Assumed-rank argument at (1) (in  loc(var)) is only permitted as actual argument to intrinsic inquiry functions

which ifort did not.

Could you gently share some domcumentation about Fortran 202x where I can read more about this? Many thanks :slight_smile:

7

@mEm ,

As pointed out upthread, an internal compiler error is a compiler bug and it doesn’t matter whether your code conforms.

Having said that, please note with a good IDE, you should not have do your memory bookkeeping technically but if you feel your coding platform and programs require that and you need to pursue along the lines you show in the original post, then do keep in mind

  1. an assumed-rank object as a received argument in a subprogram cannot be referenced in most Fortran statements, including DEALLOCATE. Thus your code in the original post does not conform.
    So consider guarding the object in a question in a SELECT RANK construct. A possible approach (if you don’t mind the verbosity) can be as follows but note you gain nothing from it relative to the intrinsic DEALLOCATE. By the time, the intrinsic DEALLOCATE fails in your actual code, an egregious code corruption has already taken place.
module m
contains
   subroutine user_int_deallocate( a, name_a )
      integer, allocatable :: a(..)
      character(len=*), intent(in) :: name_a
      if ( allocated(a) ) then
         select rank ( o => a )
            rank( 0 )
               print *, name_a, " is of rank 0"
               deallocate( o ) 
            rank( 1 )
               print *, name_a, " is of rank 1"
               deallocate( o ) 
            rank( 2 )
               print *, name_a, " is of rank 2"
               deallocate( o ) 
            rank( 3 )
               print *, name_a, " is of rank 3"
               deallocate( o )
            rank default
               print *, "a is of unsupported rank: not deallocated"
          end select
      end if 
   end subroutine 
end module
   use m
   integer, allocatable :: x(:), y(:,:), z(:,:,:)
   allocate( x(1), y(1,1), z(1,1,1) )
   call user_int_deallocate( x, "x" ) 
   call user_int_deallocate( y, "y" ) 
   call user_int_deallocate( z, "z" )
end

C:\temp>ifort /standard-semantics p.f90
Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on Intel(R) 64, Version 2021.8.0 Build 20221119_000000
Copyright (C) 1985-2022 Intel Corporation.  All rights reserved.

Microsoft (R) Incremental Linker Version 14.31.31105.0
Copyright (C) Microsoft Corporation.  All rights reserved.

-out:p.exe
-subsystem:console
p.obj

C:\temp>p.exe
 x is of rank 1
 y is of rank 2
 z is of rank 3

C:\temp>
  1. loc and sizeof are not part of the standard and you will have to pay close attention to its compiler-specific intricacies if you run with them. An alternative can be rolling your own, say like so:
   block 
      integer, allocatable :: n
      allocate( n )
      print *, "'size_of(n)' in nominal bytes: ", sizeof(n)
      print "(g0,z0)", "'n' allocated at address (hex): ", loc( n )
   end block
   print *
   block 
      integer, parameter :: WP = selected_real_kind( p=12 )
      real(WP), allocatable :: x(:)
      allocate( x(3) )
      print *, "'size_of(x)' in nominal bytes: ", sizeof(x)
      print "(g0,z0)", "'x' allocated at address (hex): ", loc( x )
   end block
   print *
   block 
      character(len=:), allocatable :: s(:)
      allocate( character(len=10) :: s(3) )
      print *, "'size_of(s)' in nominal bytes: ", sizeof(s)
      print "(g0,z0)", "'s' allocated at address (hex): ", loc( s )
   end block
contains
   function sizeof( a ) result(r)
      use, intrinsic :: iso_fortran_env, only : CZ => character_storage_size
      use, intrinsic :: iso_c_binding, only : c_size_t
      class(*), intent(in), target :: a(..)
      ! Function result
      integer(c_size_t) :: r
      r = size(a)*storage_size(a)/CZ
   end function 
   function loc( a ) result(r)
      use, intrinsic :: iso_c_binding, only : c_loc, c_intptr_t
      type(*), intent(in), target :: a(..)
      ! Function result
      integer(c_intptr_t) :: r
      r = transfer( source=c_loc(a), mold=r )
   end function 
end

C:\temp>ifort /standard-semantics p.f90
Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on Intel(R) 64, Version 2021.8.0 Build 20221119_000000
Copyright (C) 1985-2022 Intel Corporation.  All rights reserved.

Microsoft (R) Incremental Linker Version 14.31.31105.0
Copyright (C) Microsoft Corporation.  All rights reserved.

-out:p.exe
-subsystem:console
p.obj

C:\temp>p.exe
 'size_of(n)' in nominal bytes:  4
'n' allocated at address (hex): 2670EA26450

 'size_of(x)' in nominal bytes:  24
'x' allocated at address (hex): 2670EA16340

 'size_of(s)' in nominal bytes:  30
's' allocated at address (hex): 2670EA16100

C:\temp>

Caveat: I reckon it’s gfortran that does not conform with the storage_size intrinsic when the received argument of unlimited polymorphic as declared type is associated with an actual argument of CHARACTER type of length > 1.

1 Like