never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 {- |
6 Module : NITTA.Model.Networks.Types
7 Description : Types for processor unit network description.
8 Copyright : (c) Aleksandr Penskoi, 2021
9 License : BSD3
10 Maintainer : aleksandr.penskoi@gmail.com
11 Stability : experimental
12 -}
13 module NITTA.Model.Networks.Types (
14 PU (..),
15 unitType,
16 PUClasses,
17 IOSynchronization (..),
18 PUPrototype (..),
19 puInputPorts,
20 puOutputPorts,
21 puInOutPorts,
22 ) where
23
24 import Data.Aeson
25 import Data.List qualified as L
26 import Data.Map.Strict qualified as M
27 import Data.Set qualified as S
28 import Data.Typeable
29 import GHC.Generics (Generic)
30 import NITTA.Intermediate.Types
31 import NITTA.Model.Problems
32 import NITTA.Model.ProcessorUnits.Types
33 import NITTA.Model.Time
34 import NITTA.Project.TestBench
35 import NITTA.Project.Types
36
37 type PUClasses pu v x t =
38 ( ByTime pu t
39 , Connected pu
40 , IOConnected pu
41 , EndpointProblem pu v t
42 , BreakLoopProblem pu v x
43 , ConstantFoldingProblem pu v x
44 , OptimizeAccumProblem pu v x
45 , ResolveDeadlockProblem pu v x
46 , ProcessorUnit pu v x t
47 , Show (Instruction pu)
48 , Typeable pu
49 , UnambiguouslyDecode pu
50 , TargetSystemComponent pu
51 , Controllable pu
52 , IOTestBench pu v x
53 , Locks pu v
54 , Typeable pu
55 )
56
57 -- | Existential container for a processor unit .
58 data PU v x t where
59 PU ::
60 PUClasses pu v x t =>
61 { unit :: pu
62 , diff :: Changeset v
63 , uEnv :: UnitEnv pu
64 } ->
65 PU v x t
66
67 unitType :: PU v x t -> TypeRep
68 unitType PU{unit} = typeOf unit
69
70 instance Ord v => EndpointProblem (PU v x t) v t where
71 endpointOptions PU{diff, unit} =
72 map (patch diff) $ endpointOptions unit
73
74 endpointDecision PU{unit, diff, uEnv} d =
75 PU
76 { unit = endpointDecision unit $ patch (reverseDiff diff) d
77 , diff
78 , uEnv
79 }
80
81 instance BreakLoopProblem (PU v x t) v x where
82 breakLoopOptions PU{unit} = breakLoopOptions unit
83 breakLoopDecision PU{diff, unit, uEnv} d =
84 PU{unit = breakLoopDecision unit d, diff, uEnv}
85
86 instance OptimizeAccumProblem (PU v x t) v x where
87 optimizeAccumOptions PU{unit} = optimizeAccumOptions unit
88 optimizeAccumDecision PU{diff, unit, uEnv} d =
89 PU{diff, unit = optimizeAccumDecision unit d, uEnv}
90
91 instance ResolveDeadlockProblem (PU v x t) v x where
92 resolveDeadlockOptions PU{unit} = resolveDeadlockOptions unit
93 resolveDeadlockDecision PU{diff, unit, uEnv} d =
94 PU{unit = resolveDeadlockDecision unit d, diff, uEnv}
95
96 instance VarValTime v x t => ProcessorUnit (PU v x t) v x t where
97 tryBind fb PU{diff, unit, uEnv} =
98 case tryBind fb unit of
99 Right unit' -> Right PU{unit = unit', diff, uEnv}
100 Left err -> Left err
101 process PU{unit, diff} =
102 let p = process unit
103 in p{steps = map (patch diff) $ steps p}
104 parallelismType PU{unit} = parallelismType unit
105
106 instance Ord v => Patch (PU v x t) (Changeset v) where
107 patch diff' PU{unit, diff, uEnv} =
108 PU
109 { unit
110 , diff =
111 Changeset
112 { changeI = changeI diff' `M.union` changeI diff
113 , changeO = changeO diff' `M.union` changeO diff
114 }
115 , uEnv
116 }
117
118 instance Ord v => Patch (PU v x t) (I v, I v) where
119 patch (I v, I v') pu@PU{diff = diff@Changeset{changeI}} = pu{diff = diff{changeI = M.insert v v' changeI}}
120
121 instance Ord v => Patch (PU v x t) (O v, O v) where
122 patch (O vs, O vs') pu@PU{diff = diff@Changeset{changeO}} =
123 pu
124 { diff =
125 diff
126 { changeO =
127 foldl
128 (\s (v, v') -> M.insert v (S.singleton v') s)
129 changeO
130 $ [(a, b) | b <- S.elems vs', a <- S.elems vs]
131 }
132 }
133
134 instance Var v => Locks (PU v x t) v where
135 locks PU{unit, diff = diff@Changeset{changeI, changeO}}
136 | not $ M.null changeI = error $ "Locks (PU v x t) with non empty changeI: " <> show diff
137 | otherwise =
138 let (locked', locks') = L.partition (\Lock{locked} -> locked `M.member` changeO) $ locks unit
139 (lockBy', locks'') = L.partition (\Lock{lockBy} -> lockBy `M.member` changeO) locks'
140 in concat
141 [ locks''
142 , L.nub $
143 concatMap
144 (\Lock{locked, lockBy} -> [Lock{locked, lockBy = v} | v <- S.elems (changeO M.! lockBy)])
145 lockBy'
146 , L.nub $
147 concatMap
148 (\Lock{locked, lockBy} -> [Lock{locked = v, lockBy} | v <- S.elems (changeO M.! locked)])
149 locked'
150 ]
151
152 instance TargetSystemComponent (PU v x t) where
153 moduleName name PU{unit} = moduleName name unit
154 hardware name PU{unit} = hardware name unit
155 software name PU{unit} = software name unit
156 hardwareInstance name pu = hardwareInstance name pu
157
158 instance IOTestBench (PU v x t) v x where
159 testEnvironmentInitFlag tag PU{unit} = testEnvironmentInitFlag tag unit
160
161 testEnvironment tag PU{unit, uEnv} _env cntxs = testEnvironment tag unit uEnv cntxs
162
163 data IOSynchronization
164 = -- | IO cycle synchronously to process cycle
165 Sync
166 | -- | if IO cycle lag behiend - ignore them
167 ASync
168 | -- | defined by onboard signal (sync - false, async - true)
169 OnBoard
170 deriving (Show, Read, Typeable, Generic)
171
172 instance ToJSON IOSynchronization
173 instance FromJSON IOSynchronization
174
175 puInputPorts PU{uEnv} = envInputPorts uEnv
176 puOutputPorts PU{uEnv} = envOutputPorts uEnv
177 puInOutPorts PU{uEnv} = envInOutPorts uEnv
178
179 -- | PU and some additional information required for allocation on BusNetwork
180 data PUPrototype tag v x t where
181 PUPrototype ::
182 (UnitTag tag, PUClasses pu v x t) =>
183 { pTag :: tag
184 -- ^ Prototype tag. You can specify tag as a template by adding {x}.
185 -- This will allow to allocate PU more than once by replacing {x} with index.
186 -- When PU is allocated processUnitTag will look like bnName_pTag.
187 , pProto :: pu
188 -- ^ PU prototype
189 , pIOPorts :: IOPorts pu
190 -- ^ IO ports that will be used by PU
191 } ->
192 PUPrototype tag v x t