module SoOSiM.SimMonad where
import Control.Concurrent.STM
import Control.Monad.Coroutine
import Control.Monad.State
import Control.Monad.Trans.Class ()
import Data.IntMap as IntMap
import Data.Map as Map
import Data.Maybe
import SoOSiM.Simulator
import SoOSiM.Types
import SoOSiM.Util
import Unique
import UniqSupply
registerComponent ::
ComponentIface s
=> s
-> SimM ()
registerComponent cstate = SimM $ do
lift $ modify (\s -> s {componentMap = Map.insert (componentName cstate) (SC cstate) (componentMap s)})
createComponent ::
Maybe NodeId
-> Maybe ComponentId
-> String
-> SimM ComponentId
createComponent nodeId_maybe parentId_maybe cname = SimM $ do
curNodeId <- lift $ gets currentNode
let nId = fromMaybe curNodeId nodeId_maybe
pId <- lift $ gets currentComponent
let parentId = fromMaybe pId parentId_maybe
cId <- lift getUniqueM
(SC cstate) <- fmap (fromJust . Map.lookup cname) $ lift $ gets componentMap
cstateTV <- (lift . lift) $ newTVarIO cstate
statusTV <- (lift . lift) $ newTVarIO Idle
bufferTV <- (lift . lift) $ newTVarIO []
let emptyMeta = SimMetaData 0 0 0 Map.empty Map.empty
emptyMetaTV <- (lift . lift) $ newTVarIO emptyMeta
lift $ modifyNode nId (addComponent cId (CC cId statusTV cstateTV parentId bufferTV [] emptyMetaTV))
return cId
where
addComponent cId cc n@(Node {..}) =
n { nodeComponents = IntMap.insert (getKey cId) cc nodeComponents
, nodeComponentLookup = Map.insert cname cId nodeComponentLookup
, nodeComponentOrder = nodeComponentOrder ++ [cId]
}
invoke ::
Maybe ComponentId
-> ComponentId
-> Dynamic
-> SimM Dynamic
invoke senderMaybe recipient content = SimM $ do
nId <- lift $ componentNode recipient
mId <- lift $ gets currentComponent
let senderId = fromMaybe mId senderMaybe
senderNodeId <- lift $ componentNode senderId
lift $ modifyNodeM senderNodeId (incrSendCounter recipient senderId)
lift $ modifyNodeM nId (updateMsgBuffer recipient (ComponentMsg senderId content))
suspend (Request recipient return)
invokeNoWait ::
Maybe ComponentId
-> ComponentId
-> Dynamic
-> SimM ()
invokeNoWait senderMaybe recipient content = SimM $ do
nId <- lift $ componentNode recipient
mId <- lift $ gets currentComponent
let senderId = fromMaybe mId senderMaybe
senderNodeId <- lift $ componentNode senderId
lift $ modifyNodeM senderNodeId (incrSendCounter recipient senderId)
lift $ modifyNodeM nId (updateMsgBuffer recipient (ComponentMsg senderId content))
yield ::
ComponentIface s
=> s
-> SimM s
yield s = SimM $ suspend (Yield (return s))
getComponentId ::
SimM ComponentId
getComponentId = SimM $ lift $ gets currentComponent
getNodeId ::
SimM NodeId
getNodeId = SimM $ lift $ gets currentNode
createNode ::
SimM NodeId
createNode = SimM $ do
nodeId <- lift getUniqueM
let newNode = Node nodeId NodeInfo Map.empty IntMap.empty IntMap.empty []
lift $ modify (\s -> s {nodes = IntMap.insert (getKey nodeId) newNode (nodes s)})
return nodeId
writeMemory ::
Maybe NodeId
-> Int
-> Dynamic
-> SimM ()
writeMemory nodeId_maybe i val = SimM $ do
curNodeId <- lift $ gets currentNode
let nodeId = fromMaybe curNodeId nodeId_maybe
lift $ modifyNode nodeId writeVal
where
writeVal n@(Node {..}) = n { nodeMemory = IntMap.insert i val nodeMemory }
readMemory ::
Maybe NodeId
-> Int
-> SimM Dynamic
readMemory nodeId_maybe i = SimM $ do
curNodeId <- lift $ gets currentNode
let nodeId = getKey $ fromMaybe curNodeId nodeId_maybe
memVal <- fmap (IntMap.lookup i . nodeMemory . (IntMap.! nodeId)) $ lift $ gets nodes
case memVal of
Just val -> return val
Nothing -> error $ "Trying to read empty memory location: " ++ show i ++ " from Node: " ++ show (fromMaybe curNodeId nodeId_maybe)
componentCreator ::
SimM ComponentId
componentCreator = SimM $ do
nId <- fmap getKey $ lift $ gets currentNode
cId <- fmap getKey $ lift $ gets currentComponent
ns <- lift $ gets nodes
let ces = (nodeComponents (ns IntMap.! nId))
let ce = ces IntMap.! cId
let ceCreator = creator ce
return ceCreator
componentLookup ::
Maybe NodeId
-> ComponentName
-> SimM (Maybe ComponentId)
componentLookup nodeId_maybe cName = SimM $ do
curNodeId <- lift $ gets currentNode
let nId = getKey $ fromMaybe curNodeId nodeId_maybe
nsLookup <- fmap (nodeComponentLookup . (IntMap.! nId)) $ lift $ gets nodes
return $ Map.lookup cName nsLookup
runIO ::
IO a
-> SimM a
runIO = SimM . liftIO
traceMsg ::
String
-> SimM ()
traceMsg msg = SimM $ do
curNodeId <- lift $ gets currentNode
curCompId <- lift $ gets currentComponent
lift $ modifyNode curNodeId (updateTraceBuffer curCompId msg)