hip_intf.F90

Go to the documentation of this file.

! Copyright (c) 2021-2026, The Neko Authors
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
!   * Redistributions of source code must retain the above copyright
!     notice, this list of conditions and the following disclaimer.
!
!   * Redistributions in binary form must reproduce the above
!     copyright notice, this list of conditions and the following
!     disclaimer in the documentation and/or other materials provided
!     with the distribution.
!
!   * Neither the name of the authors nor the names of its
!     contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module hip_intf
  use utils, only : neko_error
  use, intrinsic :: iso_c_binding
  implicit none
 
#ifdef HAVE_HIP
 
  enum, bind(c)
    enumerator :: hipsuccess = 0
    enumerator :: hiperrorinvalidcontext = 1
    enumerator :: hiperrorinvalidkernelfile = 2
    enumerator :: hiperrormemoryallocation = 3
    enumerator :: hiperrorinitializationerror = 4
    enumerator :: hiperrorlaunchfailure = 5
    enumerator :: hiperrorlaunchoutofresources = 6
    enumerator :: hiperrorinvaliddevice = 7
    enumerator :: hiperrorinvalidvalue = 8
    enumerator :: hiperrorinvaliddevicepointer = 9
    enumerator :: hiperrorinvalidmemcpydirection = 10
    enumerator :: hiperrorunknown = 11
    enumerator :: hiperrorinvalidresourcehandle = 12
    enumerator :: hiperrornotready = 13
    enumerator :: hiperrornodevice = 14
    enumerator :: hiperrorpeeraccessalreadyenabled = 15
    enumerator :: hiperrorpeeraccessnotenabled = 16
    enumerator :: hiperrorruntimememory = 17
    enumerator :: hiperrorruntimeother = 18
    enumerator :: hiperrorhostmemoryalreadyregistered = 19
    enumerator :: hiperrorhostmemorynotregistered = 20
    enumerator :: hiperrormapbufferobjectfailed = 21
    enumerator :: hiperrortbd = 22
  end enum
 
  enum, bind(c)
    enumerator :: hipmemcpyhosttohost = 0
    enumerator :: hipmemcpyhosttodevice = 1
    enumerator :: hipmemcpydevicetohost = 2
    enumerator :: hipmemcpydevicetodevice = 3
    enumerator :: hipmemcpydefault = 4
  end enum
 
  interface
     integer(c_int) function hipmalloc(ptr_d, s) &
          bind(c, name = 'hipMalloc')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: ptr_d
       integer(c_size_t), value :: s
     end function hipmalloc
 
     integer(c_int) function hipfree(ptr_d) &
          bind(c, name = 'hipFree')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: ptr_d
     end function hipfree
 
     integer(c_int) function hipmemcpy(ptr_dst, ptr_src, s, dir) &
          bind(c, name = 'hipMemcpy')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: ptr_dst, ptr_src
       integer(c_size_t), value :: s
       integer(c_int), value :: dir
     end function hipmemcpy
 
     integer(c_int) function hipmemcpyasync(ptr_dst, ptr_src, s, dir, stream) &
          bind(c, name = 'hipMemcpyAsync')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: ptr_dst, ptr_src, stream
       integer(c_size_t), value :: s
       integer(c_int), value :: dir
     end function hipmemcpyasync
 
     integer(c_int) function hipmemsetasync(ptr, v, s, stream) &
          bind(c, name = 'hipMemsetAsync')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: ptr, stream
       integer(c_int), value :: v
       integer(c_size_t), value :: s
     end function hipmemsetasync
 
     integer(c_int) function hipdevicesynchronize() &
          bind(c, name = 'hipDeviceSynchronize')
       use, intrinsic :: iso_c_binding
       implicit none
     end function hipdevicesynchronize
 
     integer(c_int) function hipdevicereset() &
          bind(c, name = 'hipDeviceReset')
       use, intrinsic :: iso_c_binding
       implicit none
     end function hipdevicereset
 
     subroutine hip_buffer_free_all() &
          bind(c, name = 'hip_buffer_free_all')
     end subroutine hip_buffer_free_all
 
     integer(c_int) function hipdevicegetname(name, len, device) &
          bind(c, name = 'hipDeviceGetName')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: name
       integer(c_int), value :: len
       integer(c_int), value :: device
     end function hipdevicegetname
 
     integer(c_int) function hipgetdevicecount(amount) &
          bind(c, name = 'hipGetDeviceCount')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: amount
     end function hipgetdevicecount
 
     integer(c_int) function hipstreamcreate(stream) &
          bind(c, name = 'hipStreamCreate')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: stream
     end function hipstreamcreate
 
     integer(c_int) function hipstreamcreatewithflags(stream, flags) &
          bind(c, name = 'hipStreamCreateWithFlags')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: stream
       integer(c_int), value :: flags
     end function hipstreamcreatewithflags
 
     integer(c_int) function hipstreamcreatewithpriority(stream, flags, prio) &
          bind(c, name = 'hipStreamCreateWithPriority')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: stream
       integer(c_int), value :: flags, prio
     end function hipstreamcreatewithpriority
 
     integer(c_int) function hipstreamdestroy(steam) &
          bind(c, name = 'hipStreamDestroy')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: steam
     end function hipstreamdestroy
 
     integer(c_int) function hipstreamsynchronize(stream) &
          bind(c, name = 'hipStreamSynchronize')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: stream
     end function hipstreamsynchronize
 
     integer(c_int) function hipstreamwaitevent(stream, event, flags) &
          bind(c, name = 'hipStreamWaitEvent')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: stream, event
       integer(c_int), value :: flags
     end function hipstreamwaitevent
 
     integer(c_int) function hipdevicegetstreampriorityrange(low_prio, &
          high_prio) &
          bind(c, name = 'hipDeviceGetStreamPriorityRange')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: low_prio, high_prio
     end function hipdevicegetstreampriorityrange
 
     integer(c_int) function hipeventcreate(event) &
          bind(c, name = 'hipEventCreate')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: event
     end function hipeventcreate
 
     integer(c_int) function hipeventdestroy(event) &
          bind(c, name = 'hipEventDestroy')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: event
     end function hipeventdestroy
 
     integer(c_int) function hipeventcreatewithflags(event, flags) &
          bind(c, name = 'hipEventCreateWithFlags')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr) :: event
       integer(c_int), value :: flags
     end function hipeventcreatewithflags
 
     integer(c_int) function hipeventrecord(event, stream) &
          bind(c, name = 'hipEventRecord')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: event, stream
     end function hipeventrecord
 
     integer(c_int) function hipeventsynchronize(event) &
          bind(c, name = 'hipEventSynchronize')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: event
     end function hipeventsynchronize
  end interface
 
