never executed always true always false
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE QuasiQuotes #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE TypeFamilies #-}
5
6 {- |
7 Module : NITTA.Model.ProcessorUnits.Comparator
8 Description : A comparator that supports operations: <, <=, >, >=, ==
9 Copyright : (c) Boris Novoselov, 2025
10 License : BSD3
11 Stability : experimental
12 -}
13 module NITTA.Model.ProcessorUnits.Comparator (
14 Comparator,
15 compare,
16 Ports (..),
17 IOPorts (..),
18 ) where
19
20 import Control.Monad (when)
21 import Data.Bits hiding (bit)
22 import Data.Data (dataTypeConstrs, dataTypeOf)
23 import Data.Default (Default, def)
24 import Data.Foldable
25 import Data.List (partition, (\\))
26 import Data.Maybe
27 import Data.Set qualified as S
28 import Data.String.Interpolate
29 import Data.String.ToString
30 import Data.Text qualified as T
31 import NITTA.Intermediate.Functions qualified as F
32 import NITTA.Intermediate.Types
33 import NITTA.Model.Problems
34 import NITTA.Model.ProcessorUnits.Types
35 import NITTA.Model.Time
36 import NITTA.Project
37 import NITTA.Utils
38 import NITTA.Utils.ProcessDescription
39 import Numeric.Interval.NonEmpty hiding (elem, notElem)
40 import Prettyprinter
41 import Prelude hiding (compare)
42
43 data Comparator v x t = Comparator
44 { remain :: [F v x]
45 , targets :: [v]
46 , sources :: [v]
47 , currentWork :: Maybe (F v x)
48 , process_ :: Process t (StepInfo v x t)
49 }
50
51 compare :: Time t => Comparator v x t
52 compare =
53 Comparator
54 { remain = []
55 , targets = []
56 , sources = []
57 , currentWork = Nothing
58 , process_ = def
59 }
60
61 instance VarValTime v x t => ProcessorUnit (Comparator v x t) v x t where
62 tryBind f pu@Comparator{remain}
63 | Just F.Compare{} <- castF f =
64 Right
65 pu
66 { remain = f : remain
67 }
68 | otherwise = Left "Unsupported function type for Comparator"
69
70 process = process_
71
72 instance Connected (Comparator v x t) where
73 data Ports (Comparator v x t) = ComparePorts
74 { oePort :: SignalTag
75 , wrPort :: SignalTag
76 , opSelPort :: [SignalTag]
77 }
78 deriving (Show)
79
80 supportedOpsNum :: Int
81 supportedOpsNum = fromIntegral $ length (dataTypeConstrs $ dataTypeOf F.CmpEq)
82 selWidth = ceiling (logBase 2 (fromIntegral supportedOpsNum) :: Double) :: Int
83
84 instance Controllable (Comparator v x t) where
85 data Instruction (Comparator v x t)
86 = Load F.CmpOp
87 | Out
88 deriving (Show)
89
90 data Microcode (Comparator v x t) = Microcode
91 { oe :: Bool
92 , wr :: Bool
93 , opSel :: Int
94 }
95 deriving (Show, Eq)
96
97 zipSignalTagsAndValues ComparePorts{..} Microcode{..} =
98 [ (oePort, Bool oe)
99 , (wrPort, Bool wr)
100 ]
101 ++ zipWith (\tag bit -> (tag, Bool bit)) opSelPort (bits opSel selWidth)
102 where
103 bits val localWidth = [testBit val (localWidth - idx - 1) | idx <- [0 .. localWidth - 1]]
104 usedPortTags ComparePorts{oePort, wrPort, opSelPort} = oePort : wrPort : opSelPort
105
106 takePortTags (oe : wr : xs) _ = ComparePorts oe wr sel
107 where
108 sel = take selWidth xs
109 takePortTags _ _ = error "can not take port tags, tags are over"
110
111 instance Var v => Locks (Comparator v x t) v where
112 locks Comparator{remain, sources, targets} =
113 [ Lock{lockBy, locked}
114 | locked <- sources
115 , lockBy <- targets
116 ]
117 ++ [ Lock{lockBy, locked}
118 | locked <- concatMap (S.elems . variables) remain
119 , lockBy <- sources ++ targets
120 ]
121 ++ concatMap locks remain
122 instance Default (Microcode (Comparator v x t)) where
123 def =
124 Microcode
125 { wr = False
126 , oe = False
127 , opSel = 0
128 }
129
130 instance UnambiguouslyDecode (Comparator v x t) where
131 decodeInstruction Out = def{oe = True}
132 decodeInstruction (Load op) = case op of
133 F.CmpEq -> def{opSel = 0, wr = True}
134 F.CmpLt -> def{opSel = 1, wr = True}
135 F.CmpLte -> def{opSel = 2, wr = True}
136 F.CmpGt -> def{opSel = 3, wr = True}
137 F.CmpGte -> def{opSel = 4, wr = True}
138
139 instance Default x => DefaultX (Comparator v x t) x
140
141 instance Time t => Default (Comparator v x t) where
142 def = compare
143
144 flipCmpOp :: F.CmpOp -> F.CmpOp
145 flipCmpOp F.CmpEq = F.CmpEq
146 flipCmpOp F.CmpLt = F.CmpGt
147 flipCmpOp F.CmpLte = F.CmpGte
148 flipCmpOp F.CmpGt = F.CmpLt
149 flipCmpOp F.CmpGte = F.CmpLte
150
151 instance VarValTime v x t => EndpointProblem (Comparator v x t) v t where
152 endpointOptions pu@Comparator{targets = target : _} =
153 [EndpointSt (Target target) $ TimeConstraint at duration]
154 where
155 at = nextTick pu ... maxBound
156 duration = 1 ... maxBound
157 endpointOptions
158 pu@Comparator
159 { sources = _ : _
160 , currentWork = Just f
161 , process_
162 } = [EndpointSt (Source $ S.fromList (sources pu)) $ TimeConstraint at duration]
163 where
164 doneAt = inputsPushedAt process_ f + 3
165 at = max doneAt (nextTick process_) ... maxBound
166 duration = 1 ... maxBound
167 endpointOptions pu@Comparator{remain} =
168 concatMap (endpointOptions . execution pu) remain
169
170 endpointDecision pu@Comparator{targets, currentWork} d@EndpointSt{epRole = Target v, epAt}
171 | not $ null targets
172 , ([_], targets') <- partition (== v) targets
173 , -- Computation process planning is carried out.
174 let process_' = execSchedule pu $ do
175 -- this is required for correct work of automatically generated tests,
176 -- that takes information about time from Process
177 case currentWork of
178 Just f
179 | Just (F.Compare op (I a) (I _) _) <- castF f ->
180 let adjustedOp = if v == a then op else flipCmpOp op
181 in scheduleEndpoint d $ scheduleInstructionUnsafe epAt (Load adjustedOp)
182 | otherwise -> error "Unsupported function type for Comparator"
183 Nothing -> error "cmpOp is Nothing" =
184 pu
185 { process_ = process_'
186 , -- The remainder of the work is saved for the next loop
187 targets = targets'
188 }
189 endpointDecision pu@Comparator{targets = [], sources, currentWork = Just f, process_} d@EndpointSt{epRole = Source v, epAt}
190 | not $ null sources
191 , let sources' = sources \\ S.elems v
192 , sources' /= sources
193 , let a = inf $ stepsInterval $ relatedEndpoints process_ $ variables f
194 , -- Compututation process planning is carring on.
195 let process_' = execSchedule pu $ do
196 endpoints <- scheduleEndpoint d $ scheduleInstructionUnsafe epAt Out
197 when (null sources') $ do
198 scheduleFunctionFinish_ [] f $ a ... sup epAt
199 return endpoints =
200 pu
201 { process_ = process_'
202 , -- In case if not all variables what asked - remaining are saved.
203 sources = sources'
204 , -- if all of works is done, then time when result is ready,
205 -- current work and data transfering, what is done is the current function is reset.
206 currentWork = if null sources' then Nothing else Just f
207 }
208 endpointDecision pu@Comparator{targets = [], sources = [], remain} d
209 | let v = oneOf $ variables d
210 , Just f <- find (\f -> v `S.member` variables f) remain =
211 endpointDecision (execution pu f) d
212 endpointDecision pu d = error [i|incorrect decision #{ d } for #{ pretty pu }|]
213
214 execution pu@Comparator{targets = [], sources = [], remain} f
215 | Just (F.Compare _ (I a) (I b) (O c)) <- castF f =
216 pu
217 { targets = [a, b]
218 , currentWork = Just f
219 , sources = S.elems c
220 , remain = filter (/= f) remain
221 }
222 execution _ f =
223 error $
224 "Comparator: internal execution error. Expected Compare, got: " ++ show f
225
226 instance VarValTime v x t => Pretty (Comparator v x t) where
227 pretty Comparator{remain, targets, sources, currentWork, process_} =
228 [__i|
229 Comparator:
230 remain: #{ remain }
231 targets: #{ map toString targets }
232 sources: #{ map toString sources }
233 currentWork: #{ currentWork }
234 #{ nest 4 $ pretty process_ }
235 |]
236
237 instance IOConnected (Comparator v x t) where
238 data IOPorts (Comparator v x t) = CompareIO
239 deriving (Show)
240
241 instance BreakLoopProblem (Comparator v x t) v x
242
243 instance ConstantFoldingProblem (Comparator v x t) v x
244
245 instance OptimizeAccumProblem (Comparator v x t) v x
246
247 instance ResolveDeadlockProblem (Comparator v x t) v x
248
249 instance IOTestBench (Comparator v x t) v x
250
251 instance OptimizeLogicalUnitProblem (Comparator v x t) v x
252
253 instance VarValTime v x t => TargetSystemComponent (Comparator v x t) where
254 moduleName _ _ = T.pack "pu_compare"
255 software _ _ = Empty
256 hardware _tag _pu = FromLibrary "pu_compare.v"
257
258 hardwareInstance
259 tag
260 _pu
261 UnitEnv
262 { sigClk
263 , sigRst
264 , ctrlPorts = Just ComparePorts{..}
265 , valueIn = Just (dataIn, attrIn)
266 , valueOut = Just (dataOut, attrOut)
267 } =
268 [__i|
269 pu_compare \#
270 ( .DATA_WIDTH( #{ dataWidth (def :: x) } )
271 , .ATTR_WIDTH( #{ attrWidth (def :: x) } )
272 , .SEL_WIDTH( #{ selWidth } )
273 ) #{ tag } (
274 .clk(#{ sigClk }),
275 .rst( #{ sigRst } ),
276 .oe(#{ oePort }),
277 .wr(#{ wrPort }),
278 .op_sel({ #{ T.intercalate (T.pack ", ") $ map showText opSelPort } })
279
280 , .data_in( #{ dataIn } )
281 , .attr_in( #{ attrIn } )
282 , .data_out( #{ dataOut } )
283 , .attr_out( #{ attrOut } )
284 );
285 |]
286 hardwareInstance _title _pu _env = error "internal error"
287
288 instance Ord t => WithFunctions (Comparator v x t) (F v x) where
289 functions Comparator{process_, remain, currentWork} =
290 functions process_
291 ++ remain
292 ++ maybeToList currentWork
293
294 instance VarValTime v x t => Testable (Comparator v x t) v x where
295 testBenchImplementation prj@Project{pName, pUnit} =
296 let tbcSignalsConst = [T.pack "oe", T.pack "wr", T.pack $ "[" ++ show (selWidth - 1) ++ ":0] op_sel"]
297 showMicrocode Microcode{oe, wr, opSel} =
298 [i|oe <= #{ bool2verilog oe };|]
299 <> [i| wr <= #{ bool2verilog wr };|]
300 <> [i| op_sel <= #{ show opSel };|]
301 in Immediate (toString $ moduleName pName pUnit <> T.pack "_tb.v") $
302 snippetTestBench
303 prj
304 SnippetTestBenchConf
305 { tbcSignals = tbcSignalsConst
306 , tbcPorts =
307 ComparePorts
308 { oePort = SignalTag (T.pack "oe")
309 , wrPort = SignalTag (T.pack "wr")
310 , opSelPort =
311 [ (SignalTag . T.pack) ("op_sel[" <> show p <> "]")
312 | p <- [selWidth - 1, selWidth - 2 .. 0]
313 ]
314 }
315 , tbcMC2verilogLiteral = showMicrocode
316 }