never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE MultiWayIf #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TypeFamilies #-}
8
9 {- |
10 Module : NITTA.Model.Networks.Bus
11 Description : Simple process unit network - pseudo bus.
12 Copyright : (c) Aleksandr Penskoi, 2019
13 License : BSD3
14 Maintainer : aleksandr.penskoi@gmail.com
15 Stability : experimental
16 -}
17 module NITTA.Model.Networks.Bus (
18 BusNetwork (..),
19 Instruction (..),
20 Ports (..),
21 IOPorts (..),
22 boundFunctions,
23 controlSignalLiteral,
24 busNetwork,
25
26 -- * Builder
27 modifyNetwork,
28 defineNetwork,
29 addCustom,
30 add,
31 addPrototype,
32 addCustomPrototype,
33 )
34 where
35
36 import Control.Monad (when)
37 import Control.Monad.State
38 import Data.Bifunctor
39 import Data.Default
40 import Data.List qualified as L
41 import Data.Map.Strict qualified as M
42 import Data.Maybe
43 import Data.Set qualified as S
44 import Data.String
45 import Data.String.Interpolate
46 import Data.String.ToString
47 import Data.Text qualified as T
48 import Data.Typeable
49 import NITTA.Intermediate.Types
50 import NITTA.Model.Networks.Types
51 import NITTA.Model.Problems
52 import NITTA.Model.ProcessorUnits.IO.SPI (SPI)
53 import NITTA.Model.ProcessorUnits.Types
54 import NITTA.Model.Time
55 import NITTA.Project.TestBench
56 import NITTA.Project.Types
57 import NITTA.Project.VerilogSnippets
58 import NITTA.Utils
59 import NITTA.Utils.ProcessDescription
60 import Numeric.Interval.NonEmpty (inf, sup, (...))
61 import Numeric.Interval.NonEmpty qualified as I
62 import Prettyprinter
63 import Text.Regex
64
65 data BusNetwork tag v x t = BusNetwork
66 { bnName :: tag
67 , bnRemains :: [F v x]
68 -- ^ List of functions bound to network, but not bound to any process unit.
69 , bnBound :: M.Map tag [F v x]
70 -- ^ Map process unit name to list of bound functions.
71 , bnProcess :: Process t (StepInfo v x t)
72 -- ^ Network process (bindings and transport instructions)
73 , bnPus :: M.Map tag (PU v x t)
74 -- ^ Map of process units.
75 , bnSignalBusWidth :: Int
76 -- ^ Controll bus width.
77 , ioSync :: IOSynchronization
78 , bnEnv :: UnitEnv (BusNetwork tag v x t)
79 , bnPUPrototypes :: M.Map tag (PUPrototype tag v x t)
80 -- ^ Set of the PUs that could be added to the network during synthesis process
81 }
82
83 busNetwork name iosync =
84 BusNetwork
85 { bnName = name
86 , bnRemains = []
87 , bnBound = M.empty
88 , bnProcess = def
89 , bnPus = def
90 , bnSignalBusWidth = 0
91 , ioSync = iosync
92 , bnEnv = def
93 , bnPUPrototypes = def
94 }
95
96 instance (Default t, IsString tag) => Default (BusNetwork tag v x t) where
97 def = busNetwork "defaultBus" ASync
98
99 instance Var v => Variables (BusNetwork tag v x t) v where
100 variables BusNetwork{bnBound} = unionsMap variables $ concat $ M.elems bnBound
101
102 boundFunctions puTitle BusNetwork{bnBound}
103 | puTitle `M.member` bnBound = bnBound M.! puTitle
104 | otherwise = []
105
106 instance Default x => DefaultX (BusNetwork tag v x t) x
107
108 instance WithFunctions (BusNetwork tag v x t) (F v x) where
109 functions BusNetwork{bnRemains, bnBound} = bnRemains ++ concat (M.elems bnBound)
110
111 instance (UnitTag tag, VarValTime v x t) => DataflowProblem (BusNetwork tag v x t) tag v t where
112 dataflowOptions BusNetwork{bnPus, bnProcess} =
113 let sources =
114 concatMap
115 (\(tag, pu) -> map (\ep -> (tag, ep)) $ filter isSource $ endpointOptions pu)
116 $ M.assocs bnPus
117 targets =
118 M.fromList
119 $ concatMap
120 ( \(tag, pu) ->
121 concatMap (\ep -> map (,(tag, ep)) $ S.elems $ variables ep) $
122 filter isTarget $
123 endpointOptions pu
124 )
125 $ M.assocs bnPus
126 in filter (not . null . dfTargets) $
127 concatMap
128 ( \(src, sEndpoint) ->
129 let dfSource = (src, netConstrain sEndpoint)
130 -- collsion example (can not be sended at the same time):
131 -- fram1
132 -- x1 -> accum
133 -- x2 -> accum
134 (hold, sendWithColisions) =
135 L.partition (\v -> isNothing $ targets M.!? v) $
136 S.elems $
137 variables sEndpoint
138 sends =
139 sequence $
140 M.elems $
141 foldr
142 (\v -> M.alter (Just . maybe [v] (v :)) (fst $ targets M.! v))
143 def
144 sendWithColisions
145 in map
146 ( \send ->
147 DataflowSt
148 { dfSource
149 , dfTargets =
150 mapMaybe
151 (\v -> fmap (second netConstrain) (targets M.!? v))
152 $ send ++ hold
153 }
154 )
155 sends
156 )
157 sources
158 where
159 netConstrain =
160 updAt $ \at@TimeConstraint{tcAvailable} ->
161 let a = max (nextTick bnProcess) $ inf tcAvailable
162 b = sup tcAvailable
163 in at{tcAvailable = a ... b}
164
165 dataflowDecision bn@BusNetwork{bnProcess, bnPus} DataflowSt{dfSource = (srcTitle, src), dfTargets}
166 | nextTick bnProcess > inf (epAt src) =
167 error $ "BusNetwork wraping time! Time: " ++ show (nextTick bnProcess) ++ " Act start at: " ++ show src
168 | otherwise =
169 let srcStart = inf $ epAt src
170 srcDuration = maximum $ map ((\EndpointSt{epAt} -> (inf epAt - srcStart) + I.width epAt) . snd) dfTargets
171 srcEnd = srcStart + srcDuration
172
173 subDecisions =
174 (srcTitle, EndpointSt (Source $ unionsMap (variables . snd) dfTargets) (epAt src)) : dfTargets
175 in bn
176 { bnPus = foldl applyDecision bnPus subDecisions
177 , bnProcess = execScheduleWithProcess bn bnProcess $ do
178 mapM_
179 ( \(targetTitle, ep) ->
180 scheduleInstructionUnsafe
181 (srcStart ... srcEnd)
182 (Transport (oneOf $ variables ep) srcTitle targetTitle :: Instruction (BusNetwork tag v x t))
183 )
184 dfTargets
185 }
186 where
187 applyDecision pus (trgTitle, d') = M.adjust (`endpointDecision` d') trgTitle pus
188
189 instance (UnitTag tag, VarValTime v x t) => ProcessorUnit (BusNetwork tag v x t) v x t where
190 tryBind f net@BusNetwork{bnRemains, bnPus, bnPUPrototypes}
191 | any (allowToProcess f) (M.elems bnPus) = Right net{bnRemains = f : bnRemains}
192 -- TODO:
193 -- There are several issues that need to be addressed: see https://github.com/ryukzak/nitta/pull/195#discussion_r853486450
194 -- 1) Now the binding of functions to the network is hardcoded, that prevents use of an empty uarch at the start
195 -- 2) If Allocation options are independent of the bnRemains, then they are present in all synthesis states, which means no leaves in the synthesis tree
196 | any (\PUPrototype{pProto} -> allowToProcess f pProto) (M.elems bnPUPrototypes) = Right net{bnRemains = f : bnRemains}
197 tryBind f BusNetwork{bnPus} =
198 Left [i|All sub process units reject the functional block: #{ f }; rejects: #{ rejects }|]
199 where
200 rejects = T.intercalate "; " $ map showReject $ M.assocs bnPus
201 showReject (tag, pu) | Left err <- tryBind f pu = [i|[#{ toString tag }]: #{ err }"|]
202 showReject (tag, _) = [i|[#{ toString tag }]: undefined"|]
203
204 process net@BusNetwork{bnProcess, bnPus} =
205 let v2transportStepKey =
206 M.fromList
207 [ (v, pID)
208 | step@Step{pID, pDesc} <- steps bnProcess
209 , isInstruction step
210 , v <- case pDesc of
211 (InstructionStep ins) | Just (Transport var _ _) <- castInstruction net ins -> [var]
212 _ -> []
213 ]
214 wholeProcess = execScheduleWithProcess net bnProcess $ do
215 mapM_ (uncurry includeNestedProcess) $ L.sortOn fst $ M.assocs bnPus
216 Process{steps} <- getProcessSlice
217
218 -- Vertical relations between Transport and Endpoint
219 let enpointStepKeyVars =
220 concatMap
221 ( \Step{pID, pDesc} ->
222 case pDesc of
223 NestedStep{nStep = Step{pDesc = EndpointRoleStep role}} ->
224 map (pID,) $ S.elems $ variables role
225 _ -> []
226 )
227 steps
228 mapM_
229 ( \(epKey, v) ->
230 when (v `M.member` v2transportStepKey) $
231 establishVerticalRelations [v2transportStepKey M.! v] [epKey]
232 )
233 enpointStepKeyVars
234
235 -- Vertical relations between FB and Transport
236 mapM_
237 ( \case
238 Step{pID, pDesc = NestedStep{nStep = Step{pDesc = IntermediateStep f}}} ->
239 mapM_
240 ( \v ->
241 when (v `M.member` v2transportStepKey) $
242 establishVerticalRelations [pID] [v2transportStepKey M.! v]
243 )
244 $ variables f
245 _ -> error "Bus: process: insternal error"
246 )
247 $ filter isIntermediate steps
248 in wholeProcess
249 where
250 includeNestedProcess tag pu = do
251 let Process{steps, relations} = process pu
252 pu2netKey <-
253 M.fromList
254 <$> mapM
255 ( \step@Step{pID} -> do
256 pID' <- scheduleNestedStep tag step
257 return (pID, pID')
258 )
259 steps
260 mapM_
261 ( \case
262 (Vertical h l) -> establishVerticalRelations [pu2netKey M.! h] [pu2netKey M.! l]
263 (Horizontal h l) -> establishHorizontalRelations [pu2netKey M.! h] [pu2netKey M.! l]
264 )
265 relations
266
267 parallelismType _ = error " not support parallelismType for BusNetwork"
268
269 puSize BusNetwork{bnPus} = sum $ map puSize $ M.elems bnPus
270
271 instance Controllable (BusNetwork tag v x t) where
272 data Instruction (BusNetwork tag v x t)
273 = Transport v tag tag
274 deriving (Typeable)
275
276 data Microcode (BusNetwork tag v x t)
277 = BusNetworkMC (M.Map SignalTag SignalValue)
278
279 -- Right now, BusNetwork don't have external control (exclude rst signal and some hacks). All
280 -- signals starts and ends inside network unit.
281 zipSignalTagsAndValues BusNetworkPorts BusNetworkMC{} = []
282
283 usedPortTags _ = error "internal error"
284
285 takePortTags _ _ = error "internal error"
286
287 instance (ToString tag, Var v) => Show (Instruction (BusNetwork tag v x t)) where
288 show (Transport v src trg) = "Transport " <> toString v <> " " <> toString src <> " " <> toString trg
289
290 instance {-# OVERLAPS #-} ByTime (BusNetwork tag v x t) t where
291 microcodeAt BusNetwork{..} t =
292 BusNetworkMC $ foldl merge initSt $ M.elems bnPus
293 where
294 initSt = M.fromList $ map (\ins -> (SignalTag $ controlSignalLiteral ins, def)) [0 .. bnSignalBusWidth - 1]
295
296 merge st PU{unit, uEnv = UnitEnv{ctrlPorts = Just ports}} =
297 foldl merge' st $ zipSignalTagsAndValues ports $ microcodeAt unit t
298 merge _ _ = error "internal error"
299
300 merge' st (signalTag, value) = M.adjust (+++ value) signalTag st
301
302 ----------------------------------------------------------------------
303
304 cartesianProduct :: [[a]] -> [[a]]
305 cartesianProduct [] = [[]]
306 cartesianProduct (xs : xss) = [x : ys | x <- xs, ys <- cartesianProduct xss]
307
308 {- | Not all bindings can be applied to unit a the same time. E.g.:
309
310 - @b = reg(a)@
311 - @c = reg(b)@
312
313 Can't be bound to same unit because it require self sending of data.
314
315 In this case, we just throw away conflicted bindings.
316 -}
317 fixGroupBinding :: (UnitTag tag, VarValTime v x t) => BusNetwork tag v x t -> [(tag, F v x)] -> [(tag, F v x)]
318 fixGroupBinding _bn [] = []
319 fixGroupBinding bn@BusNetwork{bnPus} (b@(uTag, f) : binds)
320 | Right _ <- tryBind f (bnPus M.! uTag) = b : fixGroupBinding (bindDecision bn $ SingleBind uTag f) binds
321 | otherwise = fixGroupBinding bn binds
322
323 mergeFunctionWithSameType = True
324
325 {- | GroupBindHash required to find equal from task point of view bindings.
326 E.g. (we have 2 units and 3 functions with the same type):
327 @u1 <- f1, f2, f3; u2 <- _ === u1 <- _; u2 <- f1, f2, f3@ because all
328 task will performing by one unit and it is not matter which one.
329
330 Corner cases:
331
332 - not all group binding are correct (e.g. self sending)
333
334 - we can't wait that unit is empty
335
336 - Combination like: `u1 <- f1, f2; u2 <- f3 !== u1 <- f1, f3; u2 <- f2` are not
337 equal because we don't take into accout their place in DFG.
338 -}
339 bindsHash :: UnitTag k => BusNetwork k v x t -> [(k, F v x)] -> S.Set (TypeRep, Int, S.Set String)
340 bindsHash BusNetwork{bnPus, bnBound} binds =
341 let distribution = binds2bindGroup binds
342 in S.fromList
343 $ map
344 ( \(tag, fs) ->
345 let u = bnPus M.! tag
346 bound = maybe 0 length $ bnBound M.!? tag
347 fs' =
348 S.fromList $
349 if mergeFunctionWithSameType
350 then -- TODO: merge only functions without
351 -- inputs, because they are equal from
352 -- scheduling point of view
353
354 -- TODO: other way to reduce number of
355 -- combinations
356 map (show . (\lst -> (head lst, length lst))) (L.group $ map functionType fs)
357 else map show fs
358 in (unitType u, bound, fs')
359 )
360 $ M.assocs distribution
361
362 nubNotObviousBinds :: UnitTag k => BusNetwork k v x t -> [[(k, F v x)]] -> [[(k, F v x)]]
363 nubNotObviousBinds bn bindss =
364 let hashed = map (\binds -> (bindsHash bn binds, binds)) bindss
365 in M.elems $ M.fromList hashed
366
367 instance
368 (UnitTag tag, VarValTime v x t) =>
369 BindProblem (BusNetwork tag v x t) tag v x
370 where
371 bindOptions bn@BusNetwork{bnRemains, bnPus} =
372 let binds = map optionsFor bnRemains
373
374 -- obvious mean we have only one option to bind function
375 obviousBinds = concat $ filter ((== 1) . length) binds
376 singleAssingmentBinds
377 | null obviousBinds = []
378 | otherwise = [GroupBind True $ binds2bindGroup obviousBinds]
379
380 notObviousBinds :: [[(tag, F v x)]]
381 notObviousBinds = filter ((> 1) . length) binds
382 -- TODO: split them on independent bindGroups. It should
383 -- significantly reduce complexity.
384 multiBinds :: [Bind tag v x]
385 multiBinds
386 | null notObviousBinds = []
387 | otherwise =
388 map (GroupBind False . binds2bindGroup) $
389 filter ((> 1) . length) $
390 map (fixGroupBinding bn) $
391 nubNotObviousBinds bn $
392 cartesianProduct notObviousBinds
393
394 simpleBinds = concatMap (map $ uncurry SingleBind) binds
395 in singleAssingmentBinds <> multiBinds <> simpleBinds
396 where
397 optionsFor f =
398 [ (tag, f)
399 | (tag, pu) <- M.assocs bnPus
400 , allowToProcess f pu
401 ]
402
403 bindDecision bn@BusNetwork{bnProcess, bnPus, bnBound, bnRemains} (SingleBind tag f) =
404 bn
405 { bnPus = M.adjust (bind f) tag bnPus
406 , bnBound = registerBinding tag f bnBound
407 , bnProcess = execScheduleWithProcess bn bnProcess $ scheduleFunctionBind f
408 , bnRemains = filter (/= f) bnRemains
409 }
410 bindDecision bn@BusNetwork{} GroupBind{bindGroup} =
411 foldl bindDecision bn $ concatMap (\(tag, fs) -> map (SingleBind tag) fs) $ M.assocs bindGroup
412
413 instance (UnitTag tag, VarValTime v x t) => BreakLoopProblem (BusNetwork tag v x t) v x where
414 breakLoopOptions BusNetwork{bnPus} = concatMap breakLoopOptions $ M.elems bnPus
415
416 breakLoopDecision bn@BusNetwork{bnBound, bnPus} bl@BreakLoop{} =
417 let (puTag, boundToPU) = fromJust $ L.find (elem (recLoop bl) . snd) $ M.assocs bnBound
418 boundToPU' = recLoopIn bl : recLoopOut bl : (boundToPU L.\\ [recLoop bl])
419 in bn
420 { bnPus = M.adjust (`breakLoopDecision` bl) puTag bnPus
421 , bnBound = M.insert puTag boundToPU' bnBound
422 }
423
424 instance (UnitTag tag, VarValTime v x t) => OptimizeAccumProblem (BusNetwork tag v x t) v x where
425 optimizeAccumOptions BusNetwork{bnRemains} = optimizeAccumOptions bnRemains
426
427 optimizeAccumDecision bn@BusNetwork{bnRemains, bnProcess} oa@OptimizeAccum{} =
428 bn
429 { bnRemains = optimizeAccumDecision bnRemains oa
430 , bnProcess = execScheduleWithProcess bn bnProcess $ do
431 scheduleRefactoring (I.singleton $ nextTick bn) oa
432 }
433
434 instance (UnitTag tag, VarValTime v x t) => OptimizeLogicalUnitProblem (BusNetwork tag v x t) v x where
435 optimizeLogicalUnitOptions BusNetwork{bnRemains} = optimizeLogicalUnitOptions bnRemains
436
437 optimizeLogicalUnitDecision bn@BusNetwork{bnRemains, bnProcess} ol@OptimizeLogicalUnit{} =
438 bn
439 { bnRemains = optimizeLogicalUnitDecision bnRemains ol
440 , bnProcess = execScheduleWithProcess bn bnProcess $ do
441 scheduleRefactoring (I.singleton $ nextTick bn) ol
442 }
443
444 instance (UnitTag tag, VarValTime v x t) => ConstantFoldingProblem (BusNetwork tag v x t) v x where
445 constantFoldingOptions BusNetwork{bnRemains} = constantFoldingOptions bnRemains
446
447 constantFoldingDecision bn@BusNetwork{bnRemains, bnProcess} cf@ConstantFolding{} =
448 bn
449 { bnRemains = constantFoldingDecision bnRemains cf
450 , bnProcess = execScheduleWithProcess bn bnProcess $ do
451 scheduleRefactoring (I.singleton $ nextTick bn) cf
452 }
453
454 instance (UnitTag tag, VarValTime v x t) => ResolveDeadlockProblem (BusNetwork tag v x t) v x where
455 resolveDeadlockOptions bn@BusNetwork{bnPus, bnBound} =
456 let prepareResolve :: S.Set v -> [ResolveDeadlock v x]
457 prepareResolve =
458 map resolveDeadlock
459 . S.elems
460 . S.filter (not . S.null)
461 . ( \lockedVs ->
462 if S.null lockedVs
463 then S.empty
464 else S.filter (not . (lockedVs `S.disjoint`)) $ S.powerSet (var2endpointRole M.! oneOf lockedVs)
465 )
466 . S.filter (isBufferRepetionOK maxBufferStack)
467
468 isBufferRepetionOK 0 _ = False
469 isBufferRepetionOK n v
470 | bufferSuffix v `S.notMember` variables bn = True
471 | otherwise = isBufferRepetionOK (n - 1) (bufferSuffix v)
472
473 selfSending =
474 concatMap
475 (\(tag, fs) -> prepareResolve (unionsMap inputs fs `S.intersection` puOutputs tag))
476 $ M.assocs bnBound
477
478 allPULocks = map (second locks) $ M.assocs bnPus
479
480 resolveLocks =
481 concat
482 [ prepareResolve $ S.singleton lockBy
483 | (tag, ls) <- allPULocks
484 , Lock{lockBy, locked} <- ls
485 , lockBy `S.member` maybeSended
486 , let reversedLock = Lock{lockBy = locked, locked = lockBy}
487 , any (\(t, puLocks) -> tag /= t && reversedLock `elem` puLocks) allPULocks
488 ]
489 in L.nub $ selfSending ++ resolveLocks
490 where
491 endPointRoles = M.map (\pu -> map epRole $ endpointOptions pu) bnPus
492
493 puOutputs tag =
494 unionsMap variables $
495 filter (\case Source{} -> True; _ -> False) $
496 endPointRoles M.! tag
497
498 var2endpointRole =
499 M.fromList
500 $ concatMap
501 ( \case
502 (Source vs) -> [(v, vs) | v <- S.elems vs]
503 (Target v) -> [(v, S.singleton v)]
504 )
505 $ concat
506 $ M.elems endPointRoles
507
508 maybeSended = M.keysSet var2endpointRole
509
510 resolveDeadlockDecision
511 bn@BusNetwork{bnRemains, bnBound, bnPus, bnProcess}
512 ref@ResolveDeadlock{newBuffer, changeset} =
513 let (tag, _) =
514 fromJust
515 $ L.find
516 (\(_, f) -> not $ null $ S.intersection (outputs newBuffer) $ unionsMap outputs f)
517 $ M.assocs bnBound
518 in bn
519 { bnRemains = newBuffer : patch changeset bnRemains
520 , bnPus = M.adjust (patch changeset) tag bnPus
521 , bnBound = M.map (patch changeset) bnBound
522 , bnProcess = execScheduleWithProcess bn bnProcess $ do
523 scheduleRefactoring (I.singleton $ nextTick bn) ref
524 }
525
526 instance UnitTag tag => AllocationProblem (BusNetwork tag v x t) tag where
527 allocationOptions BusNetwork{bnName, bnRemains, bnPUPrototypes} =
528 map toOptions $ M.keys $ M.filter (\PUPrototype{pProto} -> any (`allowToProcess` pProto) bnRemains) bnPUPrototypes
529 where
530 toOptions processUnitTag =
531 Allocation
532 { networkTag = bnName
533 , processUnitTag
534 }
535
536 allocationDecision bn@BusNetwork{bnPUPrototypes, bnPus, bnProcess} alloc@Allocation{networkTag, processUnitTag} =
537 let tag = networkTag <> "_" <> fromTemplate processUnitTag (show (length bnPus))
538 prototype =
539 if M.member processUnitTag bnPUPrototypes
540 then bnPUPrototypes M.! processUnitTag
541 else error $ "No suitable prototype for the tag (" <> toString processUnitTag <> ")"
542 addPU t PUPrototype{pProto, pIOPorts} = modifyNetwork bn $ do addCustom t pProto pIOPorts
543 nBn = addPU tag prototype
544 in nBn
545 { bnProcess = execScheduleWithProcess bn bnProcess $ scheduleAllocation alloc
546 , bnPUPrototypes =
547 if isTemplate processUnitTag
548 then bnPUPrototypes
549 else M.delete processUnitTag bnPUPrototypes
550 }
551
552 --------------------------------------------------------------------------
553
554 controlSignalLiteral ix = [i|control_bus[#{ ix }]|]
555
556 -- | Add binding to Map tag [F v x] dict
557 registerBinding tag f dict =
558 M.alter (maybe (Just [f]) (Just . (f :))) tag dict
559
560 programTicks bn = [-1 .. nextTick bn]
561
562 bnExternalPorts pus =
563 M.assocs $
564 M.map
565 ( \pu ->
566 ( map inputPortTag $ S.toList $ puInputPorts pu
567 , map outputPortTag $ S.toList $ puOutputPorts pu
568 , map inoutPortTag $ S.toList $ puInOutPorts pu
569 )
570 )
571 pus
572
573 externalPortsDecl ports =
574 concatMap
575 ( \(tag, (is, os, ios)) ->
576 concat
577 [ ["// external ports for: " <> toText tag]
578 , map (", input " <>) is
579 , map (", output " <>) os
580 , map (", inout " <>) ios
581 ]
582 )
583 ports
584
585 instance (UnitTag tag, VarValTime v x t) => TargetSystemComponent (BusNetwork tag v x t) where
586 moduleName _tag BusNetwork{bnName} = toText bnName
587
588 hardware tag pu@BusNetwork{..} =
589 let (instances, valuesRegs) = renderInstance [] [] $ M.assocs bnPus
590 mn = moduleName tag pu
591 iml =
592 [__i|
593 module #{ mn } \#
594 ( parameter DATA_WIDTH = #{ dataWidth (def :: x) }
595 , parameter ATTR_WIDTH = #{ attrWidth (def :: x) }
596 )
597 ( input clk
598 , input rst
599 , input is_drop_allow
600 , output flag_cycle_begin
601 , output flag_in_cycle
602 , output flag_cycle_end
603 #{ nest 4 $ vsep $ map pretty $ externalPortsDecl $ bnExternalPorts bnPus }
604 , output [7:0] debug_status
605 , output [7:0] debug_bus1
606 , output [7:0] debug_bus2
607 );
608
609 parameter MICROCODE_WIDTH = #{ bnSignalBusWidth };
610
611 wire start, stop;
612
613 wire [MICROCODE_WIDTH-1:0] control_bus;
614 wire [DATA_WIDTH-1:0] data_bus;
615 wire [ATTR_WIDTH-1:0] attr_bus;
616
617 // Debug
618 assign debug_status = { flag_cycle_begin, flag_in_cycle, flag_cycle_end, data_bus[4:0] };
619 assign debug_bus1 = data_bus[7:0];
620 assign debug_bus2 = data_bus[31:24] | data_bus[23:16] | data_bus[15:8] | data_bus[7:0];
621
622
623 // Sub module instances
624
625 pu_simple_control \#
626 ( .MICROCODE_WIDTH( MICROCODE_WIDTH )
627 , .PROGRAM_DUMP( "{{ impl.paths.nest }}/#{ mn }.dump" )
628 , .MEMORY_SIZE( #{ length $ programTicks pu } ) // 0 - address for nop microcode
629 ) control_unit
630 ( .clk( clk )
631 , .rst( rst )
632
633 , .signal_cycle_start( #{ isDrowAllowSignal ioSync } || stop )
634
635 , .signals_out( control_bus )
636
637 , .flag_cycle_begin( flag_cycle_begin )
638 , .flag_in_cycle( flag_in_cycle )
639 , .flag_cycle_end( flag_cycle_end )
640 );
641
642 #{ vsep $ punctuate "\n\n" instances }
643
644 assign data_bus = #{ T.intercalate " | " $ map snd valuesRegs };
645 assign attr_bus = #{ T.intercalate " | " $ map fst valuesRegs };
646
647 endmodule
648 |]
649 in Aggregate (Just $ toString mn) $
650 [ Immediate (toString $ mn <> ".v") iml
651 , FromLibrary "pu_simple_control.v"
652 ]
653 <> map (uncurry hardware . first toText) (M.assocs bnPus)
654 where
655 regInstance t =
656 [__i|
657 wire [DATA_WIDTH-1:0] #{ t }_data_out;
658 wire [ATTR_WIDTH-1:0] #{ t }_attr_out;
659 |]
660
661 renderInstance insts regs [] = (reverse insts, reverse regs)
662 renderInstance insts regs ((t, PU{unit, uEnv}) : xs) =
663 let inst = hardwareInstance (toText t) unit uEnv
664 insts' = inst : regInstance (toText t) : insts
665 regs' = (toText t <> "_attr_out", toText t <> "_data_out") : regs
666 in renderInstance insts' regs' xs
667
668 software tag pu@BusNetwork{bnProcess = Process{}, ..} =
669 let subSW = map (uncurry software . first toText) $ M.assocs bnPus
670 sw = [Immediate (toString $ mn <> ".dump") $ T.pack memoryDump]
671 in Aggregate (Just $ toString mn) $ subSW ++ sw
672 where
673 mn = moduleName tag pu
674 -- Nop operation sets for all processor units at address 0. It is a
675 -- safe state of the processor which is selected when rst signal is
676 -- active.
677 memoryDump = unlines $ map (values2dump . values . microcodeAt pu) $ programTicks pu
678 values (BusNetworkMC arr) =
679 reverse $
680 map snd $
681 L.sortOn ((\ix -> read ix :: Int) . head . fromJust . matchRegex (mkRegex "([[:digit:]]+)") . T.unpack . signalTag . fst) $
682 M.assocs arr
683
684 hardwareInstance tag BusNetwork{} UnitEnv{sigRst, sigClk, ioPorts = Just ioPorts}
685 | let io2v n = [i|, .#{ n }( #{ n } )|]
686 is = map (io2v . inputPortTag) $ S.toList $ inputPorts ioPorts
687 os = map (io2v . outputPortTag) $ S.toList $ outputPorts ioPorts =
688 [__i|
689 #{ tag } \#
690 ( .DATA_WIDTH( #{ dataWidth (def :: x) } )
691 , .ATTR_WIDTH( #{ attrWidth (def :: x) } )
692 ) net
693 ( .rst( #{ sigRst } )
694 , .clk( #{ sigClk } )
695 // inputs:
696 #{ nest 4 $ vsep is }
697 // outputs:
698 #{ nest 4 $ vsep os }
699 , .debug_status( debug_status ) // FIXME:
700 , .debug_bus1( debug_bus1 ) // FIXME:
701 , .debug_bus2( debug_bus2 ) // FIXME:
702 , .is_drop_allow( rendezvous ) // FIXME:
703 );
704 |]
705 hardwareInstance _title _bn _env =
706 error "BusNetwork should be NetworkEnv"
707
708 instance Connected (BusNetwork tag v x t) where
709 data Ports (BusNetwork tag v x t) = BusNetworkPorts
710 deriving (Show)
711
712 instance IOConnected (BusNetwork tag v x t) where
713 data IOPorts (BusNetwork tag v x t) = BusNetworkIO
714 { extInputs :: S.Set InputPortTag
715 , extOutputs :: S.Set OutputPortTag
716 , extInOuts :: S.Set InoutPortTag
717 }
718 deriving (Show)
719 inputPorts = extInputs
720 outputPorts = extOutputs
721 inoutPorts = extInOuts
722
723 instance (UnitTag tag, VarValTime v x t) => Testable (BusNetwork tag v x t) v x where
724 testBenchImplementation
725 Project
726 { pName
727 , pUnit = bn@BusNetwork{bnPus, ioSync, bnName}
728 , pTestCntx = pTestCntx@Cntx{cntxProcess, cntxCycleNumber}
729 } =
730 let testEnv =
731 vsep
732 $ mapMaybe
733 ( \(tag, PU{unit, uEnv}) ->
734 let tEnv =
735 TestEnvironment
736 { teCntx = pTestCntx
737 , teComputationDuration = fromEnum $ nextTick bn
738 }
739 in testEnvironment (toText tag) unit uEnv tEnv
740 )
741 $ M.assocs bnPus
742
743 externalPortNames = map pretty $ concatMap ((\(is, os, ios) -> is <> os <> ios) . snd) $ bnExternalPorts bnPus
744 externalIO = vsep $ punctuate ", " ("" : map (\p -> [i|.#{ p }( #{ p } )|]) externalPortNames)
745
746 envInitFlags = map pretty $ mapMaybe (uncurry testEnvironmentInitFlag . first toText) $ M.assocs bnPus
747
748 tickWithTransfers =
749 map
750 ( \(cycleI, cycleCntx) ->
751 map
752 (\t -> (cycleI, t, cntxToTransfer cycleCntx t))
753 [0 .. nextTick bn]
754 )
755 $ zip [0 :: Int ..]
756 $ take cntxCycleNumber cntxProcess
757
758 assertions = vsep $ map (\cycleTickTransfer -> posedgeCycle <> line <> vsep (map assertion cycleTickTransfer)) tickWithTransfers
759
760 assertion (cycleI, t, Nothing) =
761 [i|@(posedge clk); traceWithAttr(#{ cycleI }, #{ t }, #{ toString bnName }.data_bus, #{ toString bnName }.attr_bus);|]
762 assertion (cycleI, t, Just (v, x)) =
763 [i|@(posedge clk); assertWithAttr(#{ cycleI }, #{ t }, #{ toString bnName }.data_bus, #{ toString bnName }.attr_bus, #{ dataLiteral x }, #{ attrLiteral x }, "#{ toString v }");|]
764
765 tbName = moduleName pName bn <> "_tb"
766 in Aggregate
767 Nothing
768 [ Immediate (toString $ tbName <> ".v") $
769 doc2text
770 [__i|
771 `timescale 1 ps / 1 ps
772 module #{ tbName }();
773
774 /*
775 Functions:
776 #{ indent 4 $ vsep $ map viaShow $ functions bn }
777 */
778
779 /*
780 Steps:
781 #{ indent 4 $ vsep $ map viaShow $ reverse $ steps $ process bn }
782 */
783
784 // system signals
785 reg clk, rst;
786 wire cycle;
787
788 // clk and rst generator
789 #{ snippetClkGen }
790
791 // vcd dump
792 #{ snippetDumpFile $ moduleName pName bn }
793
794
795 ////////////////////////////////////////////////////////////
796 // test environment
797
798 // external ports (IO)
799 #{ if null externalPortNames then "" else "wire " <> hsep (punctuate ", " externalPortNames) <> ";" }
800
801 // initialization flags
802 #{ if null envInitFlags then "" else "reg " <> hsep (punctuate ", " envInitFlags) <> ";" }
803 assign env_init_flag = #{ hsep $ defEnvInitFlag envInitFlags ioSync };
804
805 #{ testEnv }
806
807
808 ////////////////////////////////////////////////////////////
809 // unit under test
810
811 #{ moduleName pName bn } \#
812 ( .DATA_WIDTH( #{ dataWidth (def :: x) } )
813 , .ATTR_WIDTH( #{ attrWidth (def :: x) } )
814 ) #{ toString bnName }
815 ( .clk( clk )
816 , .rst( rst )
817 , .flag_cycle_begin( cycle )
818 #{ nest 4 externalIO }
819 // if 1 - The process cycle are indipendent from a SPI.
820 // else - The process cycle are wait for the SPI.
821 , .is_drop_allow( #{ isDrowAllowSignal ioSync } )
822 );
823
824 // internal unit under test checks
825 initial
826 begin
827 // microcode when rst == 1 -> program[0], and must be nop for all PUs
828 @(negedge rst); // Turn mUnit on.
829 // Start computational cycle from program[1] to program[n] and repeat.
830 // Signals effect to mUnit state after first clk posedge.
831 @(posedge clk);
832 while (!env_init_flag) @(posedge clk);
833 #{ nest 8 assertions }
834 repeat ( #{ 2 * nextTick bn } ) @(posedge clk);
835 $finish;
836 end
837
838 // TIMEOUT
839 initial
840 begin
841 repeat (100000) @(posedge clk);
842 $display("FAIL too long simulation process");
843 $finish;
844 end
845
846 ////////////////////////////////////////////////////////////
847 // Utils
848 #{ verilogHelper (def :: x) }
849
850 endmodule
851 |]
852 , Immediate (toString $ tbName <> ".gtkw") $
853 T.pack
854 [__i|
855 [*]
856 [*] GTKWave Analyzer v3.3.107 (w)1999-2020 BSI
857 [*] Fri Mar 12 11:37:55 2021
858 [*]
859 [dumpfile] "{{ nitta.paths.abs_nitta }}/#{ tbName }.vcd"
860 [timestart] 0
861 *-6.864726 0 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
862 [treeopen] #{ tbName }.
863 [treeopen] #{ tbName }.#{ toString bnName }.
864 [sst_width] 193
865 [signals_width] 203
866 [sst_expanded] 1
867 [sst_vpaned_height] 167
868 @28
869 #{ tbName }.clk
870 #{ tbName }.rst
871 #{ tbName }.cycle
872 @24
873 #{ tbName }.#{ toString bnName }.control_unit.pc[5:0]
874 @28
875 #{ tbName }.#{ toString bnName }.control_unit.flag_cycle_begin
876 #{ tbName }.#{ toString bnName }.control_unit.flag_cycle_end
877 @25
878 #{ tbName }.#{ toString bnName }.data_bus[31:0]
879 @22
880 #{ tbName }.#{ toString bnName }.attr_bus[3:0]
881 [pattern_trace] 1
882 [pattern_trace] 0
883 |]
884 ]
885 where
886 defEnvInitFlag flags Sync = punctuate " && " $ "1'b1" : flags
887 defEnvInitFlag flags ASync = punctuate " || " $ "1'b1" : flags
888 defEnvInitFlag _flags OnBoard = error "can't generate testbench without specific IOSynchronization"
889
890 cntxToTransfer cycleCntx t =
891 case extractInstructionAt bn t of
892 Transport v _ _ : _ -> Just (v, getCntx cycleCntx v)
893 _ -> Nothing
894
895 posedgeCycle =
896 [__i|
897 //-----------------------------------------------------------------
898 @(posedge cycle);
899 |]
900
901 isDrowAllowSignal Sync = bool2verilog False
902 isDrowAllowSignal ASync = bool2verilog True
903 isDrowAllowSignal OnBoard = "is_drop_allow"
904
905 -- * Builder
906
907 data BuilderSt tag v x t = BuilderSt
908 { signalBusWidth :: Int
909 , availSignals :: [SignalTag]
910 , pus :: M.Map tag (PU v x t)
911 , prototypes :: M.Map tag (PUPrototype tag v x t)
912 }
913
914 modifyNetwork :: BusNetwork k v x t -> State (BuilderSt k v x t) a -> BusNetwork k v x t
915 modifyNetwork net@BusNetwork{bnPus, bnPUPrototypes, bnSignalBusWidth, bnEnv} builder =
916 let st0 =
917 BuilderSt
918 { signalBusWidth = bnSignalBusWidth
919 , availSignals = map (SignalTag . controlSignalLiteral) [bnSignalBusWidth :: Int ..]
920 , pus = bnPus
921 , prototypes = bnPUPrototypes
922 }
923 BuilderSt{signalBusWidth, pus, prototypes} = execState builder st0
924 netIOPorts ps =
925 BusNetworkIO
926 { extInputs = unionsMap puInputPorts ps
927 , extOutputs = unionsMap puOutputPorts ps
928 , extInOuts = unionsMap puInOutPorts ps
929 }
930 in net
931 { bnPus = pus
932 , bnSignalBusWidth = signalBusWidth
933 , bnEnv = bnEnv{ioPorts = Just $ netIOPorts $ M.elems pus}
934 , bnPUPrototypes = prototypes
935 }
936
937 defineNetwork :: Default t => k -> IOSynchronization -> State (BuilderSt k v x t) a -> BusNetwork k v x t
938 defineNetwork bnName ioSync builder = modifyNetwork (busNetwork bnName ioSync) builder
939
940 addCustom ::
941 forall tag v x t m pu.
942 (MonadState (BuilderSt tag v x t) m, PUClasses pu v x t, UnitTag tag) =>
943 tag ->
944 pu ->
945 IOPorts pu ->
946 m ()
947 addCustom tag pu ioPorts = do
948 st@BuilderSt{signalBusWidth, availSignals, pus} <- get
949 let ctrlPorts = takePortTags availSignals pu
950 puEnv =
951 def
952 { ctrlPorts = Just ctrlPorts
953 , ioPorts = Just ioPorts
954 , valueIn = Just ("data_bus", "attr_bus")
955 , valueOut = Just (toText tag <> "_data_out", toText tag <> "_attr_out")
956 }
957 pu' = PU pu def puEnv
958 usedPortsLen = length $ usedPortTags ctrlPorts
959 put
960 st
961 { signalBusWidth = signalBusWidth + usedPortsLen
962 , availSignals = drop usedPortsLen availSignals
963 , pus = M.insertWith (\_ _ -> error "every PU must has uniq tag") tag pu' pus
964 }
965
966 -- | Add PU with the default initial state. Type specify by IOPorts.
967 add ::
968 (MonadState (BuilderSt tag v x t) m, PUClasses pu v x t, Default pu, UnitTag tag) =>
969 tag ->
970 IOPorts pu ->
971 m ()
972 add tag ioport = addCustom tag def ioport
973
974 addCustomPrototype ::
975 forall tag v x t m pu.
976 (MonadState (BuilderSt tag v x t) m, PUClasses pu v x t, UnitTag tag) =>
977 tag ->
978 pu ->
979 IOPorts pu ->
980 m ()
981 addCustomPrototype tag pu ioports
982 | typeOf pu == typeRep (Proxy :: Proxy (SPI v x t)) =
983 error "Adding SPI prototype are not supported due to https://github.com/ryukzak/nitta/issues/194"
984 | otherwise = do
985 st@BuilderSt{prototypes} <- get
986 put
987 st
988 { prototypes =
989 M.insertWith
990 (\_ _ -> error "every prototype must has uniq tag")
991 tag
992 (PUPrototype tag pu ioports)
993 prototypes
994 }
995
996 -- | Add PU to prototypes with the default initial state. Type specify by IOPorts.
997 addPrototype ::
998 (MonadState (BuilderSt tag v x t) m, PUClasses pu v x t, Default pu, UnitTag tag) =>
999 tag ->
1000 IOPorts pu ->
1001 m ()
1002 addPrototype tag ioports = addCustomPrototype tag def ioports