! $Id: CrtMemoryUtilities.f90 1976 2013-07-11 03:59:01Z ian $
!> @file
!! Defines the CrtMemoryUtilities module.

!*******************************************************************************
!!
!> Fortran interfaces to the C runtime debug functions.
!!
!! Selection out of crtdbg.h and related header files of some of the debug 
!! C runtime support routines, types and defines.  Notionally VS2010 specific, 
!! but I can't imagine they change this stuff all that often.
!!
!! General assumption made that BIND(C) applies - i.e. that there aren't 
!! bizarre pragma's or similar in effect when that header file is compiled.  
!! Perhaps this is a bit brave.
!!
!! If you reference this module in a build that doesn't use /dbglibs (or 
!! the /MTd or /MDd equivalent) then the linker will throw a patsy.  If you 
!! don't use /libs:static then the CRT memory allocation debug variants aren't 
!! used by the Fortran runtime.  (/MTd covers both those cases.)

MODULE CrtMemoryUtilities
  
  USE, INTRINSIC :: ISO_C_BINDING, ONLY:  &
      C_SIZE_T, C_PTR, C_INT, C_INTPTR_T, C_CHAR, C_LONG
  
  IMPLICIT NONE
  
  PRIVATE
  
  PUBLIC :: CrtCheckMemory
  PUBLIC :: CrtSetReportMode
  PUBLIC :: CrtSetReportFile
  PUBLIC :: CrtMemCheckpoint
  PUBLIC :: CrtMemDifference
  PUBLIC :: CrtMemDumpStatistics
  PUBLIC :: CrtMemDumpAllObjectsSince
  PUBLIC :: CrtDumpMemoryLeaks
  
  PUBLIC :: GetCrtHeapHandle
  
  !-----------------------------------------------------------------------------
  ! Constants and types.
  !
  ! Most of the constants are defines.  We've specified most of them as 
  ! INTEGER(C_INT) because that's the equivalent type and kind of the 
  ! literal that the define defines.
  
  ! Number of allocation types.
  !
  ! NORMAL_BLOCK is (hopefully) the only one of interest, so this is the 
  ! only one that's public.  For the value of MAX_BLOCK you can use 
  ! SIZE(CrtMemState_object%lCounts), etc.
  INTEGER(C_INT), PARAMETER :: FREE_BLOCK           = 0
  INTEGER(C_INT), PUBLIC, PARAMETER :: NORMAL_BLOCK = 1
  INTEGER(C_INT), PARAMETER :: CRT_BLOCK            = 2
  INTEGER(C_INT), PARAMETER :: IGNORE_BLOCK         = 3
  INTEGER(C_INT), PARAMETER :: CLIENT_BLOCK         = 4
  INTEGER(C_INT), PARAMETER :: MAX_BLOCKS           = 5
  
  !> Summary of current debug heap state (or difference in state).
  TYPE, PUBLIC, BIND(C) :: CrtMemState
    TYPE(C_PTR) :: pBlockHeader             ! struct _CrtMemBlockHeader*
    ! I refuse to admit that it took me half a day to work out that the 
    ! reason this wasn't working was because I forgot C had zero based 
    ! array indices.
    INTEGER(C_SIZE_T) :: lCounts(0:MAX_BLOCKS-1)
    INTEGER(C_SIZE_T) :: lSizes(0:MAX_BLOCKS-1)
    INTEGER(C_SIZE_T) :: lHighWaterCount
    INTEGER(C_SIZE_T) :: lTotalCount
  END TYPE CrtMemState
  
  ! Options for reportType
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRT_WARN     = 0
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRT_ERROR    = 1
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRT_ASSERT   = 2
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRT_ERRCNT   = 3
  
  ! Set report mode options for reportMode.
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRTDBG_MODE_FILE   = INT(Z'01')
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRTDBG_MODE_DEBUG  = INT(Z'02')
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRTDBG_MODE_WNDW   = INT(Z'04')
  INTEGER(C_INT), PUBLIC, PARAMETER :: CRTDBG_REPORT_MODE = -1
  
  ! _HFILE options (other than a HFILE)
  INTEGER(C_INTPTR_T), PUBLIC, PARAMETER :: CRTDBG_INVALID_HFILE  = -1
  INTEGER(C_INTPTR_T), PUBLIC, PARAMETER :: CRTDBG_HFILE_ERROR    = -2
  INTEGER(C_INTPTR_T), PUBLIC, PARAMETER :: CRTDBG_FILE_STDOUT    = -4
  INTEGER(C_INTPTR_T), PUBLIC, PARAMETER :: CRTDBG_FILE_STDERR    = -5
  INTEGER(C_INTPTR_T), PUBLIC, PARAMETER :: CRTDBG_FILE_FILE      = -6
  
  !> Size of the no mans land before (and after) the user allocation.
  INTEGER, PARAMETER :: nNoMansLandSize = 4
  
  !> Header information for each block allocated on the debug heap.
  !!
  !! Popped this in in case we want to walk the heap, but I haven't used 
  !! it yet.
  TYPE, PUBLIC, BIND(C) :: CrtMemBlockHeader
    TYPE(C_PTR) :: pBlockHeaderNext         ! struct _CrtMemBlockHeader*
    TYPE(C_PTR) :: pBlockHeaderpREV         ! struct _CrtMemBlockHeader*
    TYPE(C_PTR) :: szFileName               ! char *
    INTEGER(C_INT) :: nLine
    ! On x64 the order of the next two members are reversed from the 32 bit 
    ! variant to keep the structure packed and aligned all nicely.  Academic 
    ! for me until the CFO ponies up more cash, but hopefully this 
    ! directive covers it.
