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 OptimizeLogicalUnitProblem (SimpleIO i v x t) v x
  123 instance ResolveDeadlockProblem (SimpleIO i v x t) v x
  124 
  125 instance
  126     (VarValTime v x t, SimpleIOInterface i) =>
  127     EndpointProblem (SimpleIO i v x t) v t
  128     where
  129     endpointOptions pu@SimpleIO{receiveQueue, sendQueue} =
  130         let source vs = EndpointSt (Source $ S.fromList vs) $ TimeConstraint (nextTick pu + 1 ... maxBound) (1 ... maxBound)
  131             receiveOpts = map (source . vars) receiveQueue
  132 
  133             target v = EndpointSt (Target v) $ TimeConstraint (nextTick pu ... maxBound) (I.singleton 1)
  134             sendOpts = map (target . head . vars) sendQueue
  135          in receiveOpts ++ sendOpts
  136 
  137     endpointDecision sio@SimpleIO{receiveQueue} d@EndpointSt{epRole = Source vs, epAt}
  138         | ([q@Q{function, vars = allVars}], receiveQueue') <-
  139             L.partition ((vs `S.isSubsetOf`) . S.fromList . vars) receiveQueue
  140         , let remainVars = allVars L.\\ S.elems vs
  141               process_ = execSchedule sio $ do
  142                 void $ scheduleEndpoint d $ scheduleInstructionUnsafe epAt $ Receiving $ null remainVars
  143                 when (null remainVars) $ void $ scheduleFunction epAt function
  144               receiveQueue'' =
  145                 if null remainVars
  146                     then receiveQueue'
  147                     else q{vars = remainVars} : receiveQueue' =
  148             sio{receiveQueue = receiveQueue'', process_}
  149     endpointDecision sio@SimpleIO{sendQueue, sendN, receiveQueue, receiveN} d@EndpointSt{epRole = Target v, epAt}
  150         | ([Q{function}], sendQueue') <- L.partition ((v ==) . head . vars) sendQueue
  151         , let process_ = execSchedule sio $ do
  152                 void $ scheduleEndpoint d $ scheduleInstructionUnsafe epAt Sending
  153                 scheduleFunction epAt function =
  154             sio
  155                 { sendQueue = sendQueue'
  156                 , isReceiveOver = (sendN - length sendQueue) >= (receiveN - length receiveQueue)
  157                 , process_
  158                 }
  159     endpointDecision pu d = error [i|incorrect decision #{ d } for #{ pretty pu }|]
  160 
  161 {- | Access to received data buffer was implemented like a queue. OE signal read
  162 received value multiple times __without changing__ "pointer" to the next value.
  163 OE and WR signals simultaneously read received value and __increment__ "pointer"
  164 to the next value. We do that for the reduced number of signal lines.
  165 
  166 Example:
  167 
  168 1. Nop - do nothing;
  169 
  170 2. Send (WR signal) - read a value from data_bus to send buffer[0], pointer
  171    increments automatically.
  172 
  173 3. Send (WR signal) - read a value from data_bus to send buffer[1], pointer
  174    increments automatically.
  175 
  176 4. Nop - do nothing.
  177 
  178 5. Receive False (OE signal) - write a value to data_bus from receive buffer[0]
  179    without pointer changing.
  180 
  181 6. Receive True (OE and WR signal) - write a value to data_bus from receive
  182    buffer[0] with pointer increment.
  183 -}
  184 instance Controllable (SimpleIO i v x t) where
  185     data Instruction (SimpleIO i v x t)
  186         = Receiving Bool
  187         | Sending
  188         deriving (Show)
  189 
  190     data Microcode (SimpleIO i v x t) = Microcode
  191         { wrSignal :: Bool
  192         , oeSignal :: Bool
  193         }
  194         deriving (Show, Eq, Ord)
  195 
  196     zipSignalTagsAndValues SimpleIOPorts{..} Microcode{..} =
  197         [ (wr, Bool wrSignal)
  198         , (oe, Bool oeSignal)
  199         ]
  200 
  201     usedPortTags SimpleIOPorts{wr, oe} = [wr, oe]
  202 
  203     takePortTags (wr : oe : _) _ = SimpleIOPorts wr oe "stop"
  204     takePortTags _ _ = error "can not take port tags, tags are over"
  205 
  206 instance Default (Microcode (SimpleIO i v x t)) where
  207     def =
  208         Microcode
  209             { wrSignal = False
  210             , oeSignal = False
  211             }
  212 
  213 instance UnambiguouslyDecode (SimpleIO i v x t) where
  214     decodeInstruction Sending = def{wrSignal = True}
  215     decodeInstruction (Receiving next) = def{oeSignal = True, wrSignal = next}
  216 
  217 instance Connected (SimpleIO i v x t) where
  218     data Ports (SimpleIO i v x t) = SimpleIOPorts
  219         { wr, oe :: SignalTag
  220         , -- \|this flag which indicates an end of the data transaction
  221           -- requires for stop computational process while data transferring
  222           -- to avoid loses
  223           stop :: String
  224         }
  225         deriving (Show)
  226 
  227 instance Var v => Locks (SimpleIO i v x t) v where
  228     locks SimpleIO{} = []
  229 
  230 data ProtocolDescription v = ProtocolDescription
  231     { description :: T.Text
  232     , interface :: T.Text
  233     , dataType :: T.Text
  234     , toNitta :: [v]
  235     , fromNitta :: [v]
  236     }
  237     deriving (Generic)
  238 
  239 instance ToJSON v => ToJSON (ProtocolDescription v)
  240 
  241 protocolDescription ::
  242     forall i v x t.
  243     (VarValTime v x t, SimpleIOInterface i, ToJSON v) =>
  244     T.Text ->
  245     SimpleIO i v x t ->
  246     T.Text ->
  247     Implementation
  248 protocolDescription tag io d
  249     | not $ null $ endpointOptions io = error "EndpointProblem is not completed"
  250     | otherwise =
  251         let impFile = toString $ tag <> ".json"
  252             fbs = getIntermediates $ process_ io
  253          in Immediate impFile $
  254                 toStrict $
  255                     toLazyText $
  256                         encodePrettyToTextBuilder $
  257                             toJSON
  258                                 ProtocolDescription
  259                                     { description = d
  260                                     , interface = showText $ typeRep (Proxy :: Proxy i)
  261                                     , dataType = showText $ typeRep (Proxy :: Proxy x)
  262                                     , toNitta = map (oneOf . outputs) $ filter isReceive fbs
  263                                     , fromNitta = map (oneOf . inputs) $ filter isSend fbs
  264                                     }
  265 
  266 isReceive :: (Typeable v, Typeable x) => F v x -> Bool
  267 isReceive f
  268     | Just F.Receive{} <- castF f = True
  269     | otherwise = False
  270 
  271 isSend :: (Typeable v, Typeable x) => F v x -> Bool
  272 isSend f
  273     | Just F.Send{} <- castF f = True
  274     | otherwise = False