{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE Safe #-}

-- |
-- Copyright   :  (C) 2015-2021 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  GHC
--
-- This module supplies a variant of the selfish form of
-- <http://www.cs.canisius.edu/~hertzm/prmm-ismm-2011.pdf "Poor Richard's Memory Manager">
-- by Hertz, Kane, Keudel, Bai, Ding, Gu and Bard, adapted to run in
-- Haskell in user-space.
--
-- Due to the fact that Haskell returns memory to the operating system and doesn't really
-- tell me about it, this follows their 'GenMS+Selfish' (without RSS) scheme.
--
-- Usage:
--
-- @
-- main = do
--   _ <- 'selfishManager'
--   ...
-- @
--
-- Now, the background thread that was spawned by 'selfishManager' will watch for signs that the host operating system
-- is starting to cause the current process to page out to disk and respond with more aggressive garbage collection.
--
-- This empowers your code to try to avoid the inevitable death spiral that follows when GC has to happen with paged out data.


module System.Mem.Manager
  ( -- * Memory Manager
    selfishManager
    -- * Statistics and Utilities
  , hardPageFaults
  ) where

import Control.Concurrent
import Control.Monad
import Data.IORef
import Foreign.C.Types
import System.Mem

-- | Return the total number of \"hard page-faults\" since the program started. These are page-faults which required us to go out to disk.
foreign import ccall "getHardPageFaults" hardPageFaults :: IO CSize

-- | Run a background thread that checks for signs of memory pressure from the Host OS and kickstarts a garbage collection as needed. Returns the thread for the selfish gc manager and an IO action
-- that can be run to count the cumulative number of managed collections
selfishManager :: IO (ThreadId, IO Int)
selfishManager :: IO (ThreadId, IO Int)
selfishManager = do
  IORef Int
collections <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  ThreadId
threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    CSize
faults <- IO CSize
hardPageFaults
    let go :: CSize -> IO b
go CSize
oldFaults = do
          CSize
newFaults <- IO CSize
hardPageFaults
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CSize
newFaults CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
>= CSize
oldFaults CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
+ CSize
10) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO ()
performMajorGC
            IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
collections (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          Int -> IO ()
threadDelay Int
50000
          CSize -> IO b
go CSize
newFaults
    CSize -> IO ()
forall {b}. CSize -> IO b
go CSize
faults
  (ThreadId, IO Int) -> IO (ThreadId, IO Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId
threadId, IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
collections)