Virtual memory array in Fortran based on POSIX system headers

test_mmap.f90

! test_mmap.f90
!
! compile with:
!    gfortran -Wall -O2 -o test_mmap test_mmap.f90
!
! inspired by the work:
!    Rojc, B., & Depolli, M. (2021). A Resizable C++ Container using Virtual Memory. In ICSOFT (pp. 481-488).
!    https://www.scitepress.org/Papers/2021/105571/105571.pdf
!
! so far I've only tested this on MacOS
! may still contain errors
!
! for clarity it's probably best to prefix arrays with `mm_` to note they are memory-mapped
! and should be freed by a different sub-program than usual
!
module mmap_array

  use, intrinsic :: iso_c_binding
  
  implicit none
  private

  public :: get_mmap_array, destroy_mmap_array

  integer(c_int), parameter :: PROT_NONE  = int(z'00',c_int)
  integer(c_int), parameter :: PROT_READ  = int(z'01',c_int)
  integer(c_int), parameter :: PROT_WRITE = int(z'02',c_int)
  integer(c_int), parameter :: PROT_EXEC  = int(z'04',c_int)

  integer(c_int), parameter :: MAP_SHARED  = int(z'0001',c_int)
  integer(c_int), parameter :: MAP_PRIVATE = int(z'0002',c_int)
  integer(c_int), parameter :: MAP_FIXED   = int(z'0010',c_int)

  !> MAP_ANON on Darwin
  integer(c_int), parameter :: MAP_ANONYMOUS = int(z'1000',c_int)

  interface

    !> Map files or devices into memmory
    type(c_ptr) function c_mmap(addr,len,prot,flags,fildes,offset) bind(c,name="mmap")
      import c_ptr, c_size_t, c_int
      type(c_ptr), value :: addr
      integer(c_size_t), value :: len
      integer(c_int), value :: prot
      integer(c_int), value :: flags
      integer(c_int), value :: fildes
      integer(c_size_t), value :: offset
    end function

    !> Control the protection of pages
    integer(c_int) function c_mprotect(addr,len,prot) bind(c,name="mprotect")
      import c_ptr, c_size_t, c_int
      type(c_ptr), value :: addr
      integer(c_size_t), value :: len
      integer(c_int), value :: prot
    end function

    !> Remove a mapping
    integer(c_int) function c_munmap(addr,len) bind(c,name="munmap")
      import c_ptr, c_size_t, c_int
      type(c_ptr), value :: addr
      integer(c_size_t), value :: len
    end function

  end interface

contains

  subroutine get_mmap_array(array_ptr, max_elements, stat)
    integer, intent(in) :: max_elements
    real(c_double), pointer, intent(out) :: array_ptr(:)
    integer, intent(out) :: stat

    type(c_ptr) :: raw_ptr

    integer(c_int64_t), parameter :: block_size = 1048576
    integer(c_int64_t) :: remaining
    
    type(c_ptr) :: head
    integer(c_ptrdiff_t) :: ihead
    
    integer(c_int) :: ret

    stat = 0

    raw_ptr = c_mmap(c_null_ptr,max_elements*c_sizeof(1.0_c_double), &
        PROT_NONE, ior(MAP_PRIVATE,MAP_ANONYMOUS), &
        -1_c_int, 0_c_size_t)

    if (transfer(raw_ptr,1.0_c_double) == -1.0_c_double) then
      stat = -1
      return
    end if

    remaining = c_sizeof(1.0_c_double)*max_elements
    ihead = transfer(raw_ptr,ihead)

    do while (remaining > 0)

      head = transfer(ihead, head)
      ret = c_mprotect(head, min(block_size,remaining), &
              ior(PROT_READ,PROT_WRITE))

      if (ret /= 0) then
        stat = -2
        return
      end if

      ihead = ihead + block_size

      remaining = remaining - block_size
    end do

    call c_f_pointer(raw_ptr,array_ptr,[max_elements])

  end subroutine

  subroutine destroy_mmap_array(array,stat)
    real(c_double), intent(inout), pointer :: array(:)
    integer, intent(out) :: stat
      
    stat = c_munmap(c_loc(array), size(array)*c_sizeof(1.0_c_double))
    nullify(array)

  end subroutine

end module


program test_mmap

  use, intrinsic :: iso_c_binding, only: dp => c_double
  use mmap_array
  implicit none

  real(dp), pointer, contiguous :: a(:) => null()
  integer :: stat

  print *, "associated: ", associated(a)
  call get_mmap_array(a,10000000,stat)
  print *, "status flag = ", stat
  print *, "associated: ", associated(a)

  a(1) = 3
  a(2) = 6
  a(3) = 18

  print *, a(1:5)

  ! array a has pointer attribute meaning we are in charge of destruction
  ! Since it was created via mmap we must also use the routines from the 
  ! mman system header to unmap it.
  call destroy_mmap_array(a,stat)    
  if (stat /= 0) then
    print *, "something went wrong"
    stop 1
  end if

end program