!DEC$ IF DEFINED(_M_IA64) .OR. DEFINED(_M_AMD64) .OR. DEFINED(__x86_64__)
    INTEGER(C_INT) :: nBlockUse
    INTEGER(C_SIZE_T) :: nDataSize
!DEC$ ELSE
    INTEGER(C_SIZE_T) :: nDataSize
    INTEGER(C_INT) :: nBlockUse
!DEC$ END IF
    INTEGER(C_LONG) :: lRequest
    CHARACTER(C_CHAR) :: gap(nNoMansLandSize)
    ! Psuedo fields that follow.
    !CHARACTER(C_CHAR) :: data(nDataSize)
    !CHARACTER(C_CHAR) :: anotherGap(nNoMansLandSize)
  END TYPE CrtMemBlockHeader
  
  !-----------------------------------------------------------------------------
  ! Procedure interfaces.
  
  INTERFACE
    !> Confirms the integrity of the memory blocks allocated in the debug 
    !! heap.
    FUNCTION CrtCheckMemory() BIND(C, NAME='_CrtCheckMemory')
      USE, INTRINSIC :: ISO_C_BINDING
      IMPLICIT NONE
      INTEGER(C_INT) :: CrtCheckMemory
    END FUNCTION CrtCheckMemory
    
    !> Specifies the destination or destinations for a specific report type.
    FUNCTION CrtSetReportMode(reportType, reportMode)  &
        BIND(C, NAME='_CrtSetReportMode')
      USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT
      IMPLICIT NONE
      INTEGER(C_INT), INTENT(IN), VALUE :: reportType
      INTEGER(C_INT), INTENT(IN), VALUE :: reportMode
      INTEGER(C_INT) :: CrtSetReportMode
    END FUNCTION CrtSetReportMode
    
    !> Specifies the file handle to receive report text if the report mode 
    !! for the relevant report type is CRTDBG_MODE_FILE.
    FUNCTION CrtSetReportFile(reportType, reportFile)  &
        BIND(C, NAME='_CrtSetReportFile')
      USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT, C_INTPTR_T
      IMPLICIT NONE
      INTEGER(C_INT), INTENT(IN), VALUE :: reportType
      ! Using INTEGER(C_INTPTR_T) for _HFILE, which is a typedef of void*
      INTEGER(C_INTPTR_T), INTENT(IN), VALUE :: reportFile    ! _HFILE
      INTEGER(C_INTPTR_T) :: CrtSetReportFile                 ! _HFILE
    END FUNCTION CrtSetReportFile
    
    !> Capture a summary of the current debug heap.
    SUBROUTINE CrtMemCheckpoint(state)  &
        BIND(C, NAME='_CrtMemCheckpoint')
      IMPORT :: CrtMemState
      IMPLICIT NONE
      TYPE(CrtMemState), INTENT(OUT) :: state
    END SUBROUTINE CrtMemCheckpoint
    
    !> Calculate the difference between two summaries of the debug heap.
    FUNCTION CrtMemDifference(stateDiff, oldState, newState)  &
        BIND(C, NAME='_CrtMemDifference')
      USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT
      IMPORT :: CrtMemState
      IMPLICIT NONE
      TYPE(CrtMemState), INTENT(OUT) :: stateDiff
      TYPE(CrtMemState), INTENT(IN) :: oldState
      TYPE(CrtMemState), INTENT(IN) :: newState
      INTEGER(C_INT) :: CrtMemDifference
    END FUNCTION CrtMemDifference
    
    !> Dump a summary (or difference) of the debug heap to the debug report.
    SUBROUTINE CrtMemDumpStatistics(state)  &
        BIND(C, NAME='_CrtMemDumpStatistics')
      IMPORT :: CrtMemState
      IMPLICIT NONE
      TYPE(CrtMemState), INTENT(IN) :: state
    END SUBROUTINE CrtMemDumpStatistics
    
    !> Test if there are outstanding allocations and, if so, dump them.
    !!
    !! Non-zero return means that outstanding allocations were found.
    FUNCTION CrtDumpMemoryLeaks()  &
        BIND(C, NAME='_CrtDumpMemoryLeaks')
      USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT
      IMPLICIT NONE
      INTEGER(C_INT) :: CrtDumpMemoryLeaks
    END FUNCTION CrtDumpMemoryLeaks
  END INTERFACE
  
  !> Allow CrtDumpAllObjects to be called with a C_NULL_PTR instead of 
  !! a CrtMemState object.
  INTERFACE CrtMemDumpAllObjectsSince
    !> Dump all objects since the state was captured, or since program start.
    !!
    !! (Variant to allow passing a C_NULL_PTR for state.)
    SUBROUTINE CrtMemDumpAllObjectsSince_ptr(state)  &
        BIND(C, NAME='_CrtMemDumpAllObjectsSince')
      USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
      IMPLICIT NONE
      TYPE(C_PTR), INTENT(IN), VALUE :: state
    END SUBROUTINE CrtMemDumpAllObjectsSince_ptr
    
    ! Variant that takes a CrtMemState argument.
    MODULE PROCEDURE CrtMemDumpAllObjectsSince_memstate
  END INTERFACE CrtMemDumpAllObjectsSince
  
