never executed always true always false
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TypeFamilies #-}
6
7 {- |
8 Module : NITTA.Model.ProcessorUnits.IO.SimpleIO
9 Description :
10 Copyright : (c) Aleksandr Penskoi, 2019
11 License : BSD3
12 Maintainer : aleksandr.penskoi@gmail.com
13 Stability : experimental
14 -}
15 module NITTA.Model.ProcessorUnits.IO.SimpleIO (
16 SimpleIOInterface,
17 SimpleIO (..),
18 Ports (..),
19 protocolDescription,
20 ) where
21
22 import Control.Monad
23 import Data.Aeson (ToJSON (toJSON))
24 import Data.Aeson.Encode.Pretty
25 import Data.Default
26 import Data.List qualified as L
27 import Data.Maybe
28 import Data.Set qualified as S
29 import Data.String.Interpolate
30 import Data.String.ToString
31 import Data.Text qualified as T
32 import Data.Text.Lazy (toStrict)
33 import Data.Text.Lazy.Builder
34 import Data.Typeable
35 import GHC.Generics (Generic)
36 import NITTA.Intermediate.Functions qualified as F
37 import NITTA.Intermediate.Types
38 import NITTA.Model.Problems
39 import NITTA.Model.ProcessorUnits.Types
40 import NITTA.Model.Time
41 import NITTA.Project.Types (Implementation (Immediate))
42 import NITTA.Utils
43 import NITTA.Utils.ProcessDescription
44 import Numeric.Interval.NonEmpty ((...))
45 import Numeric.Interval.NonEmpty qualified as I
46 import Prettyprinter
47
48 class Typeable i => SimpleIOInterface i
49
50 data SimpleIO i v x t = SimpleIO
51 { bounceFilter :: Int
52 , bufferSize :: Maybe Int
53 -- ^ if 'Nothing' then size should defined by algorithm
54 , receiveQueue :: [Q v x]
55 , receiveN :: Int
56 , isReceiveOver :: Bool
57 -- ^ set if send buffer overlap receive buffer
58 , sendQueue :: [Q v x]
59 , sendN :: Int
60 , process_ :: Process t (StepInfo v x t)
61 }
62
63 instance (VarValTime v x t, SimpleIOInterface i) => Pretty (SimpleIO i v x t) where
64 pretty io =
65 [__i|
66 SimpleIO:
67 bounceFilter: #{ bounceFilter io }
68 bufferSize: #{ bufferSize io }
69 receiveQueue: #{ receiveQueue io }
70 receiveN: #{ receiveN io }
71 isReceiveOver: #{ isReceiveOver io }
72 sendQueue: #{ sendQueue io }
73 sendN: #{ sendN io }
74 #{ indent 4 $ pretty $ process_ io }
75 |]
76
77 data Q v x = Q {vars :: [v], function :: F v x, cads :: [ProcessStepID]}
78
79 instance (Var v, Val x) => Show (Q v x) where
80 show Q{vars, function, cads} =
81 concat
82 [ "Q{"
83 , "vars: " <> concatMap toString vars <> ","
84 , "function: " <> show function <> ","
85 , "cads : " <> show cads <> "}"
86 ]
87
88 instance
89 (VarValTime v x t, SimpleIOInterface i) =>
90 ProcessorUnit (SimpleIO i v x t) v x t
91 where
92 tryBind f sio@SimpleIO{sendQueue, receiveQueue, receiveN, sendN, bufferSize}
93 | Just F.Receive{} <- castF f
94 , fromMaybe maxBound bufferSize == receiveN =
95 Left "IO process unit to small buffer size"
96 | Just F.Send{} <- castF f
97 , fromMaybe maxBound bufferSize == sendN =
98 Left "IO process unit to small buffer size"
99 | Just (F.Receive (O vs)) <- castF f
100 , let (cads, process_) = runSchedule sio $ scheduleFunctionBind f =
101 Right
102 sio
103 { receiveQueue = Q{vars = S.elems vs, function = f, cads} : receiveQueue
104 , receiveN = receiveN + 1
105 , process_
106 }
107 | Just (F.Send (I v)) <- castF f
108 , let (cads, process_) = runSchedule sio $ scheduleFunctionBind f =
109 Right
110 sio
111 { sendQueue = Q{vars = [v], function = f, cads} : sendQueue
112 , sendN = sendN + 1
113 , process_
114 }
115 | otherwise = Left $ "IO processor unit do not support: " ++ show f
116
117 process = process_
118
119 instance BreakLoopProblem (SimpleIO i v x t) v x
120 instance ConstantFoldingProblem (SimpleIO i v x t) v x
121 instance OptimizeAccumProblem (SimpleIO i v x t) v x
122 instance ResolveDeadlockProblem (SimpleIO i v x t) v x
123
124 instance
125 (VarValTime v x t, SimpleIOInterface i) =>
126 EndpointProblem (SimpleIO i v x t) v t
127 where
128 endpointOptions pu@SimpleIO{receiveQueue, sendQueue} =
129 let source vs = EndpointSt (Source $ S.fromList vs) $ TimeConstraint (nextTick pu + 1 ... maxBound) (1 ... maxBound)
130 receiveOpts = map (source . vars) receiveQueue
131
132 target v = EndpointSt (Target v) $ TimeConstraint (nextTick pu ... maxBound) (I.singleton 1)
133 sendOpts = map (target . head . vars) sendQueue
134 in receiveOpts ++ sendOpts
135
136 endpointDecision sio@SimpleIO{receiveQueue} d@EndpointSt{epRole = Source vs, epAt}
137 | ([q@Q{function, vars = allVars}], receiveQueue') <-
138 L.partition ((vs `S.isSubsetOf`) . S.fromList . vars) receiveQueue
139 , let remainVars = allVars L.\\ S.elems vs
140 process_ = execSchedule sio $ do
141 void $ scheduleEndpoint d $ scheduleInstructionUnsafe epAt $ Receiving $ null remainVars
142 when (null remainVars) $ void $ scheduleFunction epAt function
143 receiveQueue'' =
144 if null remainVars
145 then receiveQueue'
146 else q{vars = remainVars} : receiveQueue' =
147 sio{receiveQueue = receiveQueue'', process_}
148 endpointDecision sio@SimpleIO{sendQueue, sendN, receiveQueue, receiveN} d@EndpointSt{epRole = Target v, epAt}
149 | ([Q{function}], sendQueue') <- L.partition ((v ==) . head . vars) sendQueue
150 , let process_ = execSchedule sio $ do
151 void $ scheduleEndpoint d $ scheduleInstructionUnsafe epAt Sending
152 scheduleFunction epAt function =
153 sio
154 { sendQueue = sendQueue'
155 , isReceiveOver = (sendN - length sendQueue) >= (receiveN - length receiveQueue)
156 , process_
157 }
158 endpointDecision pu d = error [i|incorrect decision #{ d } for #{ pretty pu }|]
159
160 {- | Access to received data buffer was implemented like a queue. OE signal read
161 received value multiple times __without changing__ "pointer" to the next value.
162 OE and WR signals simultaneously read received value and __increment__ "pointer"
163 to the next value. We do that for the reduced number of signal lines.
164
165 Example:
166
167 1. Nop - do nothing;
168
169 2. Send (WR signal) - read a value from data_bus to send buffer[0], pointer
170 increments automatically.
171
172 3. Send (WR signal) - read a value from data_bus to send buffer[1], pointer
173 increments automatically.
174
175 4. Nop - do nothing.
176
177 5. Receive False (OE signal) - write a value to data_bus from receive buffer[0]
178 without pointer changing.
179
180 6. Receive True (OE and WR signal) - write a value to data_bus from receive
181 buffer[0] with pointer increment.
182 -}
183 instance Controllable (SimpleIO i v x t) where
184 data Instruction (SimpleIO i v x t)
185 = Receiving Bool
186 | Sending
187 deriving (Show)
188
189 data Microcode (SimpleIO i v x t) = Microcode
190 { wrSignal :: Bool
191 , oeSignal :: Bool
192 }
193 deriving (Show, Eq, Ord)
194
195 zipSignalTagsAndValues SimpleIOPorts{..} Microcode{..} =
196 [ (wr, Bool wrSignal)
197 , (oe, Bool oeSignal)
198 ]
199
200 usedPortTags SimpleIOPorts{wr, oe} = [wr, oe]
201
202 takePortTags (wr : oe : _) _ = SimpleIOPorts wr oe "stop"
203 takePortTags _ _ = error "can not take port tags, tags are over"
204
205 instance Default (Microcode (SimpleIO i v x t)) where
206 def =
207 Microcode
208 { wrSignal = False
209 , oeSignal = False
210 }
211
212 instance UnambiguouslyDecode (SimpleIO i v x t) where
213 decodeInstruction Sending = def{wrSignal = True}
214 decodeInstruction (Receiving next) = def{oeSignal = True, wrSignal = next}
215
216 instance Connected (SimpleIO i v x t) where
217 data Ports (SimpleIO i v x t) = SimpleIOPorts
218 { wr, oe :: SignalTag
219 , -- \|this flag which indicates an end of the data transaction
220 -- requires for stop computational process while data transferring
221 -- to avoid loses
222 stop :: String
223 }
224 deriving (Show)
225
226 instance Var v => Locks (SimpleIO i v x t) v where
227 locks SimpleIO{} = []
228
229 data ProtocolDescription v = ProtocolDescription
230 { description :: T.Text
231 , interface :: T.Text
232 , dataType :: T.Text
233 , toNitta :: [v]
234 , fromNitta :: [v]
235 }
236 deriving (Generic)
237
238 instance ToJSON v => ToJSON (ProtocolDescription v)
239
240 protocolDescription ::
241 forall i v x t.
242 (VarValTime v x t, SimpleIOInterface i, ToJSON v) =>
243 T.Text ->
244 SimpleIO i v x t ->
245 T.Text ->
246 Implementation
247 protocolDescription tag io d
248 | not $ null $ endpointOptions io = error "EndpointProblem is not completed"
249 | otherwise =
250 let impFile = toString $ tag <> ".json"
251 fbs = getIntermediates $ process_ io
252 in Immediate impFile $
253 toStrict $
254 toLazyText $
255 encodePrettyToTextBuilder $
256 toJSON
257 ProtocolDescription
258 { description = d
259 , interface = showText $ typeRep (Proxy :: Proxy i)
260 , dataType = showText $ typeRep (Proxy :: Proxy x)
261 , toNitta = map (oneOf . outputs) $ filter isReceive fbs
262 , fromNitta = map (oneOf . inputs) $ filter isSend fbs
263 }
264
265 isReceive :: (Typeable v, Typeable x) => F v x -> Bool
266 isReceive f
267 | Just F.Receive{} <- castF f = True
268 | otherwise = False
269
270 isSend :: (Typeable v, Typeable x) => F v x -> Bool
271 isSend f
272 | Just F.Send{} <- castF f = True
273 | otherwise = False