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 , OptimizeLogicalUnitProblem pu v x
46 , ResolveDeadlockProblem pu v x
47 , ProcessorUnit pu v x t
48 , Show (Instruction pu)
49 , Typeable pu
50 , UnambiguouslyDecode pu
51 , TargetSystemComponent pu
52 , Controllable pu
53 , IOTestBench pu v x
54 , Locks pu v
55 , Typeable pu
56 )
57
58 -- | Existential container for a processor unit .
59 data PU v x t where
60 PU ::
61 PUClasses pu v x t =>
62 { unit :: pu
63 , diff :: Changeset v
64 , uEnv :: UnitEnv pu
65 } ->
66 PU v x t
67
68 unitType :: PU v x t -> TypeRep
69 unitType PU{unit} = typeOf unit
70
71 instance Ord v => EndpointProblem (PU v x t) v t where
72 endpointOptions PU{diff, unit} =
73 map (patch diff) $ endpointOptions unit
74
75 endpointDecision PU{unit, diff, uEnv} d =
76 PU
77 { unit = endpointDecision unit $ patch (reverseDiff diff) d
78 , diff
79 , uEnv
80 }
81
82 instance BreakLoopProblem (PU v x t) v x where
83 breakLoopOptions PU{unit} = breakLoopOptions unit
84 breakLoopDecision PU{diff, unit, uEnv} d =
85 PU{unit = breakLoopDecision unit d, diff, uEnv}
86
87 instance OptimizeAccumProblem (PU v x t) v x where
88 optimizeAccumOptions PU{unit} = optimizeAccumOptions unit
89 optimizeAccumDecision PU{diff, unit, uEnv} d =
90 PU{diff, unit = optimizeAccumDecision unit d, uEnv}
91
92 instance OptimizeLogicalUnitProblem (PU v x t) v x where
93 optimizeLogicalUnitOptions PU{unit} = optimizeLogicalUnitOptions unit
94 optimizeLogicalUnitDecision PU{diff, unit, uEnv} d =
95 PU{diff, unit = optimizeLogicalUnitDecision unit d, uEnv}
96 instance ResolveDeadlockProblem (PU v x t) v x where
97 resolveDeadlockOptions PU{unit} = resolveDeadlockOptions unit
98 resolveDeadlockDecision PU{diff, unit, uEnv} d =
99 PU{unit = resolveDeadlockDecision unit d, diff, uEnv}
100
101 instance VarValTime v x t => ProcessorUnit (PU v x t) v x t where
102 tryBind fb PU{diff, unit, uEnv} =
103 case tryBind fb unit of
104 Right unit' -> Right PU{unit = unit', diff, uEnv}
105 Left err -> Left err
106 process PU{unit, diff} =
107 let p = process unit
108 in p{steps = map (patch diff) $ steps p}
109 parallelismType PU{unit} = parallelismType unit
110
111 instance Ord v => Patch (PU v x t) (Changeset v) where
112 patch diff' PU{unit, diff, uEnv} =
113 PU
114 { unit
115 , diff =
116 Changeset
117 { changeI = changeI diff' `M.union` changeI diff
118 , changeO = changeO diff' `M.union` changeO diff
119 }
120 , uEnv
121 }
122
123 instance Ord v => Patch (PU v x t) (I v, I v) where
124 patch (I v, I v') pu@PU{diff = diff@Changeset{changeI}} = pu{diff = diff{changeI = M.insert v v' changeI}}
125
126 instance Ord v => Patch (PU v x t) (O v, O v) where
127 patch (O vs, O vs') pu@PU{diff = diff@Changeset{changeO}} =
128 pu
129 { diff =
130 diff
131 { changeO =
132 foldl
133 (\s (v, v') -> M.insert v (S.singleton v') s)
134 changeO
135 $ [(a, b) | b <- S.elems vs', a <- S.elems vs]
136 }
137 }
138
139 instance Var v => Locks (PU v x t) v where
140 locks PU{unit, diff = diff@Changeset{changeI, changeO}}
141 | not $ M.null changeI = error $ "Locks (PU v x t) with non empty changeI: " <> show diff
142 | otherwise =
143 let (locked', locks') = L.partition (\Lock{locked} -> locked `M.member` changeO) $ locks unit
144 (lockBy', locks'') = L.partition (\Lock{lockBy} -> lockBy `M.member` changeO) locks'
145 in concat
146 [ locks''
147 , L.nub $
148 concatMap
149 (\Lock{locked, lockBy} -> [Lock{locked, lockBy = v} | v <- S.elems (changeO M.! lockBy)])
150 lockBy'
151 , L.nub $
152 concatMap
153 (\Lock{locked, lockBy} -> [Lock{locked = v, lockBy} | v <- S.elems (changeO M.! locked)])
154 locked'
155 ]
156
157 instance TargetSystemComponent (PU v x t) where
158 moduleName name PU{unit} = moduleName name unit
159 hardware name PU{unit} = hardware name unit
160 software name PU{unit} = software name unit
161 hardwareInstance name pu = hardwareInstance name pu
162
163 instance IOTestBench (PU v x t) v x where
164 testEnvironmentInitFlag tag PU{unit} = testEnvironmentInitFlag tag unit
165
166 testEnvironment tag PU{unit, uEnv} _env cntxs = testEnvironment tag unit uEnv cntxs
167
168 data IOSynchronization
169 = -- | IO cycle synchronously to process cycle
170 Sync
171 | -- | if IO cycle lag behiend - ignore them
172 ASync
173 | -- | defined by onboard signal (sync - false, async - true)
174 OnBoard
175 deriving (Show, Read, Typeable, Generic)
176
177 instance ToJSON IOSynchronization
178 instance FromJSON IOSynchronization
179
180 puInputPorts PU{uEnv} = envInputPorts uEnv
181 puOutputPorts PU{uEnv} = envOutputPorts uEnv
182 puInOutPorts PU{uEnv} = envInOutPorts uEnv
183
184 -- | PU and some additional information required for allocation on BusNetwork
185 data PUPrototype tag v x t where
186 PUPrototype ::
187 (UnitTag tag, PUClasses pu v x t) =>
188 { pTag :: tag
189 {- ^ Prototype tag. You can specify tag as a template by adding {x}.
190 This will allow to allocate PU more than once by replacing {x} with index.
191 When PU is allocated processUnitTag will look like bnName_pTag.
192 -}
193 , pProto :: pu
194 -- ^ PU prototype
195 , pIOPorts :: IOPorts pu
196 -- ^ IO ports that will be used by PU
197 } ->
198 PUPrototype tag v x t