Merge pull request #164 from ryukzak/116-dsl-bus-support

Test DSL for target system

src/NITTA/Intermediate/DataFlow.hs

@@ -21,6 +21,7 @@ module NITTA.Intermediate.DataFlow (
     addFuncToDataFlowGraph,
 ) where
 
+import Data.Default
 import qualified Data.List as L
 import qualified Data.Set as S
 import GHC.Generics
@@ -37,6 +38,9 @@ data DataFlowGraph v x
     | DFCluster [DataFlowGraph v x]
     deriving (Show, Generic)
 
+instance Default (DataFlowGraph v x) where
+    def = DFCluster []
+
 instance Eq (DataFlowGraph v x) where
     -- `show` used for avoid `Ord (DataFlowGraph v x)`
     (DFCluster c1) == (DFCluster c2) = S.fromList (map show c1) == S.fromList (map show c2)

src/NITTA/Model/Networks/Bus.hs

@@ -39,6 +39,7 @@ import qualified Data.List as L
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import qualified Data.Set as S
+import Data.String
 import Data.String.Interpolate
 import Data.String.ToString
 import qualified Data.Text as T
@@ -86,6 +87,9 @@ busNetwork name iosync =
         , bnEnv = def
         }
 
+instance (Default t, IsString tag) => Default (BusNetwork tag v x t) where
+    def = busNetwork "defaultBus" ASync
+
 instance (Var v) => Variables (BusNetwork tag v x t) v where
     variables BusNetwork{bnBinded} = unionsMap variables $ concat $ M.elems bnBinded
 
@@ -305,17 +309,25 @@ instance (UnitTag tag, VarValTime v x t) => BreakLoopProblem (BusNetwork tag v x
                 , bnBinded = M.insert puTag bindedToPU' bnBinded
                 }
 
-instance (VarValTime v x t) => OptimizeAccumProblem (BusNetwork tag v x t) v x where
+instance (UnitTag tag, VarValTime v x t) => OptimizeAccumProblem (BusNetwork tag v x t) v x where
     optimizeAccumOptions BusNetwork{bnRemains} = optimizeAccumOptions bnRemains
 
-    optimizeAccumDecision bn@BusNetwork{bnRemains} oa@OptimizeAccum{} =
-        bn{bnRemains = optimizeAccumDecision bnRemains oa}
+    optimizeAccumDecision bn@BusNetwork{bnRemains, bnProcess} oa@OptimizeAccum{} =
+        bn
+            { bnRemains = optimizeAccumDecision bnRemains oa
+            , bnProcess = execScheduleWithProcess bn bnProcess $ do
+                scheduleRefactoring (I.singleton $ nextTick bn) oa
+            }
 
-instance (VarValTime v x t) => ConstantFoldingProblem (BusNetwork tag v x t) v x where
+instance (UnitTag tag, VarValTime v x t) => ConstantFoldingProblem (BusNetwork tag v x t) v x where
     constantFoldingOptions BusNetwork{bnRemains} = constantFoldingOptions bnRemains
 
-    constantFoldingDecision bn@BusNetwork{bnRemains} cf@ConstantFolding{} =
-        bn{bnRemains = constantFoldingDecision bnRemains cf}
+    constantFoldingDecision bn@BusNetwork{bnRemains, bnProcess} cf@ConstantFolding{} =
+        bn
+            { bnRemains = constantFoldingDecision bnRemains cf
+            , bnProcess = execScheduleWithProcess bn bnProcess $ do
+                scheduleRefactoring (I.singleton $ nextTick bn) cf
+            }
 
 instance (UnitTag tag, VarValTime v x t) => ResolveDeadlockProblem (BusNetwork tag v x t) v x where
     resolveDeadlockOptions bn@BusNetwork{bnPus, bnBinded} =
