module Control.Concurrent.Configuration
(
Component (..),
showComponentTree,
atomic, lift, liftParallelPair, liftSequentialPair, parallelRouterAndBranches, recursiveComponentTree
)
where
import Data.List (minimumBy)
import GHC.Conc (numCapabilities)
data AnyComponent = forall a. AnyComponent (Component a)
data Component c = Component {
name :: String,
subComponents :: [AnyComponent],
maxUsableThreads :: Int,
usingThreads :: Int -> Component c,
usedThreads :: Int,
cost :: Int,
with :: c
}
instance Functor Component where
fmap f c = c{with= f (with c), usingThreads= fmap f . usingThreads c}
showComponentTree :: forall c. Component c -> String
showComponentTree c = showIndentedComponent 1 c
showIndentedComponent :: forall c. Int -> Component c -> String
showIndentedComponent depth c = showRightAligned 4 (cost c) ++ showRightAligned 3 (usedThreads c) ++ replicate depth ' '
++ name c ++ "\n"
++ concatMap (showIndentedAnyComponent (succ depth)) (subComponents c)
showIndentedAnyComponent :: Int -> AnyComponent -> String
showIndentedAnyComponent depth (AnyComponent c) = showIndentedComponent depth c
showRightAligned :: Show x => Int -> x -> String
showRightAligned width x = let str = show x
in replicate (width length str) ' ' ++ str
data ComponentConfiguration = ComponentConfiguration {componentChildren :: [AnyComponent],
componentThreads :: Int,
componentCost :: Int}
toComponent :: String -> Int -> (Int -> (ComponentConfiguration, c)) -> Component c
toComponent nm maxThreads using = usingThreads' 1
where usingThreads' n = let (configuration, c') = using n
in Component nm (componentChildren configuration) maxThreads usingThreads'
(componentThreads configuration) (componentCost configuration) c'
atomic :: String -> Int -> c -> Component c
atomic nm cost1 x = toComponent nm 1 (\_threads-> (ComponentConfiguration [] 1 cost1, x))
optimalTwoAlternatingConfigurations :: Int -> Component c1 -> Component c2
-> (ComponentConfiguration, Component c1, Component c2)
optimalTwoAlternatingConfigurations threads c1 c2 = (cfg{componentCost= componentCost cfg `div` 2}, c1', c2')
where (cfg, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
optimalTwoSequentialConfigurations :: Int -> Component c1 -> Component c2
-> (ComponentConfiguration, Component c1, Component c2)
optimalTwoSequentialConfigurations threads c1 c2 = (configuration, c1', c2')
where configuration = ComponentConfiguration
[AnyComponent c1', AnyComponent c2']
(usedThreads c1' `max` usedThreads c2')
(cost c1' + cost c2')
c1' = c1 `usingThreads` threads
c2' = c2 `usingThreads` threads
optimalTwoParallelConfigurations :: Int -> Component c1 -> Component c2
-> (ComponentConfiguration, Component c1, Component c2, Bool)
optimalTwoParallelConfigurations threads c1 c2 = (configuration, c1', c2', parallelize)
where parallelize = threads > 1 && parallelCost + 1 < sequentialCost
configuration = ComponentConfiguration
[AnyComponent c1', AnyComponent c2']
(if parallelize then usedThreads c1' + usedThreads c2' else usedThreads c1' `max` usedThreads c2')
(if parallelize then parallelCost + 1 else sequentialCost)
(c1', c2') = if parallelize then (c1p, c2p) else (c1s, c2s)
(c1p, c2p, parallelCost) = minimumBy
(\(_, _, cost1) (_, _, cost2)-> compare cost1 cost2)
[let c2threads = threads c1threads `min` maxUsableThreads c2
c1i = usingThreads c1 c1threads
c2i = usingThreads c2 c2threads
in (c1i, c2i, cost c1i `max` cost c2i)
| c1threads <- [1 .. threads 1 `min` maxUsableThreads c1]]
c1s = usingThreads c1 threads
c2s = usingThreads c2 threads
sequentialCost = cost c1s + cost c2s
lift :: Int -> String -> (c1 -> c2) -> Component c1
-> Component c2
lift wrapperCost combinatorName combinator c =
toComponent combinatorName (maxUsableThreads c) $
\threads-> let c' = usingThreads c threads
in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c' + wrapperCost),
combinator (with c'))
liftSequentialPair :: String -> (c1 -> c2 -> c3) -> Component c1 -> Component c2 -> Component c3
liftSequentialPair combinatorName combinator c1 c2 =
toComponent combinatorName (maxUsableThreads c1 `max` maxUsableThreads c2) $
\threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
in (configuration, combinator (with c1') (with c2'))
liftParallelPair :: String -> (Bool -> c1 -> c2 -> c3) -> Component c1 -> Component c2 -> Component c3
liftParallelPair combinatorName combinator c1 c2 =
toComponent combinatorName (maxUsableThreads c1 + maxUsableThreads c2) $
\threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2
in (configuration, combinator parallel (with c1') (with c2'))
parallelRouterAndBranches :: String -> (Bool -> c1 -> c2 -> c3 -> c4) -> Component c1 -> Component c2 -> Component c3
-> Component c4
parallelRouterAndBranches combinatorName combinator router c1 c2 =
toComponent combinatorName (maxUsableThreads router + maxUsableThreads c1 + maxUsableThreads c2) $
\threads-> let (cfg, router', c'', parallel) = optimalTwoParallelConfigurations threads router c'
(c1'', c2'') = with c''
c' = toComponent "branches" (maxUsableThreads c1 `max` maxUsableThreads c2) $
\newThreads-> let (cfg', c1', c2') = optimalTwoAlternatingConfigurations newThreads c1 c2
in (cfg', (c1', c2'))
in (cfg, combinator parallel (with router') (with c1'') (with c2''))
recursiveComponentTree :: forall c1 c2. String -> (Bool -> c1 -> c2 -> c2) -> Component c1 -> Component c2
recursiveComponentTree combinatorName combinator c =
toComponent combinatorName numCapabilities $
\threads-> let optimalRecursion :: Int -> Int -> (ComponentConfiguration, c2)
optimalRecursion oldThreads newThreads
| oldThreads == newThreads = let final = combinator False (with $ usingThreads c newThreads) final
in (ComponentConfiguration [] newThreads (cost c), final)
| otherwise =
let (configuration, c', r', parallel) = optimalTwoParallelConfigurations newThreads c r
r = toComponent combinatorName (newThreads 1) (optimalRecursion newThreads)
in (configuration, combinator parallel (with c') (with r'))
in optimalRecursion 0 threads