Use a non-blocking lock for coordinating memory reporting

source/utility.locks.F90

@@ -39,14 +39,16 @@ An OpenMP lock type that does no locking. Useful when a function expects a lock,
    contains
      !![
      <methods>
-       <method description="Obtain a lock on the object."          method="set"       />
-       <method description="Release a lock on the object."         method="unset"     />
-       <method description="(Re)initialize an OpenMP lock object." method="initialize"/>
+       <method description="Obtain a lock on the object."                                                              method="set"           />
+       <method description="Attempt to obtain a lock on the object, returning false (without blocking) if this fails." method="setNonBlocking"/>
+       <method description="Release a lock on the object."                                                             method="unset"         />
+       <method description="(Re)initialize an OpenMP lock object."                                                     method="initialize"    />
      </methods>
      !!]
-     procedure :: initialize => ompLockClassInitialize
-     procedure :: set        => ompLockClassSet
-     procedure :: unset      => ompLockClassUnset
+     procedure :: initialize     => ompLockClassInitialize
+     procedure :: set            => ompLockClassSet
+     procedure :: setNonBlocking => ompLockClassSetNonBlocking
+     procedure :: unset          => ompLockClassUnset
   end type ompLockClass
 
   type, extends(ompLockClass) :: ompLock
@@ -62,11 +64,12 @@ An OpenMP lock type that does no locking. Useful when a function expects a lock,
        <method description="Return true if the current thread already owns this lock." method="ownedByThread"/>
      </methods>
      !!]
-     final     ::                  ompLockDestructor
-     procedure :: initialize    => ompLockInitialize
-     procedure :: set           => ompLockSet
-     procedure :: unset         => ompLockUnset
-     procedure :: ownedByThread => ompLockOwnedByThread
+     final     ::                   ompLockDestructor
+     procedure :: initialize     => ompLockInitialize
+     procedure :: set            => ompLockSet
+     procedure :: setNonBlocking => ompLockSetNonBlocking
+     procedure :: unset          => ompLockUnset
+     procedure :: ownedByThread  => ompLockOwnedByThread
   end type ompLock
 
   interface ompLock
@@ -162,6 +165,18 @@ subroutine ompLockClassSet(self)
     return
   end subroutine ompLockClassSet
 
+  logical function ompLockClassSetNonBlocking(self) result(success)
+    !!{
+    Get a lock on an OpenMP null lock objects.
+    !!}
+    implicit none
+    class(ompLockClass), intent(inout) :: self
+    !$GLC attributes unused :: self
+
+    success=.true.
+    return
+  end function ompLockClassSetNonBlocking
+
   subroutine ompLockClassUnset(self)
     !!{
     Release a lock on an OpenMP null lock objects.
@@ -225,6 +240,22 @@ subroutine ompLockSet(self)
     return
   end subroutine ompLockSet
 
+  logical function ompLockSetNonBlocking(self) result(success)
+    !!{
+    Attempt to get a lock on an OpenMP lock object, returning false if this fails without blocking.
+    !!}
+    !$ use :: OMP_Lib, only : OMP_Get_Thread_Num, OMP_Test_Lock
+    implicit none
+    class(ompLock), intent(inout) :: self
+
+    success=.true.
+    !$ success=OMP_Test_Lock(self%lock)
+    if (.not.success) return
+    self%ownerThread=0
+    !$ self%ownerThread=OMP_Get_Thread_Num()
+    return
+  end function ompLockSetNonBlocking
+
   subroutine ompLockUnset(self)
     !!{
     Release a lock on an OpenMP lock objects.

source/utility.memory_reporting.F90

@@ -30,13 +30,18 @@ module Memory_Reporting
   !!}
   use            :: Error        , only : Error_Report
   use, intrinsic :: ISO_C_Binding, only : c_size_t    , c_int
+  use            :: Locks        , only : ompLock
   implicit none
   private
   public :: reportMemoryUsage
 
   ! Code memory size initialization status.
   logical           :: codeMemoryUsageInitialized =.false.
 
+  ! Lock used to coordinate memory reporting.
+  type   (ompLock ) :: memoryUsageLock
+  logical           :: memoryUsageLockInitialized =.false.
+
   ! Count of number of successive decreases in memory usage.
   integer           :: successiveDecreaseCount    =0
 
@@ -47,7 +52,7 @@ module Memory_Reporting
   integer(c_size_t) :: memoryUsageMaximum         =0
 
   ! Record of code size and available memory.
-  integer(c_size_t) :: memoryUsageCode                   , memoryAvailable
+  integer(c_size_t) :: memoryUsageCode                    , memoryAvailable
 
   ! Interface to getpagesize() function.
   interface
@@ -90,15 +95,24 @@ subroutine reportMemoryUsage()
     character       (len =2        )            :: suffix
     character       (len =7        )            :: label
     double precision                            :: memoryFraction
-
-    !$omp critical(memoryUsageReport)
+
+    if (.not.memoryUsageLockInitialized) then
+       !$omp critical(memoryUsageReport)
+       if (.not.memoryUsageLockInitialized) then
+          memoryUsageLock           =ompLock()
+          memoryUsageLockInitialized=.true.
+       end if
+       !$omp end critical(memoryUsageReport)
+    end if
+    ! Attempt to get a lock to coordinate memory usage reporting - if the lock is held by another thread, just return (no need for
+    ! us to report memory also).
+    if (.not.memoryUsageLock%setNonBlocking()) return
     ! Ensure that we have the code memory usage.
     call codeUsageGet()
     ! Get the current memory usage.
     memoryUsage=+memoryUsageCode   &
          &      +mallinfo2_C    ()
     ! Record the maximum memory usage.
-    !$omp atomic
     memoryUsageMaximum=max(memoryUsageMaximum,memoryUsage)
     ! Decide whether to report.
     issueNewReport=.false.
@@ -143,7 +157,7 @@ subroutine reportMemoryUsage()
        ! Display the report.
        call displayMessage(usageText)
     end if
-    !$omp end critical(memoryUsageReport)
+    call memoryUsageLock%unset()
     return
   end subroutine reportMemoryUsage