gs_tune.f90

Go to the documentation of this file.

! Copyright (c) 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.
!
submodule(gather_scatter) gs_tune
  use gs_shmem, only : gs_shmem_avail
  use gs_caf, only : gs_caf_avail, gs_caf_usable, gs_caf_signal_auto, &
       gs_caf_signal_modes, gs_caf_mode_name, gs_caf_mode_get, &
       gs_caf_set_mode
  use gs_utofu, only : gs_utofu_avail
  implicit none
 
  integer, parameter :: GS_TUNE_BCKND(5) = [gs_comm_mpi, gs_comm_neighbour, &
       gs_comm_openshmem, gs_comm_caf, gs_comm_utofu]
 
  logical, parameter :: GS_TUNE_DEFAULT(5) = [.true., .true., .true., &
       .false., .true.]
 
  logical, save :: caf_signal_tuned = .false.
 
contains
 
  function gs_comm_host_cand() result(cand)
    integer, allocatable :: cand(:)
    character(len=LOG_SIZE) :: log_buf
    character(len=13) :: label
    logical :: sel(size(GS_TUNE_BCKND)), named(size(GS_TUNE_BCKND))
    integer :: c(size(GS_TUNE_BCKND)), i, n
 
    call gs_tune_select(sel, named)
 
    n = 0
    do i = 1, size(gs_tune_bcknd)
       if (.not. sel(i)) cycle
       if (gs_comm_tunable(gs_tune_bcknd(i))) then
          n = n + 1
          c(n) = gs_tune_bcknd(i)
       else if (named(i)) then
          ! Asked for by name, but this build or run cannot drive it: say so
          ! rather than leaving the candidate quietly missing from the
          ! comparison below
          label = adjustl(gs_comm_name(gs_tune_bcknd(i)))
          write(log_buf, '(A,A,A12)') label, ': ', 'unavailable'
          call neko_log%message(log_buf)
       end if
    end do
 
    allocate(cand(n))
    cand = c(1:n)
 
  end function gs_comm_host_cand
 
  function gs_comm_tunable(comm_bcknd) result(tunable)
    integer, intent(in) :: comm_bcknd
    logical :: tunable
 
    select case (comm_bcknd)
    case (gs_comm_mpi, gs_comm_neighbour)
       tunable = .true.
    case (gs_comm_openshmem)
       ! The one-sided backends that address their peers by global PE or
       ! image number (OpenSHMEM PEs, coarray images) are only correct when
       ! NEKO_COMM spans every process, so skip them when the run has been
       ! split into several communicators (NEKO_COMM_ID). uTofu exchanges
       ! its addresses over NEKO_COMM itself and is unaffected.
       tunable = gs_shmem_avail .and. (pe_size .eq. global_pe_size)
    case (gs_comm_caf)
       ! Coarray support at configure time says nothing about the job
       ! actually running more than one image, see gs_caf_usable
       tunable = gs_caf_avail .and. gs_caf_usable() .and. &
            (pe_size .eq. global_pe_size)
    case (gs_comm_utofu)
       tunable = gs_utofu_avail
    case default
       tunable = .false.
    end select
 
  end function gs_comm_tunable
 
  subroutine gs_tune_select(sel, named)
    logical, intent(out) :: sel(:), named(:)
    character(len=255) :: env_val
    character(len=32) :: tok, name
    character(len=1) :: op
    integer :: env_len, i, j, k
    logical :: delta, first
 
    sel = gs_tune_default
    named = .false.
 
    call get_environment_variable("NEKO_GS_TUNE", env_val, env_len)
    if (env_len .eq. 0) return
    ! env_len is the length of the value, which may well exceed the buffer
    env_len = min(env_len, len(env_val))
 
    delta = .false.
    first = .true.
    i = 1
    do while (i .le. env_len)
       if (scan(env_val(i:i), ', ') .ne. 0) then
          i = i + 1
          cycle
       end if
 
       j = i
       do while (j .le. env_len)
          if (scan(env_val(j:j), ', ') .ne. 0) exit
          j = j + 1
       end do
       tok = gs_tune_upcase(env_val(i:j-1))
       i = j
 
       op = ' '
       name = tok
       if (tok(1:1) .eq. '+' .or. tok(1:1) .eq. '-') then
          op = tok(1:1)
          name = tok(2:)
       end if
 
       if (first) then
          ! The first name decides how the list is read; a plain one starts
          ! the set from nothing rather than from the default
          delta = (op .ne. ' ')
          if (.not. delta) sel = .false.
          first = .false.
       else if ((op .ne. ' ') .neqv. delta) then
          call neko_error('NEKO_GS_TUNE: plain backend names and +/- ' // &
               'prefixed ones cannot be mixed')
       end if
 
       k = gs_tune_index(name)
       if (k .eq. 0) then
          call neko_error('NEKO_GS_TUNE: not a tunable Gather-scatter ' // &
               'comm. backend: ' // trim(name))
       end if
       sel(k) = (op .ne. '-')
       named(k) = .true.
    end do
 
  end subroutine gs_tune_select
 
  function gs_tune_index(name) result(idx)
    character(len=*), intent(in) :: name
    integer :: idx, bcknd, i
 
    select case (trim(name))
    case ('MPI')
       bcknd = gs_comm_mpi
    case ('NEIGHBOUR', 'NEIGHBOR')
       bcknd = gs_comm_neighbour
    case ('SHMEM', 'OPENSHMEM')
       bcknd = gs_comm_openshmem
    case ('CAF')
       bcknd = gs_comm_caf
    case ('UTOFU')
       bcknd = gs_comm_utofu
    case default
       bcknd = 0
    end select
 
    idx = 0
    do i = 1, size(gs_tune_bcknd)
       if (gs_tune_bcknd(i) .eq. bcknd) idx = i
    end do
 
  end function gs_tune_index
 
  function gs_tune_upcase(str) result(upper)
    character(len=*), intent(in) :: str
    character(len=len(str)) :: upper
    integer :: i, c
 
    do i = 1, len(str)
       c = iachar(str(i:i))
       if (c .ge. iachar('a') .and. c .le. iachar('z')) then
          upper(i:i) = achar(c - (iachar('a') - iachar('A')))
       else
          upper(i:i) = str(i:i)
       end if
    end do
 
  end function gs_tune_upcase
 
  subroutine gs_comm_switch(gs, comm_bcknd)
    type(gs_t), intent(inout) :: gs
    integer, intent(in) :: comm_bcknd
    class(gs_comm_t), allocatable :: comm_new
 
    call gs_comm_alloc(comm_new, comm_bcknd)
    call comm_new%take_schedule(gs%comm)
    call gs%comm%free()
    deallocate(gs%comm)
    call move_alloc(comm_new, gs%comm)
    call gs%comm%init_schedule()
 
  end subroutine gs_comm_switch
 
  module function gs_time_ops(gs, u, n, op, ntrials) result(t)
    type(gs_t), intent(inout) :: gs
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, intent(in) :: op, ntrials
    real(kind=dp) :: t
    integer :: i
 
    do i = 1, gs_tune_nwarmup
       call gs_op_vector(gs, u, n, op)
    end do
 
    if (neko_bcknd_device .eq. 1) call device_sync
    call mpi_barrier(neko_comm)
 
    t = mpi_wtime()
    do i = 1, ntrials
       call gs_op_vector(gs, u, n, op)
    end do
    if (neko_bcknd_device .eq. 1) call device_sync
    t = (mpi_wtime() - t) / real(ntrials, dp)
 
  end function gs_time_ops
 
  module subroutine gs_tune_comm(gs, n, comm_bcknd)
    type(gs_t), intent(inout) :: gs
    integer, intent(in) :: n
    integer, intent(in) :: comm_bcknd
    character(len=LOG_SIZE) :: log_buf
    character(len=13) :: label
    integer, allocatable :: cand(:)
    real(kind=dp), allocatable :: cand_time(:)
    real(kind=rp), allocatable :: tmp(:)
    type(c_ptr) :: tmp_d
    integer :: i, best, nmin, cur
 
    allocate(cand, source = gs_comm_host_cand())
 
    ! Track what gs is running as the sweep proceeds. The candidate list
    ! need neither start with the backend the schedule was built with nor
    ! contain it at all, and switching is what costs, so every candidate is
    ! switched to exactly once
    cur = comm_bcknd
 
    ! A rank without any dofs skips the halo exchange in gs_op_vector, which
    ! would leave every other rank hanging in a collective based backend.
    ! Keep the current backend in that case. NEKO_GS_TUNE may also have left
    ! us with nothing to compare, in which case a lone candidate is simply
    ! switched to, as if it had been requested with NEKO_GS_COMM.
    nmin = n
    call mpi_allreduce(mpi_in_place, nmin, 1, mpi_integer, mpi_min, neko_comm)
    if (nmin .eq. 0 .or. size(cand) .lt. 2) then
       call neko_log%message('Comm tuning  :      skipped')
       if (nmin .gt. 0 .and. size(cand) .eq. 1) then
          if (cand(1) .ne. cur) call gs_comm_switch(gs, cand(1))
          cur = cand(1)
       end if
       call neko_log%message('Tuned comm   : ' // gs_comm_name(cur))
       return
    end if
 
    allocate(cand_time(size(cand)))
 
    tmp_d = c_null_ptr
    allocate(tmp(n))
    tmp = 1.0_rp
    if (neko_bcknd_device .eq. 1) then
       call device_map(tmp, tmp_d, n)
       call device_memcpy(tmp, tmp_d, n, host_to_device, sync = .false.)
    end if
 
    ! GS_OP_MIN leaves the working vector untouched, so the benchmark can
    ! run for any number of trials without the values growing out of range
    do i = 1, size(cand)
       if (cand(i) .eq. gs_comm_caf .and. gs_caf_signal_auto() .and. &
            .not. caf_signal_tuned) then
          ! Benchmark the signaling modes as well; this leaves the CAF
          ! backend allocated in the winning mode
          cand_time(i) = gs_tune_caf_signal(gs, tmp, n)
          caf_signal_tuned = .true.
       else
          if (cand(i) .ne. cur) call gs_comm_switch(gs, cand(i))
          cand_time(i) = gs_time_ops(gs, tmp, n, gs_op_min, gs_tune_ntrials)
       end if
       cur = cand(i)
    end do
 
    if (neko_bcknd_device .eq. 1) call device_unmap(tmp, tmp_d)
    deallocate(tmp)
 
    call mpi_allreduce(mpi_in_place, cand_time, size(cand), &
         mpi_double_precision, mpi_sum, neko_comm)
    cand_time = cand_time / pe_size
 
    best = minloc(cand_time, 1)
 
    do i = 1, size(cand)
       label = adjustl(gs_comm_name(cand(i)))
       ! What the coarray backend costs depends on the signaling mode in
       ! force, so report the timing under the mode it was measured in
       if (cand(i) .eq. gs_comm_caf .and. gs_caf_mode_get() .ne. 0) then
          label = 'CAF (' // &
               trim(adjustl(gs_caf_mode_name(gs_caf_mode_get()))) // ')'
       end if
       ! ES10.3 + ' s' fills the same 12 columns as the right-adjusted
       ! backend names, so the unit lines up with their last letter
       write(log_buf, '(A,A,ES10.3,A)') label, ': ', cand_time(i), ' s'
       call neko_log%message(log_buf)
    end do
 
    if (cand(best) .ne. cur) call gs_comm_switch(gs, cand(best))
 
    call neko_log%message('Tuned comm   : ' // gs_comm_name(cand(best)))
 
    deallocate(cand_time)
 
  end subroutine gs_tune_comm
 
  function gs_tune_caf_signal(gs, u, n) result(t)
    type(gs_t), intent(inout) :: gs
    integer, intent(in) :: n
    real(kind=rp), dimension(n), intent(inout) :: u
    real(kind=dp) :: t
    character(len=LOG_SIZE) :: log_buf
    character(len=13) :: label
    integer, allocatable :: mode(:)
    real(kind=dp), allocatable :: mode_time(:)
    integer :: i, best
 
    allocate(mode, source = gs_caf_signal_modes())
    allocate(mode_time(size(mode)))
 
    do i = 1, size(mode)
       ! Bind the mode before building the backend: gs_caf_init sets up its
       ! per-instance signaling state according to the mode in force
       call gs_caf_set_mode(mode(i))
       call gs_comm_switch(gs, gs_comm_caf)
       mode_time(i) = gs_time_ops(gs, u, n, gs_op_min, gs_tune_ntrials)
    end do
 
    call mpi_allreduce(mpi_in_place, mode_time, size(mode), &
         mpi_double_precision, mpi_sum, neko_comm)
    mode_time = mode_time / pe_size
 
    best = minloc(mode_time, 1)
 
    do i = 1, size(mode)
       label = 'CAF ' // adjustl(gs_caf_mode_name(mode(i)))
       write(log_buf, '(A,A,ES10.3,A)') label, ': ', mode_time(i), ' s'
       call neko_log%message(log_buf)
    end do
 
    ! The last mode is the one currently allocated
    if (best .ne. size(mode)) then
       call gs_caf_set_mode(mode(best))
       call gs_comm_switch(gs, gs_comm_caf)
    end if
 
    call neko_log%message('Tuned CAF sig: ' // gs_caf_mode_name(mode(best)))
 
    t = mode_time(best)
 
    deallocate(mode, mode_time)
 
  end function gs_tune_caf_signal
 
end submodule gs_tune