CONTAINS
  
  !*****************************************************************************
  !!
  !> Specific procedure for the CrtMemDumpAllObjectsSince generic that takes 
  !! a CrtMemState argument.
  !!
  
  SUBROUTINE CrtMemDumpAllObjectsSince_memstate(state)
    
    USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LOC
    
    !---------------------------------------------------------------------------
    ! Arguments
    
    TYPE(CrtMemState), INTENT(IN), TARGET :: state
    
    !***************************************************************************
    
    CALL CrtMemDumpAllObjectsSince(C_LOC(state))
    
  END SUBROUTINE CrtMemDumpAllObjectsSince_memstate
  
  
  !*****************************************************************************
  !!
  !> Get the Heap* API handle for the CRT heap.
  !!
  
  FUNCTION GetCrtHeapHandle()
    
    USE IFWINTY, ONLY: HANDLE
    
    !---------------------------------------------------------------------------
    ! Characteristics
    
    INTEGER(HANDLE) :: GetCrtHeapHandle
    
    !---------------------------------------------------------------------------
    ! Local variables
    
    ! Gumpf to get the heap handle used by the CRT.
    COMMON /crtheapcommon/ crt_heap
    INTEGER(HANDLE) :: crt_heap
    BIND(C, NAME='_crtheap') :: crtheapcommon
    
    !***************************************************************************
    
    GetCrtHeapHandle = crt_heap
    
  END FUNCTION GetCrtHeapHandle
  
END MODULE CrtMemoryUtilities