@@ -371,16 +383,20 @@ instance (UnitTag tag, VarValTime v x t) => ResolveDeadlockProblem (BusNetwork t
 
             maybeSended = M.keysSet var2endpointRole
 
-    resolveDeadlockDecision bn@BusNetwork{bnRemains, bnBinded, bnPus} ResolveDeadlock{newBuffer, changeset} =
-        let Just (tag, _) =
-                L.find
-                    (\(_, f) -> not $ null $ S.intersection (outputs newBuffer) $ unionsMap outputs f)
-                    $ M.assocs bnBinded
-         in bn
-                { bnRemains = newBuffer : patch changeset bnRemains
-                , bnPus = M.adjust (patch changeset) tag bnPus
-                , bnBinded = M.map (patch changeset) bnBinded
-                }
+    resolveDeadlockDecision
+        bn@BusNetwork{bnRemains, bnBinded, bnPus, bnProcess}
+        ref@ResolveDeadlock{newBuffer, changeset} =
+            let Just (tag, _) =
+                    L.find
+                        (\(_, f) -> not $ null $ S.intersection (outputs newBuffer) $ unionsMap outputs f)
+                        $ M.assocs bnBinded
+             in bn
+                    { bnRemains = newBuffer : patch changeset bnRemains
+                    , bnPus = M.adjust (patch changeset) tag bnPus
+                    , bnBinded = M.map (patch changeset) bnBinded
+                    , bnProcess = execScheduleWithProcess bn bnProcess $ do
+                        scheduleRefactoring (I.singleton $ nextTick bn) ref
+                    }
 
 --------------------------------------------------------------------------
 

src/NITTA/Model/Problems/Bind.hs

@@ -24,7 +24,7 @@ import NITTA.Intermediate.Types
 
 data Bind tag v x
     = Bind (F v x) tag
-    deriving (Generic)
+    deriving (Generic, Eq)
 
 instance (ToString tag) => Show (Bind tag v x) where
     show (Bind f tag) = "Bind " <> show f <> " " <> toString tag

src/NITTA/Model/Problems/Dataflow.hs

@@ -24,8 +24,10 @@ module NITTA.Model.Problems.Dataflow (
 import Data.Bifunctor
 import Data.String.ToString
 import GHC.Generics
+import NITTA.Intermediate.Variable
 import NITTA.Model.Problems.Endpoint
 import NITTA.Model.Time
+import NITTA.Utils
 import Numeric.Interval.NonEmpty
 
 {- |Dataflow option (@tp ~ TimeConstraint t@) or decision (@tp Z Interval t@)
@@ -47,6 +49,9 @@ instance (ToString tag, Show (EndpointSt v tp)) => Show (DataflowSt tag v tp) wh
         where
             show' (tag, ep) = "(" <> toString tag <> ", " <> show ep <> ")"
 
+instance (Ord v) => Variables (DataflowSt tag v tp) v where
+    variables DataflowSt{dfTargets} = unionsMap (variables . snd) dfTargets
+
 {- |Implemented for any things, which can send data between processor units over
 the network.
 -}

src/NITTA/Model/Problems/Endpoint.hs

@@ -51,9 +51,9 @@ data EndpointSt v tp = EndpointSt
 instance Variables (EndpointSt v t) v where
     variables EndpointSt{epRole} = variables epRole
 
-instance (Var v, Time t) => Show (EndpointSt v (TimeConstraint t)) where
+instance (ToString v, Time t) => Show (EndpointSt v (TimeConstraint t)) where
     show EndpointSt{epRole, epAt} = "?" <> show epRole <> "@(" <> show epAt <> ")"
-instance (Var v, Time t) => Show (EndpointSt v (Interval t)) where
+instance (ToString v, Time t) => Show (EndpointSt v (Interval t)) where
     show EndpointSt{epRole, epAt} = "!" <> show epRole <> "@(" <> show epAt <> ")"
 
 instance (Ord v) => Patch (EndpointSt v tp) (Changeset v) where
@@ -81,7 +81,7 @@ data EndpointRole v
       Target v
     deriving (Eq, Ord, Generic)
 
-instance (Var v) => Show (EndpointRole v) where
+instance (ToString v) => Show (EndpointRole v) where
     show (Source vs) = "Source " <> S.join "," (vsToStringList vs)
     show (Target v) = "Target " <> toString v
 

src/NITTA/Model/ProcessorUnits/Fram.hs

@@ -46,7 +46,7 @@ import NITTA.Model.Time
 import NITTA.Project
 import NITTA.Utils
 import NITTA.Utils.ProcessDescription
-import Numeric.Interval.NonEmpty (inf, sup, (...))
+import Numeric.Interval.NonEmpty (inf, singleton, sup, (...))
 import Prettyprinter
 
 data Fram v x t = Fram
@@ -275,7 +275,9 @@ instance (VarValTime v x t) => BreakLoopProblem (Fram v x t) v x where
                 revoke <- scheduleFunctionRevoke $ recLoop bl
                 f1 <- scheduleFunctionBind $ recLoopOut bl
                 f2 <- scheduleFunctionBind $ recLoopIn bl
-                establishVerticalRelations binds (f1 ++ f2 ++ revoke)
+                ref <- scheduleRefactoring (singleton $ nextTick fram) bl
+                establishVerticalRelations ref (f1 ++ f2 ++ revoke)
+                establishVerticalRelations binds ref
                 return (f1, f2)
             iJob = (defJob $ recLoopOut bl){binds = iPid, startAt = Just 0}
             oJob = (defJob $ recLoopIn bl){binds = oPid}

src/NITTA/Model/ProcessorUnits/Types.hs

@@ -38,6 +38,7 @@ module NITTA.Model.ProcessorUnits.Types (
     whatsHappen,
     extractInstructionAt,
     withShift,
+    isRefactorStep,
 
     -- *Control
     Controllable (..),
@@ -185,7 +186,9 @@ instance (Ord v) => Patch (Step t (StepInfo v x t)) (Changeset v) where
 data StepInfo v x t where
     -- |CAD level step
     CADStep :: String -> StepInfo v x t
-    -- |intermidiate level step (funcution execution)
+    -- |Apply refactoring
+    RefactorStep :: (Typeable ref, Show ref, Eq ref) => ref -> StepInfo v x t
+    -- |intermidiate level step (function execution)
     FStep :: F v x -> StepInfo v x t
     -- |endpoint level step (source or target)
     EndpointRoleStep :: EndpointRole v -> StepInfo v x t
@@ -200,8 +203,12 @@ data StepInfo v x t where
 descent (NestedStep _ step) = descent $ pDesc step
 descent desc = desc
 
+isRefactorStep RefactorStep{} = True
+isRefactorStep _ = False
+
 instance (Var v, Show (Step t (StepInfo v x t))) => Show (StepInfo v x t) where
     show (CADStep msg) = "CAD: " <> msg
+    show (RefactorStep ref) = "Refactor: " <> show ref
     show (FStep F{fun}) = "Intermediate: " <> show fun
     show (EndpointRoleStep eff) = "Endpoint: " <> show eff
     show (InstructionStep instr) = "Instruction: " <> show instr

src/NITTA/Model/TargetSystem.hs

@@ -21,6 +21,7 @@ module NITTA.Model.TargetSystem (
 ) where
 
 import Control.Exception (assert)
+import Data.Default
 import qualified Data.Set as S
 import GHC.Generics
 import NITTA.Intermediate.DataFlow
@@ -40,6 +41,9 @@ data TargetSystem u tag v x t = TargetSystem
     }
     deriving (Generic)
 
+instance (Default u) => Default (TargetSystem u tag v x t) where
+    def = TargetSystem def def
+
 instance (WithFunctions u (F v x)) => WithFunctions (TargetSystem u tag v x t) (F v x) where
     functions TargetSystem{mUnit, mDataFlowGraph} =
         assert (S.fromList (functions mUnit) == S.fromList (functions mDataFlowGraph)) $ -- inconsistent TargetSystem
@@ -51,6 +55,15 @@ isSynthesisComplete :: (ProcessorUnit u v x t) => TargetSystem u tag v x t -> Bo
 isSynthesisComplete TargetSystem{mUnit, mDataFlowGraph} =
     transferred mUnit == variables mDataFlowGraph
 
+instance
+    ( VarValTime v x t
+    , ProcessorUnit u v x t
+    ) =>
+    ProcessorUnit (TargetSystem u tag v x t) v x t
+    where
+    tryBind f ts@TargetSystem{mUnit} = (\u -> ts{mUnit = u}) <$> tryBind f mUnit
+    process TargetSystem{mUnit} = process mUnit
+
 instance (BindProblem u tag v x) => BindProblem (TargetSystem u tag v x t) tag v x where
     bindOptions TargetSystem{mUnit} = bindOptions mUnit
 

src/NITTA/Synthesis.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 {- |
@@ -153,6 +154,10 @@ instance (UnitTag tag, VarValTime v x t) => Default (TargetSynthesis tag v x t)
             , tSimulationCycleN = 5
             }
 
+instance (UnitTag tag, VarValTime v x t) => ProcessorUnit (TargetSynthesis tag v x t) v x t where
+    tryBind _ _ = error "Not Implemented"
+    process TargetSynthesis{tMicroArch} = process tMicroArch
+
 runTargetSynthesis leaf = do
     prj <- synthesizeTargetSystem leaf
     traverse runTestbench prj

src/NITTA/Synthesis/ConstantFolding.hs

@@ -24,6 +24,7 @@ import Data.Aeson (ToJSON)
 import GHC.Generics
 import NITTA.Model.Networks.Bus
 import NITTA.Model.Problems.Refactor
+import NITTA.Model.ProcessorUnits.Types
 import NITTA.Model.TargetSystem
 import NITTA.Model.Time
 import NITTA.Synthesis.Types
@@ -34,7 +35,7 @@ data ConstantFoldingMetrics = ConstantFoldingMetrics
 instance ToJSON ConstantFoldingMetrics
 
 instance
-    (VarValTime v x t) =>
+    (UnitTag tag, VarValTime v x t) =>
     SynthesisDecisionCls
         (SynthesisState (TargetSystem (BusNetwork tag v x t) tag v x t) tag v x t)
         (TargetSystem (BusNetwork tag v x t) tag v x t)

src/NITTA/Synthesis/OptimizeAccum.hs

@@ -24,6 +24,7 @@ import Data.Aeson (ToJSON)
 import GHC.Generics
 import NITTA.Model.Networks.Bus
 import NITTA.Model.Problems.Refactor
+import NITTA.Model.ProcessorUnits.Types
 import NITTA.Model.TargetSystem
 import NITTA.Model.Time
 import NITTA.Synthesis.Types
@@ -34,7 +35,7 @@ data OptimizeAccumMetrics = OptimizeAccumMetrics
 instance ToJSON OptimizeAccumMetrics
 
 instance
-    (VarValTime v x t) =>
+    (UnitTag tag, VarValTime v x t) =>
     SynthesisDecisionCls
         (SynthesisState (TargetSystem (BusNetwork tag v x t) tag v x t) tag v x t)
         (TargetSystem (BusNetwork tag v x t) tag v x t)

src/NITTA/UIBackend/Timeline.hs

@@ -98,6 +98,7 @@ processTimelines Process{steps, relations} =
             }
 
 viewpoint FStep{} = ViewPointID{level = "Fun", component = []}
+viewpoint RefactorStep{} = ViewPointID{level = "Ref", component = []}
 viewpoint CADStep{} = ViewPointID{level = "CAD", component = []}
 viewpoint EndpointRoleStep{} = ViewPointID{level = "EndPoint", component = []}
 viewpoint InstructionStep{} = ViewPointID{level = "INST", component = []}

src/NITTA/Utils/ProcessDescription.hs

@@ -27,6 +27,7 @@ module NITTA.Utils.ProcessDescription (
     scheduleFunctionBind,
     scheduleFunctionRevoke,
     scheduleFunction,
+    scheduleRefactoring,
     scheduleInstructionUnsafe,
     scheduleInstructionUnsafe_,
     scheduleNestedStep,
@@ -60,8 +61,11 @@ from the PU by the 'process' function.
 -}
 execSchedule pu st = snd $ runSchedule pu st
 
-{- |Execute process builder and return new process description. The initial process state is passed
-explicetly.
+{- |Execute process builder and return new process description. The initial
+process state is passed explicetly.
+
+Why can not we get a process here? In the case of Bus Network, it also fetches
+processes from underlying units.
 -}
 execScheduleWithProcess pu p st = snd $ runScheduleWithProcess pu p st
 
@@ -137,6 +141,8 @@ scheduleFunctionRevoke f = do
 -- |Add to the process description information about function evaluation.
 scheduleFunction ti f = scheduleStep ti $ FStep f
 
+scheduleRefactoring ti ref = scheduleStep ti $ RefactorStep ref
+
 {- |Add to the process description information about endpoint behaviour, and it's low-level
 implementation (on instruction level). Vertical relations connect endpoint level and instruction
 level steps.

test/NITTA/LuaFrontend/Tests.hs

@@ -24,15 +24,17 @@ module NITTA.LuaFrontend.Tests (
 ) where
 
 import Control.Monad.State
+import Data.Default
 import Data.FileEmbed (embedStringFile)
 import qualified Data.HashMap.Strict as HM
 import Data.String.Interpolate
-import Data.Text as T
+import qualified Data.Text as T
 import qualified Language.Lua as Lua
-import NITTA.Intermediate.Functions
+import qualified NITTA.Intermediate.Functions as F
 import NITTA.Intermediate.Types
 import NITTA.LuaFrontend
 import NITTA.LuaFrontend.Tests.Providers
+import NITTA.Model.ProcessorUnits.Tests.Providers
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
 import Test.Tasty.TH
@@ -226,7 +228,7 @@ case_lua_negative_operator =
                 sum(0)
             |]
         dfg =
-            [ neg "a^0#0" ["b^0#0"] :: F T.Text Int
+            [ F.neg "a^0#0" ["b^0#0"] :: F T.Text Int
             , loop 0 "b^0#0" ["a^0#0"]
             ]
      in functions (frDataFlow $ lua2functions src) @?= dfg
@@ -572,11 +574,11 @@ test_trace_features =
     ]
 
 test_examples =
-    [ typedLuaTestCase
-        (microarch Sync SlaveSPI)
-        pFX22_32
-        "teacup io wait"
-        $(embedStringFile "examples/teacup.lua")
+    [ unitTestCase "teacup io wait" def $ do
+        setNetwork $ microarch Sync SlaveSPI
+        setBusType pFX22_32
+        assignLua $(embedStringFile "examples/teacup.lua")
+        synthesizeAndCoSim
     , typedLuaTestCase
         (microarch ASync SlaveSPI)
         pFX22_32