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 Vertical {vUp, vDown :: ProcessStepID}
264 | -- | Horizontal relationships (on one level). For example, we bind the
265 -- function and apply the refactoring. The binding step should be
266 -- connected to refactoring steps, including new binding steps.
267 Horizontal {hPrev, hNext :: ProcessStepID}
268 deriving (Show, Generic, Ord, Eq)
269
270 instance ToJSON Relation
271
272 whatsHappen t Process{steps} = filter (atSameTime t . pInterval) steps
273 where
274 atSameTime a ti = a `member` ti
275
276 extractInstructionAt pu t = mapMaybe (inst pu) $ whatsHappen t $ process pu
277 where
278 inst :: Typeable (Instruction pu) => pu -> Step t (StepInfo v x t) -> Maybe (Instruction pu)
279 inst _ Step{pDesc = InstructionStep instr} = cast instr
280 inst _ _ = Nothing
281
282 {- | Shift @nextTick@ value if it is not zero on a specific offset. Use case: The
283 processor unit has buffered output, so we should provide @oe@ signal for one
284 tick before data actually send to the bus. That raises the following cases:
285
286 1. First usage. We can receive value immediately on nextTick
287
288 @
289 tick | Endpoint | Instruction |
290 0 | Target "c" | WR | <- nextTick
291 @
292
293 2. Not first usage. We need to wait for one tick from the last instruction due to the offset between instruction and data transfers.
294
295 @
296 tick | Endpoint | Instruction |
297 8 | | OE |
298 9 | Source ["b"] | | <- nextTick
299 10 | Target "c" | WR |
300 @
301 -}
302 0 `withShift` _offset = 0
303 tick `withShift` offset = tick + offset
304
305 ---------------------------------------------------------------------
306
307 {- | Type class for controllable units. Defines two level of a unit behaviour
308 representation (see ahead).
309 -}
310 class Controllable pu where
311 -- Instruction describe unit behaviour on each mUnit cycle. If instruction
312 -- not defined for some cycles - it should be interpreted as NOP.
313 data Instruction pu :: Type
314
315 -- | Microcode desctibe controll signals on each mUnit cycle (without exclusion).
316 data Microcode pu :: Type
317
318 -- | Zip port signal tags and value.
319 zipSignalTagsAndValues :: Ports pu -> Microcode pu -> [(SignalTag, SignalValue)]
320
321 -- | Get list of used control signal tags.
322 usedPortTags :: Ports pu -> [SignalTag]
323
324 -- | Take signal tags from inifinite list of tags.
325 takePortTags :: [SignalTag] -> pu -> Ports pu
326
327 -- | Getting microcode value at a specific time.
328 class ByTime pu t | pu -> t where
329 microcodeAt :: pu -> t -> Microcode pu
330
331 instance
332 ( Show (Instruction pu)
333 , Default (Microcode pu)
334 , ProcessorUnit pu v x t
335 , UnambiguouslyDecode pu
336 , Typeable pu
337 ) =>
338 ByTime pu t
339 where
340 microcodeAt pu t = case extractInstructionAt pu t of
341 [] -> def
342 [instr] -> decodeInstruction instr
343 is -> error [i|instruction collision at #{ t } tick: #{ is } #{ pretty $ process pu }|]
344
345 newtype SignalTag = SignalTag {signalTag :: T.Text} deriving (Eq, Ord)
346
347 instance Show SignalTag where
348 show = toString . signalTag
349
350 -- | Type class of processor units with control ports.
351 class Connected pu where
352 -- | A processor unit control ports (signals, flags).
353 data Ports pu :: Type
354
355 {- | Decoding microcode from a simple instruction (microcode don't change over
356 time).
357
358 TODO: Generalize that class for all process units, including networks.
359 -}
360 class UnambiguouslyDecode pu where
361 decodeInstruction :: Instruction pu -> Microcode pu
362
363 -- | Control line value.
364 data SignalValue
365 = -- | undefined by design (`x`)
366 Undef
367 | -- | boolean (`0` or `1`)
368 Bool Bool
369 | -- | broken value (`x`) by data colision
370 BrokenSignal
371 deriving (Eq)
372
373 instance Default SignalValue where
374 def = Undef
375
376 instance Show SignalValue where
377 show Undef = "x"
378 show (Bool True) = "1"
379 show (Bool False) = "0"
380 show BrokenSignal = "B"
381
382 Undef +++ v = v
383 v +++ Undef = v
384 _ +++ _ = BrokenSignal
385
386 ------------------------------------------------------------
387
388 -- | Type class of processor units with IO ports.
389 class IOConnected pu where
390 data IOPorts pu :: Type
391
392 -- | External input ports, which go outside of NITTA mUnit.
393 inputPorts :: IOPorts pu -> S.Set InputPortTag
394 inputPorts _ = S.empty
395
396 -- | External output ports, which go outside of NITTA mUnit.
397 outputPorts :: IOPorts pu -> S.Set OutputPortTag
398 outputPorts _ = S.empty
399
400 -- | External output ports, which go outside of NITTA mUnit.
401 inoutPorts :: IOPorts pu -> S.Set InoutPortTag
402 inoutPorts _ = S.empty
403
404 newtype InputPortTag = InputPortTag {inputPortTag :: T.Text} deriving (Eq, Ord)
405 instance Show InputPortTag where show = toString . inputPortTag
406
407 newtype OutputPortTag = OutputPortTag {outputPortTag :: T.Text} deriving (Eq, Ord)
408 instance Show OutputPortTag where show = toString . outputPortTag
409
410 newtype InoutPortTag = InoutPortTag {inoutPortTag :: T.Text} deriving (Eq, Ord)
411 instance Show InoutPortTag where show = toString . inoutPortTag