{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  GHC.Event.Windows.ManagedThreadPool
-- Copyright   :  (c) Tamar Christina 2019
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  non-portable
--
-- WinIO Windows Managed Thread pool API.  This thread pool scales dynamically
-- based on demand.
--
-------------------------------------------------------------------------------

module GHC.Event.Windows.ManagedThreadPool
  ( ThreadPool(..)
  , startThreadPool
  , notifyRunning
  , notifyWaiting
  , monitorThreadPool
  ) where

import Control.Concurrent.MVar
import Data.Maybe
import Foreign
import GHC.Base
import GHC.Num ((-), (+))
import GHC.Real (fromIntegral)
import qualified GHC.Event.Array as A
import GHC.IO.Handle.Internals (debugIO)
import GHC.Conc.Sync (ThreadId(..))
import GHC.RTS.Flags

------------------------------------------------------------------------
-- Thread spool manager

type WorkerJob = IO ()

-- | Thread pool manager state
data ThreadPool = ThreadPool
  { ThreadPool -> Maybe ThreadId
thrMainThread    :: Maybe ThreadId
  , ThreadPool -> Int
thrMaxThreads    :: {-# UNPACK #-} !Int
  , ThreadPool -> Int
thrMinThreads    :: {-# UNPACK #-} !Int
  , ThreadPool -> Int
thrCurThreads    :: {-# UNPACK #-} !Int
  , ThreadPool -> WorkerJob
thrCallBack      :: WorkerJob
  , ThreadPool -> MVar Int
thrActiveThreads :: MVar Int
  , ThreadPool -> MVar ()
thrMonitor       :: MVar ()
  , ThreadPool -> Array ThreadId
thrThreadIds     :: {-#UNPACK #-} !(A.Array ThreadId)
  }

startThreadPool :: WorkerJob -> IO ThreadPool
startThreadPool :: WorkerJob -> IO ThreadPool
startThreadPool WorkerJob
job = do
  String -> WorkerJob
debugIO String
"Starting I/O manager threadpool..."
  let thrMinThreads :: Int
thrMinThreads = Int
2
  let thrCurThreads :: Int
thrCurThreads = Int
0
  let thrCallBack :: WorkerJob
thrCallBack   = WorkerJob
job
  Int
thrMaxThreads     <- (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> (MiscFlags -> Word32) -> MiscFlags -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiscFlags -> Word32
numIoWorkerThreads) (MiscFlags -> Int) -> IO MiscFlags -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO MiscFlags
getMiscFlags
  MVar Int
thrActiveThreads  <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
  MVar ()
thrMonitor        <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  Array ThreadId
thrThreadIds      <- IO (Array ThreadId)
forall a. HasCallStack => a
undefined -- A.new thrMaxThreads
  let thrMainThread :: Maybe a
thrMainThread = Maybe a
forall a. Maybe a
Nothing

  let !pool :: ThreadPool
pool = ThreadPool{Int
Maybe ThreadId
WorkerJob
MVar Int
MVar ()
Array ThreadId
forall a. Maybe a
thrMainThread :: Maybe ThreadId
thrMaxThreads :: Int
thrMinThreads :: Int
thrCurThreads :: Int
thrCallBack :: WorkerJob
thrActiveThreads :: MVar Int
thrMonitor :: MVar ()
thrThreadIds :: Array ThreadId
thrMinThreads :: Int
thrCurThreads :: Int
thrCallBack :: WorkerJob
thrMaxThreads :: Int
thrActiveThreads :: MVar Int
thrMonitor :: MVar ()
thrThreadIds :: Array ThreadId
thrMainThread :: forall a. Maybe a
..}
  ThreadPool -> IO ThreadPool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadPool
pool

monitorThreadPool :: MVar () -> IO ()
monitorThreadPool :: MVar () -> WorkerJob
monitorThreadPool MVar ()
monitor = do
  ()
_active <- MVar () -> WorkerJob
forall a. MVar a -> IO a
takeMVar MVar ()
monitor

  () -> WorkerJob
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

notifyRunning :: Maybe ThreadPool -> IO ()
notifyRunning :: Maybe ThreadPool -> WorkerJob
notifyRunning Maybe ThreadPool
Nothing     = () -> WorkerJob
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notifyRunning (Just ThreadPool
pool) = do
  MVar Int -> (Int -> IO Int) -> WorkerJob
forall a. MVar a -> (a -> IO a) -> WorkerJob
modifyMVar_ (ThreadPool -> MVar Int
thrActiveThreads ThreadPool
pool) (\Int
x -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (ThreadPool -> MVar ()
thrMonitor ThreadPool
pool) ()
  () -> WorkerJob
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

notifyWaiting :: Maybe ThreadPool -> IO ()
notifyWaiting :: Maybe ThreadPool -> WorkerJob
notifyWaiting Maybe ThreadPool
Nothing     = () -> WorkerJob
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notifyWaiting (Just ThreadPool
pool) = do
  MVar Int -> (Int -> IO Int) -> WorkerJob
forall a. MVar a -> (a -> IO a) -> WorkerJob
modifyMVar_ (ThreadPool -> MVar Int
thrActiveThreads ThreadPool
pool) (\Int
x -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar (ThreadPool -> MVar ()
thrMonitor ThreadPool
pool) ()
  () -> WorkerJob
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()