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