never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE FunctionalDependencies #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 {- |
9 Module : NITTA.Model.ProcessorUnits.Types
10 Description : Set of types for process unit description
11 Copyright : (c) Aleksandr Penskoi, 2021
12 License : BSD3
13 Maintainer : aleksandr.penskoi@gmail.com
14 Stability : experimental
15 -}
16 module NITTA.Model.ProcessorUnits.Types (
17 -- * Processor unit
18 UnitTag (..),
19 ProcessorUnit (..),
20 bind,
21 allowToProcess,
22 NextTick (..),
23 ParallelismType (..),
24
25 -- * Process description
26 Process (..),
27 ProcessStepID,
28 Step (..),
29 StepInfo (..),
30 Relation (..),
31 descent,
32 whatsHappen,
33 extractInstructionAt,
34 withShift,
35 isRefactorStep,
36 isAllocationStep,
37
38 -- * Control
39 Controllable (..),
40 SignalTag (..),
41 UnambiguouslyDecode (..),
42 Connected (..),
43 ByTime (..),
44 SignalValue (..),
45 (+++),
46
47 -- * IO
48 IOConnected (..),
49 InputPortTag (..),
50 OutputPortTag (..),
51 InoutPortTag (..),
52 ) where
53
54 import Data.Aeson (ToJSON)
55 import Data.Default
56 import Data.Either
57 import Data.Kind
58 import Data.List qualified as L
59 import Data.List.Utils (replace)
60 import Data.Maybe
61 import Data.Set qualified as S
62 import Data.String
63 import Data.String.Interpolate
64 import Data.String.ToString
65 import Data.Text qualified as T
66 import Data.Typeable
67 import GHC.Generics (Generic)
68 import NITTA.Intermediate.Types
69 import NITTA.Model.Problems.Endpoint
70 import NITTA.Model.Time
71 import Numeric.Interval.NonEmpty
72 import Numeric.Interval.NonEmpty qualified as I
73 import Prettyprinter
74
75 -- | Class for processor unit tag or "name"
76 class (Typeable tag, Ord tag, ToString tag, IsString tag, Semigroup tag) => UnitTag tag where
77 -- | Whether the value can be used as a template or not
78 isTemplate :: tag -> Bool
79
80 -- | Create tag from the template and index
81 fromTemplate :: tag -> String -> tag
82
83 instance UnitTag T.Text where
84 isTemplate tag = T.isInfixOf (T.pack "{x}") tag
85 fromTemplate tag index = T.replace (T.pack "{x}") (T.pack index) tag
86
87 instance UnitTag String where
88 isTemplate tag = "{x}" `L.isInfixOf` tag
89 fromTemplate tag index = replace "{x}" index tag
90
91 -- | Processor unit parallelism type
92 data ParallelismType
93 = -- | All operations can be performed in parallel mode
94 Full
95 | -- | All operations can be performed in pipeline mode
96 Pipeline
97 | -- | Other processor units
98 None
99 deriving (Show, Generic, Eq)
100
101 instance ToJSON ParallelismType
102
103 {- | Process unit - part of NITTA process with can execute a function from
104 intermediate representation:
105
106 1. get function for execution ('tryBind');
107
108 2. store computational process description ('process');
109
110 3. other features implemented by different type classes (see above and in
111 "NITTA.Model.Problems").
112 -}
113 class VarValTime v x t => ProcessorUnit u v x t | u -> v x t where
114 -- If the processor unit can execute a function, then it will return the PU
115 -- model with already bound function (only registeration, actual scheduling
116 -- will be happening later). If not, it will return @Left@ value with a
117 -- specific reason (e.g., not support or all internal resources is over).
118 tryBind :: F v x -> u -> Either String u
119
120 -- Get a computational process description. If the processor unit embedded
121 -- another PUs (like "NITTA.Model.Networks.Bus"), the description should
122 -- contain process steps for all PUs.
123 --
124 -- 'ProcessStepID' may change from one call to another.
125 process :: u -> Process t (StepInfo v x t)
126
127 -- | Indicates what type of parallelism is supported by 'ProcessorUnit'
128 parallelismType :: u -> ParallelismType
129 parallelismType _ = None
130
131 -- | Provide the processor unit size. At the moment it's just the number of subprocessors
132 puSize :: u -> Float
133 puSize _ = 1
134
135 bind f pu = case tryBind f pu of
136 Right pu' -> pu'
137 Left err -> error $ "can't bind function: " <> err
138
139 allowToProcess f pu = isRight $ tryBind f pu
140
141 class NextTick u t | u -> t where
142 nextTick :: u -> t
143
144 instance ProcessorUnit u v x t => NextTick u t where
145 nextTick = nextTick . process
146
147 ---------------------------------------------------------------------
148
149 {- | Computational process description. It was designed in ISO 15926 style, with
150 separated data and relations storage.
151 -}
152 data Process t i = Process
153 { steps :: [Step t i]
154 -- ^ All process steps desctiption.
155 , relations :: [Relation]
156 -- ^ List of relationships between process steps (see 'Relation').
157 , nextTick_ :: t
158 -- ^ Next tick for instruction. Note: instruction /= endpoint.
159 , nextUid :: ProcessStepID
160 -- ^ Next process step ID
161 }
162 deriving (Generic)
163
164 instance (Time t, Show i) => Pretty (Process t i) where
165 pretty p =
166 [__i|
167 Process:
168 steps: #{ showList' $ reverse $ steps p }
169 relations: #{ showList' $ relations p }
170 nextTick: #{ nextTick p }
171 nextUid: #{ nextUid p }
172 |]
173 where
174 showList' [] = pretty ""
175 showList' xs = line <> indent 8 (vsep lst)
176 where
177 lst =
178 map (pretty . (\(ix, value) -> [i|#{ ix }) #{ value }|] :: T.Text)) $
179 zip [0 :: Int ..] xs
180
181 instance (ToJSON t, ToJSON i) => ToJSON (Process t i)
182
183 instance Default t => Default (Process t i) where
184 def = Process{steps = [], relations = [], nextTick_ = def, nextUid = def}
185
186 instance {-# OVERLAPS #-} NextTick (Process t si) t where
187 nextTick = nextTick_
188
189 instance Ord t => WithFunctions (Process t (StepInfo v x t)) (F v x) where
190 functions Process{steps} = mapMaybe get $ L.sortOn (I.inf . pInterval) steps
191 where
192 get Step{pDesc} | IntermediateStep f <- descent pDesc = Just f
193 get _ = Nothing
194
195 -- | Unique ID of a process step. Uniquity presented only inside PU.
196 type ProcessStepID = Int
197
198 -- | Process step representation
199 data Step t i = Step
200 { pID :: ProcessStepID
201 -- ^ uniq (inside single the process unit) step ID
202 , pInterval :: Interval t
203 -- ^ step time
204 , pDesc :: i
205 -- ^ step description
206 }
207 deriving (Show, Generic)
208
209 instance (ToJSON t, ToJSON i) => ToJSON (Step t i)
210
211 instance Ord v => Patch (Step t (StepInfo v x t)) (Changeset v) where
212 patch diff step@Step{pDesc} = step{pDesc = patch diff pDesc}
213
214 -- | Informative process step description at a specific process level.
215 data StepInfo v x t where
216 -- | CAD level step
217 CADStep :: String -> StepInfo v x t
218 -- | Apply refactoring
219 RefactorStep :: (Typeable ref, Show ref, Eq ref) => ref -> StepInfo v x t
220 -- | intermidiate level step (function execution)
221 IntermediateStep :: F v x -> StepInfo v x t
222 -- | endpoint level step (source or target)
223 EndpointRoleStep :: EndpointRole v -> StepInfo v x t
224 -- | process unit instruction (depends on process unit type)
225 InstructionStep ::
226 (Show (Instruction pu), Typeable (Instruction pu)) =>
227 Instruction pu ->
228 StepInfo v x t
229 -- | wrapper for nested process unit step (used for networks)
230 NestedStep :: UnitTag tag => {nTitle :: tag, nStep :: Step t (StepInfo v x t)} -> StepInfo v x t
231 -- | Process unit allocation step
232 AllocationStep :: (Typeable a, Show a, Eq a) => a -> StepInfo v x t
233
234 descent (NestedStep _ step) = descent $ pDesc step
235 descent desc = desc
236
237 isRefactorStep RefactorStep{} = True
238 isRefactorStep _ = False
239
240 isAllocationStep AllocationStep{} = True
241 isAllocationStep _ = False
242
243 instance (Var v, Show (Step t (StepInfo v x t))) => Show (StepInfo v x t) where
244 show (CADStep msg) = "CAD: " <> msg
245 show (AllocationStep alloc) = "Allocation: " <> show alloc
246 show (RefactorStep ref) = "Refactor: " <> show ref
247 show (IntermediateStep F{fun}) = "Intermediate: " <> show fun
248 show (EndpointRoleStep eff) = "Endpoint: " <> show eff
249 show (InstructionStep instr) = "Instruction: " <> show instr
250 show NestedStep{nTitle, nStep = Step{pDesc}} = "@" <> toString nTitle <> " " <> show pDesc
251
252 instance Ord v => Patch (StepInfo v x t) (Changeset v) where
253 patch diff (IntermediateStep f) = IntermediateStep $ patch diff f
254 patch diff (EndpointRoleStep ep) = EndpointRoleStep $ patch diff ep
255 patch diff (NestedStep tag nStep) = NestedStep tag $ patch diff nStep
256 patch _ instr = instr
257
258 -- | Relations between process steps.
259 data Relation
260 = {- | Vertical relationships (up and down). For example, the intermediate
261 step (function execution) can be translated to a sequence of endpoint
262 steps (receiving and sending variable), and process unit instructions.
263 -}
264 Vertical {vUp, vDown :: ProcessStepID}
265 | {- | Horizontal relationships (on one level). For example, we bind the
266 function and apply the refactoring. The binding step should be
267 connected to refactoring steps, including new binding steps.
268 -}
269 Horizontal {hPrev, hNext :: ProcessStepID}
270 deriving (Show, Generic, Ord, Eq)
271
272 instance ToJSON Relation
273
274 whatsHappen t Process{steps} = filter (atSameTime t . pInterval) steps
275 where
276 atSameTime a ti = a `member` ti
277
278 extractInstructionAt pu t = mapMaybe (inst pu) $ whatsHappen t $ process pu
279 where
280 inst :: Typeable (Instruction pu) => pu -> Step t (StepInfo v x t) -> Maybe (Instruction pu)
281 inst _ Step{pDesc = InstructionStep instr} = cast instr
282 inst _ _ = Nothing
283
284 {- | Shift @nextTick@ value if it is not zero on a specific offset. Use case: The
285 processor unit has buffered output, so we should provide @oe@ signal for one
286 tick before data actually send to the bus. That raises the following cases:
287
288 1. First usage. We can receive value immediately on nextTick
289
290 @
291 tick | Endpoint | Instruction |
292 0 | Target "c" | WR | <- nextTick
293 @
294
295 2. Not first usage. We need to wait for one tick from the last instruction due to the offset between instruction and data transfers.
296
297 @
298 tick | Endpoint | Instruction |
299 8 | | OE |
300 9 | Source ["b"] | | <- nextTick
301 10 | Target "c" | WR |
302 @
303 -}
304 0 `withShift` _offset = 0
305 tick `withShift` offset = tick + offset
306
307 ---------------------------------------------------------------------
308
309 {- | Type class for controllable units. Defines two level of a unit behaviour
310 representation (see ahead).
311 -}
312 class Controllable pu where
313 -- Instruction describe unit behaviour on each mUnit cycle. If instruction
314 -- not defined for some cycles - it should be interpreted as NOP.
315 data Instruction pu :: Type
316
317 -- | Microcode desctibe controll signals on each mUnit cycle (without exclusion).
318 data Microcode pu :: Type
319
320 -- | Zip port signal tags and value.
321 zipSignalTagsAndValues :: Ports pu -> Microcode pu -> [(SignalTag, SignalValue)]
322
323 -- | Get list of used control signal tags.
324 usedPortTags :: Ports pu -> [SignalTag]
325
326 -- | Take signal tags from inifinite list of tags.
327 takePortTags :: [SignalTag] -> pu -> Ports pu
328
329 -- | Getting microcode value at a specific time.
330 class ByTime pu t | pu -> t where
331 microcodeAt :: pu -> t -> Microcode pu
332
333 instance
334 ( Show (Instruction pu)
335 , Default (Microcode pu)
336 , ProcessorUnit pu v x t
337 , UnambiguouslyDecode pu
338 , Typeable pu
339 ) =>
340 ByTime pu t
341 where
342 microcodeAt pu t = case extractInstructionAt pu t of
343 [] -> def
344 [instr] -> decodeInstruction instr
345 is -> error [i|instruction collision at #{ t } tick: #{ is } #{ pretty $ process pu }|]
346
347 newtype SignalTag = SignalTag {signalTag :: T.Text} deriving (Eq, Ord)
348
349 instance Show SignalTag where
350 show = toString . signalTag
351
352 -- | Type class of processor units with control ports.
353 class Connected pu where
354 -- | A processor unit control ports (signals, flags).
355 data Ports pu :: Type
356
357 {- | Decoding microcode from a simple instruction (microcode don't change over
358 time).
359
360 TODO: Generalize that class for all process units, including networks.
361 -}
362 class UnambiguouslyDecode pu where
363 decodeInstruction :: Instruction pu -> Microcode pu
364
365 -- | Control line value.
366 data SignalValue
367 = -- | undefined by design (`x`)
368 Undef
369 | -- | boolean (`0` or `1`)
370 Bool Bool
371 | -- | broken value (`x`) by data colision
372 BrokenSignal
373 deriving (Eq)
374
375 instance Default SignalValue where
376 def = Undef
377
378 instance Show SignalValue where
379 show Undef = "x"
380 show (Bool True) = "1"
381 show (Bool False) = "0"
382 show BrokenSignal = "B"
383
384 Undef +++ v = v
385 v +++ Undef = v
386 _ +++ _ = BrokenSignal
387
388 ------------------------------------------------------------
389
390 -- | Type class of processor units with IO ports.
391 class IOConnected pu where
392 data IOPorts pu :: Type
393
394 -- | External input ports, which go outside of NITTA mUnit.
395 inputPorts :: IOPorts pu -> S.Set InputPortTag
396 inputPorts _ = S.empty
397
398 -- | External output ports, which go outside of NITTA mUnit.
399 outputPorts :: IOPorts pu -> S.Set OutputPortTag
400 outputPorts _ = S.empty
401
402 -- | External output ports, which go outside of NITTA mUnit.
403 inoutPorts :: IOPorts pu -> S.Set InoutPortTag
404 inoutPorts _ = S.empty
405
406 newtype InputPortTag = InputPortTag {inputPortTag :: T.Text} deriving (Eq, Ord)
407 instance Show InputPortTag where show = toString . inputPortTag
408
409 newtype OutputPortTag = OutputPortTag {outputPortTag :: T.Text} deriving (Eq, Ord)
410 instance Show OutputPortTag where show = toString . outputPortTag
411
412 newtype InoutPortTag = InoutPortTag {inoutPortTag :: T.Text} deriving (Eq, Ord)
413 instance Show InoutPortTag where show = toString . inoutPortTag