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