Merge pull request #253 from ryukzak/group-binding

Group binding

src/NITTA/Intermediate/Types.hs

@@ -30,6 +30,7 @@ module NITTA.Intermediate.Types (
     FView (..),
     packF,
     castF,
+    functionType,
     Function (..),
     Lock (..),
     Locks (..),
@@ -194,6 +195,9 @@ data F v x where
 
 packF f = F{fun = f, funHistory = []}
 
+functionType :: F v x -> TypeRep
+functionType F{fun} = typeOf fun
+
 instance Eq (F v x) where
     F{fun = a} == F{fun = b}
         | typeOf a == typeOf b = a == fromJust (cast b)

src/NITTA/Model/Networks/Bus.hs

@@ -299,25 +299,116 @@ instance {-# OVERLAPS #-} ByTime (BusNetwork tag v x t) t where
 
 ----------------------------------------------------------------------
 
+cartesianProduct :: [[a]] -> [[a]]
+cartesianProduct [] = [[]]
+cartesianProduct (xs : xss) = [x : ys | x <- xs, ys <- cartesianProduct xss]
+
+{- | Not all bindings can be applied to unit a the same time. E.g.:
+
+ - @b = reg(a)@
+ - @c = reg(b)@
+
+ Can't be binded to same unit because it require self sending of data.
+
+ In this case, we just throw away conflicted bindings.
+-}
+fixGroupBinding :: (UnitTag tag, VarValTime v x t) => BusNetwork tag v x t -> [(tag, F v x)] -> [(tag, F v x)]
+fixGroupBinding _bn [] = []
+fixGroupBinding bn@BusNetwork{bnPus} (b@(uTag, f) : binds)
+    | Right _ <- tryBind f (bnPus M.! uTag) = b : fixGroupBinding (bindDecision bn $ SingleBind uTag f) binds
+    | otherwise = fixGroupBinding bn binds
+
+mergeFunctionWithSameType = True
+
+{- | GroupBindHash required to find equal from task point of view bindings.
+ E.g. (we have 2 units and 3 functions with the same type):
+ @u1 <- f1, f2, f3; u2 <- _ === u1 <- _; u2 <-  f1, f2, f3@ because all
+ task will performing by one unit and it is not matter which one.
+
+ Corner cases:
+
+ - not all group binding are correct (e.g. self sending)
+
+ - we can't wait that unit is empty
+
+ - Combination like: `u1 <- f1, f2; u2 <- f3 !== u1 <- f1, f3; u2 <- f2` are not
+   equal because we don't take into accout their place in DFG.
+-}
+bindsHash :: UnitTag k => BusNetwork k v x t -> [(k, F v x)] -> S.Set (TypeRep, Int, S.Set String)
+bindsHash BusNetwork{bnPus, bnBinded} binds =
+    let distribution = binds2bindGroup binds
+     in S.fromList
+            $ map
+                ( \(tag, fs) ->
+                    let
+                        u = bnPus M.! tag
+                        binded = maybe 0 length $ bnBinded M.!? tag
+                        fs' =
+                            S.fromList $
+                                if mergeFunctionWithSameType
+                                    then -- TODO: merge only functions without
+                                    -- inputs, because they are equal from
+                                    -- scheduling point of view
+
+                                    -- TODO: other way to reduce number of
+                                    -- combinations
+                                        map (show . (\lst -> (head lst, length lst))) (L.group $ map functionType fs)
+                                    else map show fs
+                     in
+                        (unitType u, binded, fs')
+                )
+            $ M.assocs distribution
+
+nubNotObliviousBinds :: UnitTag k => BusNetwork k v x t -> [[(k, F v x)]] -> [[(k, F v x)]]
+nubNotObliviousBinds bn bindss =
+    let hashed = map (\binds -> (bindsHash bn binds, binds)) bindss
+     in M.elems $ M.fromList hashed
+
 instance
     (UnitTag tag, VarValTime v x t) =>
     BindProblem (BusNetwork tag v x t) tag v x
     where
-    bindOptions BusNetwork{bnRemains, bnPus} = concatMap optionsFor bnRemains
+    bindOptions bn@BusNetwork{bnRemains, bnPus} =
+        let binds = map optionsFor bnRemains
+
+            -- oblivious mean we have only one option to bind function
+            obliviousBinds = concat $ filter ((== 1) . length) binds
+            singleAssingmentBinds
+                | null obliviousBinds = []
+                | otherwise = [GroupBind True $ binds2bindGroup obliviousBinds]
+
+            notObliviousBinds :: [[(tag, F v x)]]
+            notObliviousBinds = filter ((> 1) . length) binds
+            -- TODO: split them on independent bindGroups. It should
+            -- significantly reduce complexity.
+            multiBinds :: [Bind tag v x]
+            multiBinds
+                | null notObliviousBinds = []
+                | otherwise =
+                    map (GroupBind False . binds2bindGroup) $
+                        filter ((> 1) . length) $
+                            map (fixGroupBinding bn) $
+                                nubNotObliviousBinds bn $
+                                    cartesianProduct notObliviousBinds
+
+            simpleBinds = concatMap (map $ uncurry SingleBind) binds
+         in singleAssingmentBinds <> multiBinds <> simpleBinds
         where
             optionsFor f =
-                [ Bind f puTitle
-                | (puTitle, pu) <- M.assocs bnPus
+                [ (tag, f)
+                | (tag, pu) <- M.assocs bnPus
                 , allowToProcess f pu
                 ]
 
-    bindDecision bn@BusNetwork{bnProcess, bnPus, bnBinded, bnRemains} (Bind f tag) =
+    bindDecision bn@BusNetwork{bnProcess, bnPus, bnBinded, bnRemains} (SingleBind tag f) =
         bn
             { bnPus = M.adjust (bind f) tag bnPus
             , bnBinded = registerBinding tag f bnBinded
             , bnProcess = execScheduleWithProcess bn bnProcess $ scheduleFunctionBind f
             , bnRemains = filter (/= f) bnRemains
             }
+    bindDecision bn@BusNetwork{} GroupBind{bindGroup} =
+        foldl bindDecision bn $ concatMap (\(tag, fs) -> map (SingleBind tag) fs) $ M.assocs bindGroup
 
 instance (UnitTag tag, VarValTime v x t) => BreakLoopProblem (BusNetwork tag v x t) v x where
     breakLoopOptions BusNetwork{bnPus} = concatMap breakLoopOptions $ M.elems bnPus

src/NITTA/Model/Networks/Types.hs

@@ -12,6 +12,7 @@ Stability   : experimental
 -}
 module NITTA.Model.Networks.Types (
     PU (..),
+    unitType,
     PUClasses,
     IOSynchronization (..),
     PUPrototype (..),
@@ -50,6 +51,7 @@ type PUClasses pu v x t =
     , Controllable pu
     , IOTestBench pu v x
     , Locks pu v
+    , Typeable pu
     )
 
 -- | Existential container for a processor unit .
@@ -62,6 +64,9 @@ data PU v x t where
         } ->
         PU v x t
 
+unitType :: PU v x t -> TypeRep
+unitType PU{unit} = typeOf unit
+
 instance Ord v => EndpointProblem (PU v x t) v t where
     endpointOptions PU{diff, unit} =
         map (patch diff) $ endpointOptions unit

src/NITTA/Model/Problems/Bind.hs

@@ -12,22 +12,60 @@ Stability   : experimental
 module NITTA.Model.Problems.Bind (
     Bind (..),
     BindProblem (..),
+    binds2bindGroup,
 ) where
 
+import Data.Map.Strict qualified as M
 import Data.String.ToString
+import Data.String.Utils qualified as S
 import GHC.Generics
 import NITTA.Intermediate.Types
+import NITTA.Model.ProcessorUnits.Types (UnitTag)
+import NITTA.Utils.Base (unionsMap)
 
 data Bind tag v x
-    = Bind (F v x) tag
+    = SingleBind tag (F v x)
+    | GroupBind {isObliviousBinds :: Bool, bindGroup :: M.Map tag [F v x]}
     deriving (Generic, Eq)
 
-instance ToString tag => Show (Bind tag v x) where
-    show (Bind f tag) = "Bind " <> show f <> " " <> toString tag
+binds2bindGroup :: UnitTag tag => [(tag, F v x)] -> M.Map tag [F v x]
+binds2bindGroup binds =
+    foldl
+        ( \st (tag, f) ->
+            M.alter
+                ( \case
+                    (Just fs) -> Just $ f : fs
+                    Nothing -> Just [f]
+                )
+                tag
+                st
+        )
+        M.empty
+        binds
+
+instance UnitTag tag => Show (Bind tag v x) where
+    show (SingleBind uTag f) = "Bind " <> showFAndTag (f, uTag)
+    show (GroupBind{isObliviousBinds, bindGroup}) =
+        concat
+            [ "Binds "
+            , if isObliviousBinds then "obliviousBinds " else ""
+            , S.join "; " (map showFsAndTag $ M.assocs bindGroup)
+            ]
+
+showFAndTag :: UnitTag tag => (F v x, tag) -> String
+showFAndTag (f, tag) = toString tag <> " <- " <> show f
+
+showFsAndTag :: (ToString a1, Show a2) => (a1, [a2]) -> String
+showFsAndTag (tag, fs) = toString tag <> " <- " <> S.join ", " (map show fs)
 
 class BindProblem u tag v x | u -> tag v x where
     bindOptions :: u -> [Bind tag v x]
     bindDecision :: u -> Bind tag v x -> u
 
 instance Var v => Variables (Bind tab v x) v where
-    variables (Bind f _tag) = variables f
+    variables (SingleBind _tag f) = variables f
+    variables GroupBind{bindGroup} = unionsMap variables $ concat $ M.elems bindGroup
+
+instance WithFunctions (Bind tag v x) (F v x) where
+    functions (SingleBind _tag f) = [f]
+    functions GroupBind{bindGroup} = concat $ M.elems bindGroup

src/NITTA/Model/Problems/ViewHelper.hs

@@ -10,7 +10,9 @@ module NITTA.Model.Problems.ViewHelper (
 ) where
 
 import Data.Aeson
-import Data.Bifunctor
+import Data.Bifunctor (Bifunctor (bimap))
+import Data.HashMap.Strict qualified as HM
+import Data.Map.Strict qualified as M
 import Data.Set qualified as S
 import Data.Text qualified as T
 import GHC.Generics
@@ -31,10 +33,13 @@ instance ToJSON IntervalView
 
 data DecisionView
     = RootView
-    | BindDecisionView
+    | SingleBindView
         { function :: FView
         , pu :: T.Text
         }
+    | GroupBindView
+        { bindGroup :: HM.HashMap T.Text [FView]
+        }
     | AllocationView
         { networkTag :: T.Text
         , processUnitTag :: T.Text
@@ -63,11 +68,12 @@ data DecisionView
     deriving (Generic)
 
 instance UnitTag tag => Viewable (Bind tag v x) DecisionView where
-    view (Bind f pu) =
-        BindDecisionView
+    view (SingleBind uTag f) =
+        SingleBindView
             { function = view f
-            , pu = toText pu
+            , pu = toText uTag
             }
+    view GroupBind{bindGroup} = GroupBindView $ HM.fromList $ map (bimap toText (map view)) $ M.assocs bindGroup
 
 instance UnitTag tag => Viewable (Allocation tag) DecisionView where
     view Allocation{networkTag, processUnitTag} =

src/NITTA/Synthesis/Analysis.hs

@@ -13,63 +13,82 @@ module NITTA.Synthesis.Analysis (
 
 import Control.Concurrent.STM
 import Data.HashMap.Strict qualified as HM
+import Data.Maybe (isJust)
 import GHC.Generics
-import NITTA.Model.TargetSystem (processDuration)
+import NITTA.Model.ProcessorUnits.Types (NextTick)
+import NITTA.Model.TargetSystem (TargetSystem, processDuration)
+import NITTA.Model.Time (VarValTime)
 import NITTA.Synthesis.Types
 
 -- | Metrics of synthesis tree process
 data TreeInfo = TreeInfo
-    { nodes :: !Int
-    , success :: !Int
-    , failed :: !Int
-    , notProcessed :: !Int
-    , durationSuccess :: HM.HashMap Int Int
-    , stepsSuccess :: HM.HashMap Int Int
+    { nodesVisited :: !Int
+    , nodesSuccess :: !Int
+    , nodesFailed :: !Int
+    , nodesNotProcessed :: !Int
+    , targetProcessDuration :: HM.HashMap Int Int
+    , synthesisStepsForSuccess :: HM.HashMap Int Int
     }
     deriving (Generic, Show)
 
 instance Semigroup TreeInfo where
-    (<>) synthesisInfo1 synthesisInfo2 =
-        let synthesisInfoList = [synthesisInfo1, synthesisInfo2]
-            durationSuccessList = map durationSuccess synthesisInfoList
-            stepsSuccessList = map stepsSuccess synthesisInfoList
+    a <> b =
+        let ab = [a, b]
+            durationSuccessList = map targetProcessDuration ab
+            stepsSuccessList = map synthesisStepsForSuccess ab
          in TreeInfo
-                { nodes = sum $ map nodes synthesisInfoList
-                , success = sum $ map success synthesisInfoList
-                , failed = sum $ map failed synthesisInfoList
-                , notProcessed = sum $ map notProcessed synthesisInfoList
-                , durationSuccess = if not $ null durationSuccessList then foldr1 (HM.unionWith (+)) durationSuccessList else HM.empty
-                , stepsSuccess = if not $ null stepsSuccessList then foldr1 (HM.unionWith (+)) stepsSuccessList else HM.empty
+                { nodesVisited = sum $ map nodesVisited ab
+                , nodesSuccess = sum $ map nodesSuccess ab
+                , nodesFailed = sum $ map nodesFailed ab
+                , nodesNotProcessed = sum $ map nodesNotProcessed ab
+                , targetProcessDuration = if not $ null durationSuccessList then foldr1 (HM.unionWith (+)) durationSuccessList else HM.empty
+                , synthesisStepsForSuccess = if not $ null stepsSuccessList then foldr1 (HM.unionWith (+)) stepsSuccessList else HM.empty
                 }
 
 instance Monoid TreeInfo where
     mempty =
         TreeInfo
-            { nodes = 0
-            , success = 0
-            , failed = 0
-            , notProcessed = 0
-            , durationSuccess = HM.empty
-            , stepsSuccess = HM.empty
+            { nodesVisited = 0
+            , nodesSuccess = 0
+            , nodesFailed = 0
+            , nodesNotProcessed = 0
+            , targetProcessDuration = HM.empty
+            , synthesisStepsForSuccess = HM.empty
             }
 
+getTreeInfo ::
+    (VarValTime v x t, NextTick u t) =>
+    Tree (TargetSystem u tag v x t) tag v x t ->
+    IO TreeInfo
 getTreeInfo tree@Tree{sID = Sid sid, sSubForestVar} = do
     subForestM <- atomically $ tryReadTMVar sSubForestVar
-    subForestInfo <- maybe (return mempty) (fmap mconcat . mapM getTreeInfo) subForestM
+    let isProcessed = isJust subForestM
+    TreeInfo
+        { nodesVisited
+        , nodesSuccess
+        , nodesFailed
+        , targetProcessDuration
+        , synthesisStepsForSuccess
+        , nodesNotProcessed
+        } <-
+        maybe (return mempty) (fmap mconcat . mapM getTreeInfo) subForestM
+
     let (isSuccess, isFail)
             | isLeaf tree = if isComplete tree then (True, False) else (False, True)
             | otherwise = (False, False)
+
     let duration = fromEnum $ processDuration $ sTarget $ sState tree
-    let successDepends value field =
-            if not isSuccess
-                then field subForestInfo
-                else HM.alter (Just . maybe 1 (+ 1)) value $ field subForestInfo
+
+    let registerIfSuccess stat value
+            | not isSuccess = stat
+            | otherwise = HM.alter (Just . maybe 1 (+ 1)) value stat
+
     return $
         TreeInfo
-            { nodes = 1 + nodes subForestInfo
-            , success = if isSuccess then 1 else 0 + success subForestInfo
-            , failed = if isFail then 1 else 0 + failed subForestInfo
-            , notProcessed = maybe 1 (const 0) subForestM + notProcessed subForestInfo
-            , durationSuccess = successDepends duration durationSuccess
-            , stepsSuccess = successDepends (length sid) stepsSuccess
+            { nodesVisited = nodesVisited + 1
+            , nodesSuccess = nodesSuccess + if isSuccess then 1 else 0
+            , nodesFailed = nodesFailed + if isFail then 1 else 0
+            , nodesNotProcessed = nodesNotProcessed + if isProcessed then 0 else 1
+            , targetProcessDuration = registerIfSuccess targetProcessDuration duration
+            , synthesisStepsForSuccess = registerIfSuccess synthesisStepsForSuccess $ length sid
             }