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) => 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