kmp_integer_8_apis.f90

Go to the documentation of this file.

! REQUIRES: flang
! RUN: %flang %flags %openmp_flags %s -o %t.exe
! RUN: %t.exe
 
! Fortran coverage of the 64-bit integer libomp entry points.
!
! The specific kmp_*_8 procedures are never named here. Every call uses the
! generic omp_*/kmp_* name with integer(8) actual arguments, so generic
! resolution in omp_lib is what selects the kmp_*_8 entry points. The 32-bit
! getters are used to verify the effects.
 
program kmp_integer_8_apis
  use omp_lib
  implicit none
  integer :: fails, i
  integer, parameter :: repetitions = 10
 
  fails = 0
 
  call test_disp_num_buffers()
  call test_stacksize()
  call test_blocktime()
  call test_library()
 
  do i = 1, repetitions
    call test_num_threads_and_team()
    call test_schedule()
    call test_max_active_levels()
    call test_teams()
    call test_default_device()
    call test_places()
    call test_affinity_mask()
  end do
 
  call test_pause_resource()
 
  if (fails /= 0) then
    print *, fails, ' check(s) failed'
    error stop 1
  end if
  print *, 'passed'
 
contains
 
  subroutine check(cond, msg)
    logical, intent(in) :: cond
    character(len=*), intent(in) :: msg
    if (.not. cond) then
      print *, 'FAIL: ', trim(msg)
      fails = fails + 1
    end if
  end subroutine check
 
  subroutine test_disp_num_buffers()
    call kmp_set_disp_num_buffers(8_8)
  end subroutine test_disp_num_buffers
 
  subroutine test_stacksize()
    integer(8) :: want
    integer(kmp_size_t_kind) :: got_s
    want = 8_8 * 1024_8 * 1024_8
    call kmp_set_stacksize(want)
    call check(kmp_get_stacksize() == int(want, kind=omp_integer_kind), &
         'kmp_set_stacksize(integer(8)) vs kmp_get_stacksize')
    got_s = kmp_get_stacksize_s()
    call check(got_s == int(want, kind=kmp_size_t_kind), &
         'kmp_set_stacksize(integer(8)) vs kmp_get_stacksize_s')
  end subroutine test_stacksize
 
  subroutine test_blocktime()
    call kmp_set_blocktime(200_8)
    call check(kmp_get_blocktime() == 200, 'kmp_set_blocktime(integer(8))')
  end subroutine test_blocktime
 
  subroutine test_library()
    ! enum library_type: none=0, serial=1, turnaround=2, throughput=3
    call kmp_set_library(3_8)
    call check(kmp_get_library() == 3, 'kmp_set_library(integer(8)) throughput')
    call kmp_set_library(2_8)
    call check(kmp_get_library() == 2, 'kmp_set_library(integer(8)) turnaround')
  end subroutine test_library
 
  subroutine test_num_threads_and_team()
    integer :: nthreads, nthreads_lib, team_err
    integer(8) :: level0, level1
 
    nthreads = 0
    nthreads_lib = -1
    team_err = 0
    level0 = 0_8
    level1 = 1_8
 
    call omp_set_dynamic(.false.)
    call omp_set_num_threads(2_8)
    call check(omp_get_max_threads() == 2, &
         'omp_set_num_threads(integer(8)) max_threads')
 
    call check(omp_get_ancestor_thread_num(level0) == 0, &
         'omp_get_ancestor_thread_num(0_8) serial')
    call check(omp_get_team_size(level0) == 1, &
         'omp_get_team_size(0_8) serial')
 
    !$omp parallel
    if (omp_get_ancestor_thread_num(level1) /= omp_get_thread_num() .or. &
        omp_get_team_size(level1) /= omp_get_num_threads() .or. &
        omp_get_ancestor_thread_num(level0) /= 0 .or. &
        omp_get_team_size(level0) /= 1) then
      !$omp atomic
      team_err = team_err + 1
    end if
    !$omp atomic
    nthreads = nthreads + 1
    !$omp single
    nthreads_lib = omp_get_num_threads()
    !$omp end single
    !$omp end parallel
 
    call check(team_err == 0, &
         'omp_get_ancestor_thread_num / omp_get_team_size with integer(8)')
    call check(nthreads == 2 .and. nthreads_lib == 2, 'parallel team size')
 
    call omp_set_num_threads(int(huge(0_4), kind=8) + 1000_8)
    call check(omp_get_max_threads() == huge(0_4), &
         'omp_set_num_threads(integer(8)) clamp to INT_MAX')
    call omp_set_num_threads(2_8)
  end subroutine test_num_threads_and_team
 
  subroutine test_schedule()
    integer(omp_sched_kind) :: kind
    integer(8) :: chunk
 
    kind = omp_sched_static
    chunk = 0_8
    call omp_set_schedule(omp_sched_dynamic, 7_8)
    call omp_get_schedule(kind, chunk)
    call check(kind == omp_sched_dynamic .and. chunk == 7_8, &
         'omp_set/get_schedule with integer(8) chunk, dynamic')
 
    call omp_set_schedule(omp_sched_guided, 1_8)
    call omp_get_schedule(kind, chunk)
    call check(kind == omp_sched_guided .and. chunk == 1_8, &
         'omp_set/get_schedule with integer(8) chunk, guided')
  end subroutine test_schedule
 
  subroutine test_max_active_levels()
    call omp_set_max_active_levels(1_8)
    call check(omp_get_max_active_levels() == 1, &
         'omp_set_max_active_levels(1_8)')
    call omp_set_max_active_levels(2_8)
    call check(omp_get_max_active_levels() >= 1, &
         'omp_set_max_active_levels(2_8)')
  end subroutine test_max_active_levels
 
  subroutine test_teams()
    call omp_set_num_teams(5_8)
    call check(omp_get_max_teams() == 5, 'omp_set_num_teams(5_8)')
    call omp_set_teams_thread_limit(7_8)
    call check(omp_get_teams_thread_limit() == 7, &
         'omp_set_teams_thread_limit(7_8)')
  end subroutine test_teams
 
  subroutine test_default_device()
    integer :: orig, after8, after32
    orig = omp_get_default_device()
    call omp_set_default_device(0_8)
    after8 = omp_get_default_device()
    call omp_set_default_device(0)
    after32 = omp_get_default_device()
    call check(after8 == after32, &
         'omp_set_default_device: integer(8) vs default integer')
    call omp_set_default_device(orig)
  end subroutine test_default_device
 
  subroutine test_places()
    integer :: nplaces, n32, n8, npart, i
    integer(omp_integer_kind), allocatable :: ids32(:), p32(:)
    integer(8), allocatable :: ids8(:), p8(:)
    integer(8) :: dummy(1)
 
    nplaces = omp_get_num_places()
    if (nplaces > 0) then
      n32 = omp_get_place_num_procs(0)
      n8 = omp_get_place_num_procs(0_8)
      call check(n32 == n8, 'omp_get_place_num_procs(0_8)')
      if (n32 > 0) then
        allocate(ids32(n32), ids8(n32))
        call omp_get_place_proc_ids(0, ids32)
        call omp_get_place_proc_ids(0_8, ids8)
        do i = 1, n32
          call check(ids32(i) == int(ids8(i), kind=omp_integer_kind), &
               'omp_get_place_proc_ids with integer(8) element')
        end do
        deallocate(ids32, ids8)
      end if
    else
      call check(omp_get_place_num_procs(0_8) == omp_get_place_num_procs(0), &
           'omp_get_place_num_procs(0_8) with no places')
    end if
 
    npart = omp_get_partition_num_places()
    if (npart > 0) then
      allocate(p32(npart), p8(npart))
      call omp_get_partition_place_nums(p32)
      call omp_get_partition_place_nums(p8)
      do i = 1, npart
        call check(p32(i) == int(p8(i), kind=omp_integer_kind), &
             'omp_get_partition_place_nums with integer(8) element')
      end do
      deallocate(p32, p8)
    else
      dummy(1) = -1_8
      call omp_get_partition_place_nums(dummy)
    end if
  end subroutine test_places
 
  subroutine test_affinity_mask()
    integer(kmp_affinity_mask_kind) :: mask
    integer :: max_proc, rc_set, rc_set32
    integer(8) :: proc0
 
    proc0 = 0_8
    call kmp_create_affinity_mask(mask)
    max_proc = kmp_get_affinity_max_proc()
    rc_set = kmp_set_affinity_mask_proc(proc0, mask)
    rc_set32 = kmp_set_affinity_mask_proc(0, mask)
    call check(rc_set == rc_set32, &
         'kmp_set_affinity_mask_proc: integer(8) vs default integer')
    if (rc_set == 0 .and. max_proc > 0) then
      call check(kmp_get_affinity_mask_proc(proc0, mask) == 1, &
           'kmp_get_affinity_mask_proc(integer(8)) after set')
      call check(kmp_unset_affinity_mask_proc(proc0, mask) == 0, &
           'kmp_unset_affinity_mask_proc(integer(8))')
      call check(kmp_get_affinity_mask_proc(proc0, mask) == 0, &
           'kmp_get_affinity_mask_proc(integer(8)) after unset')
    else
      rc_set = kmp_get_affinity_mask_proc(proc0, mask)
      rc_set = kmp_unset_affinity_mask_proc(proc0, mask)
    end if
    call kmp_destroy_affinity_mask(mask)
  end subroutine test_affinity_mask
 
  subroutine test_pause_resource()
    integer :: my_dev, nthreads
    integer(8) :: device8
 
    my_dev = omp_get_initial_device()
    device8 = int(my_dev, kind=8)
    nthreads = 0
    !$omp parallel
    !$omp single
    nthreads = omp_get_num_threads()
    !$omp end single
    !$omp end parallel
    call check(nthreads > 0, 'threads before pause')
 
    call check(omp_pause_resource(omp_pause_soft, device8) == 0, &
         'omp_pause_resource(integer(8) device) soft')
    nthreads = 0
    !$omp parallel
    !$omp single
    nthreads = omp_get_num_threads()
    !$omp end single
    !$omp end parallel
    call check(nthreads > 0, 'threads after pause soft')
 
    call check(omp_pause_resource(omp_pause_hard, device8) == 0, &
         'omp_pause_resource(integer(8) device) hard')
    nthreads = 0
    !$omp parallel
    !$omp single
    nthreads = omp_get_num_threads()
    !$omp end single
    !$omp end parallel
    call check(nthreads > 0, 'threads after pause hard')
  end subroutine test_pause_resource
 
end program kmp_integer_8_apis