contains
 
  subroutine hip_init(glb_cmd_queue, aux_cmd_queue, &
       STRM_HIGH_PRIO, STRM_LOW_PRIO)
    type(c_ptr), intent(inout) :: glb_cmd_queue
    type(c_ptr), intent(inout) :: aux_cmd_queue
    integer, intent(inout) :: STRM_HIGH_PRIO
    integer, intent(inout) :: STRM_LOW_PRIO
 
    if (hipdevicegetstreampriorityrange(strm_low_prio, strm_high_prio) &
         .ne. hipsuccess) then
       call neko_error('Error retrieving stream priority range')
    end if
 
    if (hipstreamcreatewithpriority(glb_cmd_queue, 1, strm_high_prio) &
         .ne. hipsuccess) then
       call neko_error('Error creating main stream')
    end if
 
    if (hipstreamcreatewithpriority(aux_cmd_queue, 1, strm_low_prio) &
         .ne. hipsuccess) then
       call neko_error('Error creating main stream')
    end if
  end subroutine hip_init
 
  subroutine hip_finalize(glb_cmd_queue, aux_cmd_queue)
    type(c_ptr), intent(inout) :: glb_cmd_queue
    type(c_ptr), intent(inout) :: aux_cmd_queue
    integer :: ierr
 
    ! Release all device buffers held by the device layer
    call hip_buffer_free_all()
 
    if (hipstreamdestroy(glb_cmd_queue) .ne. hipsuccess) then
       call neko_error('Error destroying main stream')
    end if
 
    if (hipstreamdestroy(aux_cmd_queue) .ne. hipsuccess) then
       call neko_error('Error destroying aux stream')
    end if
 
    ierr = hipdevicesynchronize()
 
    ! Best-effort context teardown to release runtime-owned allocations.
    ! Skipped in pFUnit-enabled builds: unit tests cycle device
    ! init/finalize with MPI still up, and device-aware communication
    ! backends (GPU-aware MPI, RCCL) cache device state from first
    ! use; resetting the device here would leave them with dangling
    ! handles
#ifndef HAVE_PFUNIT
    ierr = hipdevicereset()
#endif
  end subroutine hip_finalize
 
  subroutine hip_device_name(name)
    character(len=*), intent(inout) :: name
    character(kind=c_char, len=1024), target :: c_name
    integer :: end_pos
 
    if (hipdevicegetname(c_loc(c_name), 1024, 0) .ne. hipsuccess) then
       call neko_error('Failed to query device')
    end if
 
    end_pos = scan(c_name, c_null_char)
    if (end_pos .ge. 2) then
       name(1:end_pos-1) = c_name(1:end_pos-1)
    end if
 
  end subroutine hip_device_name
 
  integer function hip_device_count()
    type(c_ptr) :: hip_count_ptr
    integer :: amount
 
    if (hipgetdevicecount(amount) .ne. hipsuccess) then
       call neko_error('Failed to query device count')
    end if
 
    hip_device_count = amount
  end function hip_device_count
 
#endif
 
end module hip_intf