module SoOSiM.SimMonad
(
createComponent
, invoke
, invokeAsync
, respond
, yield
, readMemory
, writeMemory
, componentLookup
, traceMsg
, createNode
, runSTM
, getComponentId
, getNodeId
, componentCreator
, createComponentN
, createComponentNP
, invokeS
, invokeAsyncS
, respondS
, readMemoryN
, writeMemoryN
)
where
import Control.Concurrent.STM (STM,TVar,newTVar,readTVar,writeTVar)
import Control.Monad.Coroutine (suspend)
import Control.Monad.State (gets,lift,modify)
import Data.Dynamic (Dynamic,Typeable,toDyn)
import qualified Data.IntMap as IM
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import SoOSiM.Simulator.Util
import SoOSiM.Types
import SoOSiM.Util
createComponent ::
(ComponentInterface iface, Typeable (Receive iface))
=> iface
-> Sim ComponentId
createComponent = createComponentNPS Nothing Nothing Nothing
createComponentN ::
(ComponentInterface iface, Typeable (Receive iface))
=> iface
-> NodeId
-> Sim ComponentId
createComponentN iface nId =
createComponentNPS (Just nId) Nothing Nothing iface
createComponentNP ::
(ComponentInterface iface, Typeable (Receive iface))
=> NodeId
-> ComponentId
-> iface
-> Sim ComponentId
createComponentNP nodeId parentId iface =
createComponentNPS (Just nodeId) (Just parentId) Nothing iface
createComponentNPS ::
(ComponentInterface iface, Typeable (Receive iface))
=> Maybe NodeId
-> Maybe ComponentId
-> Maybe (State iface)
-> iface
-> Sim ComponentId
createComponentNPS nodeIdM parentIdM iStateM iface = Sim $ do
nodeId <- fmap (`fromMaybe` nodeIdM) $ gets currentNode
parentId <- fmap (`fromMaybe` parentIdM) $ gets currentComponent
compId <- getUniqueM
statusTV <- (lift . lift) $ newTVar ReadyToRun
let iState = fromMaybe (initState iface) iStateM
stateTV <- (lift . lift) $ newTVar iState
msgBufTV <- (lift . lift) $ newTVar []
let meta = SimMetaData 0 0 0 Map.empty Map.empty
metaTV <- (lift . lift) $ newTVar meta
let component = (CC iface compId parentId statusTV stateTV msgBufTV [] metaTV)
lift $ modifyNode nodeId (addComponent compId component)
return compId
where
cname = componentName iface
addComponent cId comp n@(Node {..}) =
n { nodeComponents = IM.insert cId comp nodeComponents
, nodeComponentLookup = Map.insert cname cId nodeComponentLookup
}
invoke ::
(ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface))
=> iface
-> ComponentId
-> Receive iface
-> Sim (Send iface)
invoke iface recipient content = invokeS iface Nothing recipient content
invokeS ::
forall iface
. (ComponentInterface iface
, Typeable (Receive iface)
, Typeable (Send iface))
=> iface
-> Maybe ComponentId
-> ComponentId
-> Receive iface
-> Sim (Send iface)
invokeS _ senderM recipient content = Sim $ do
sender <- fmap (`fromMaybe` senderM) $ gets currentComponent
responseTV <- lift . lift . newTVar $ toDyn (undefined :: Send iface)
let response = RA (sender,responseTV)
let message = Message (toDyn content) response
rNodeId <- lift $ componentNode recipient
sNodeId <- lift $ componentNode sender
lift $ modifyNodeM rNodeId (updateMsgBuffer recipient message)
lift $ modifyNodeM sNodeId (incrSendCounter recipient sender)
suspend (Request recipient return)
fmap (unmarshall "invoke") . lift . lift $ readTVar responseTV
invokeAsync ::
(ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface))
=> iface
-> ComponentId
-> Receive iface
-> (Send iface -> Sim ())
-> Sim ()
invokeAsync iface recipient content handler =
invokeAsyncS iface Nothing recipient content handler
invokeAsyncS ::
forall iface
. (ComponentInterface iface
, Typeable (Receive iface)
, Typeable (Send iface))
=> iface
-> Maybe ComponentId
-> ComponentId
-> (Receive iface)
-> (Send iface -> Sim ())
-> Sim ()
invokeAsyncS _ parentIdM recipient content handler = Sim $ do
nodeId <- gets currentNode
responseTV <- lift . lift . newTVar $ toDyn (undefined :: Send iface)
parentId <- fmap (`fromMaybe` parentIdM) $ gets currentComponent
sender <- runSim $ createComponentNPS (Just nodeId) parentIdM
(Just (recipient,responseTV,handler . unmarshallAsync))
(HS parentId)
let response = RA (sender,responseTV)
let message = Message (toDyn content) response
rNodeId <- lift $ componentNode recipient
sNodeId <- lift $ componentNode sender
lift $ modifyNodeM rNodeId (updateMsgBuffer recipient message)
lift $ modifyNodeM sNodeId (incrSendCounter recipient sender)
where
unmarshallAsync :: Dynamic -> Send iface
unmarshallAsync = unmarshall "invokeAsyncS"
respond ::
(ComponentInterface iface, Typeable (Send iface))
=> iface
-> ReturnAddress
-> (Send iface)
-> Sim ()
respond iface retAddr content = respondS iface Nothing retAddr content
respondS ::
forall iface
. ( ComponentInterface iface
, Typeable (Send iface))
=> iface
-> Maybe ComponentId
-> ReturnAddress
-> (Send iface)
-> Sim ()
respondS _ senderM (RA (recipient,respTV)) content = Sim $ do
sender <- fmap (`fromMaybe` senderM) $ gets currentComponent
lift . lift $ writeTVar respTV (toDyn content)
let message = Message undefined (RA (sender,undefined))
rNodeId <- lift $ componentNode recipient
sNodeId <- lift $ componentNode sender
lift $ modifyNodeM rNodeId (updateMsgBuffer recipient message)
lift $ modifyNodeM sNodeId (incrSendCounter recipient sender)
yield ::
a
-> Sim a
yield s = Sim $ suspend (Yield (return s))
getComponentId ::
Sim ComponentId
getComponentId = Sim $ gets currentComponent
getNodeId ::
Sim NodeId
getNodeId = Sim $ gets currentNode
createNode ::
Sim NodeId
createNode = Sim $ do
nodeId <- getUniqueM
let newNode = Node nodeId NodeInfo Map.empty IM.empty IM.empty []
modify (\s -> s {nodes = IM.insert nodeId newNode (nodes s)})
return nodeId
writeMemory ::
Typeable a
=> Int
-> a
-> Sim ()
writeMemory = writeMemoryN Nothing
writeMemoryN ::
Typeable a
=> Maybe NodeId
-> Int
-> a
-> Sim ()
writeMemoryN nodeM addr val = Sim $ do
node <- fmap (`fromMaybe` nodeM) $ gets currentNode
lift $ modifyNode node writeVal
where
writeVal n@(Node {..}) = n { nodeMemory = IM.insert addr (toDyn val)
nodeMemory }
readMemory ::
Int
-> Sim Dynamic
readMemory = readMemoryN Nothing
readMemoryN ::
Maybe NodeId
-> Int
-> Sim Dynamic
readMemoryN nodeM addr = Sim $ do
node <- fmap (`fromMaybe` nodeM) $ gets currentNode
nodeMem <- fmap (nodeMemory . (IM.! node)) $ gets nodes
case (IM.lookup addr nodeMem) of
Just val -> return val
Nothing -> error $ "Trying to read empty memory location: " ++
show addr ++ " from Node: " ++ show node
componentCreator ::
Sim ComponentId
componentCreator = Sim $ do
nId <- gets currentNode
cId <- gets currentComponent
ns <- gets nodes
let ces = (nodeComponents (ns IM.! nId))
let ce = ces IM.! cId
let ceCreator = creator ce
return ceCreator
componentLookup ::
ComponentInterface iface
=> iface
-> Sim (Maybe ComponentId)
componentLookup = componentLookupN Nothing
componentLookupN ::
ComponentInterface iface
=> Maybe NodeId
-> iface
-> Sim (Maybe ComponentId)
componentLookupN nodeM iface = Sim $ do
node <- fmap (`fromMaybe` nodeM) $ gets currentNode
idCache <- fmap (nodeComponentLookup . (IM.! node)) $ lift $ gets nodes
return $ Map.lookup (componentName iface) idCache
traceMsg ::
String
-> Sim ()
traceMsg msg = Sim $ do
node <- gets currentNode
comp <- gets currentComponent
lift $ modifyNode node (updateTraceBuffer comp msg)
runSTM ::
STM a
-> Sim a
runSTM = Sim . lift . lift
data HandlerStub = HS ComponentId
instance ComponentInterface HandlerStub where
type State HandlerStub = (ComponentId, TVar Dynamic, Dynamic -> Sim ())
type Receive HandlerStub = ()
type Send HandlerStub = ()
initState _ = undefined
componentName (HS cId) = "Asynchronous callback for component " ++
show cId
componentBehaviour _ (waitingFor, tv, handler) _ = Sim $ do
suspend (Request waitingFor return)
var <- lift . lift $ readTVar tv
runSim $ handler var
suspend Kill