diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,476 @@ +SoOSiM - Abstract Full System Simulator +======================================= + +Installation +------------ + +* Download the latest Haskell Platform from: http://hackage.haskell.org/platform/ +* Execute on the command-line: `cabal update` +* Execute on the command-line: `cabal install SoOSiM` + +Creating OS Components +---------------------- + +We jump straight into some code, by showing the description of the *Memory Manager* (http://www.soos-project.eu/wiki/index.php/Application_Cases#Memory_Manager) + +#### ./examples/MemoryManager.hs +```haskell +{-# LANGUAGE TypeFamilies #-} +module MemoryManager where + +import SoOSiM + +import MemoryManager.Types +import MemoryManager.Util + +memoryManager :: MemState -> Input MemCommand -> Sim MemState +memoryManager s (Message content retAddr) = do + case content of + (Register memorySource) -> do + yield $ s {addressLookup = memorySource:(addressLookup s)} + + (Read addr) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- readMemory addr + respond MemoryManager retAddr addrVal + yield s + Just remote -> do + response <- invoke MemoryManager remote content + respond MemoryManager retAddr response + yield s + + (Write addr val) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- writeMemory addr val + yield s + Just remote -> do + invokeAsync MemoryManager remote content ignore + yield s + +memoryManager s _ = yield s + +instance ComponentInterface MemoryManager where + type State MemoryManager = MemState + type Receive MemoryManager = MemCommand + type Send MemoryManager = Dynamic + initState _ = (MemState []) + componentName _ = "MemoryManager" + componentBehaviour _ = memoryManager +``` + +#### ./examples/MemoryManager/Types.hs +```haskell +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +module MemoryManager.Types where + +import SoOSiM + +data MemorySource + = MemorySource + { baseAddress :: Int + , scope :: Int + , sourceId :: Maybe ComponentId + } + + +data MemState = + MemState { addressLookup :: [MemorySource] + } + +data MemCommand = Register Int Int (Maybe ComponentId) + | Read Int + | forall a . Typeable a => Write Int a + deriving Typeable + +data MemoryManager = MemoryManager +``` + +#### ./examples/MemoryManager/Util.hs +```haskell +module MemoryManager.Util where + +import MemoryManager.Types + +checkAddress :: + [MemorySource] + -> Int + -> MemorySource +checkAddress sources addr = case (filter containsAddr sources) of + [] -> error ("address unknown: " ++ show addr) + (x:_) -> x + where + containsAddr (MemorySource base sc _) = base <= addr && addr < sc +``` + +### Component definition Step-by-Step +We will now walk through the code step-by-step: + +```haskell +module MemoryManager where +``` + +We start by defining the name of our Haskell module, in this case `MemoryManager`. +Make sure the name of file matches the name of the module, where haskell src files use the `.hs` file-name extension. + +We continue with importing modules that we require to build our component: + +```haskell +import SoOSiM + +import MemoryManager.Types +import MemoryManager.Util +``` + +The `SoOSiM` module defines all the simulator API functions. +Besides the *external* module, we also import two *local* module called `MemoryManager.Types` and `MemoryManager.Util`, which we define in `./MemoryManager/Types.hs` and `./MemoryManager/Util.hs` respectively. + +We start our description with a datatype definition describing the internal state of our memory manager component, and the datatype encoding the messages our memory manager will receive: + +```haskell +data MemorySource + = MemorySource + { baseAddress :: Int + , scope :: Int + , sourceId :: Maybe ComponentId + } + +data MemState = + MemState { addressLookup :: [MemorySource] + } + +data MemCommand = Register MemorySource + | Read Int + | forall a . Typeable a => Write Int a + deriving Typeable + +data MemoryManager = MemoryManager +``` + +We define two record datatypes [1]; and with three fields (`baseAddress`, `scope`, and `sourceId`) and another with one field (`addressLookup`). +The first record type defines an address range (`baseAddress` and `scope`) and an indication which memory manager is responsible for tht memory range. +The second record type, which has only one field, which defines a dynamically-sized list of `MemorySource` elements. + +The third datatype is an algebraic datatype defining the kind of messages that can be send to the memory manager: registering a memory range, reading, and writing. + +The fourth datatype is a singleton datatype, which will act as the label/name for the interface defining our memory manager. + +We now start defining the actual behaviour of our memory manager, starting with its type annotation: + +```haskell +memoryManager :: MemState -> Input MemCommand -> Sim MemState +``` + +The type definition tells us that the first argument has the type of our internal component state, and the second argument a value of type `Input a`, where the `a` is instantiate to the `MemCommand` datatype. +The possible values of the `Input a` type are enumerated in the *OS Component API* section. +The value of the result is of type `Sim MemState`. +This tells us two things: + +* The `memoryManager` function is executed within the `Sim` monad. +* The actual value that is returned is of type `MemState`. + +A *monad* is many wonderful things [2], way too much to explain here, so for the rest of this README we see it as an execution environment. +Only inside this execution environment will we have access to the SoOSiM API functions. + +Although we know the types of the arguments and the result of the function, we don't know their actual meaning. +The SoOSiM simulator will call your component behaviour, passing as the first argument its current internal state. +The second argument is an event that triggered the execution of your component: for example a message send to you by another component. +The result that you must ultimately return is the, potentially updated, internal state of your component. + +We now turn to the first line of the actual function definition: + +```haskell +memoryManager s (Message content retAddr) = do +``` + +Where `memoryManager` is the name of the function, `s` the first argument (of type `MemState`). +We pattern-match on the second argument, meaning this function definition clause only works for values whose constructor is `Message`. +By pattern matching we get access to the fields of the datatype, where we bind the names `content` and `retAddr` to the values of these fields. + +The `do` *keyword* after the `=` sign indicates that the function executes within a monadic environment, the `Sim` environment in our case. +The semantics in a monadic environment are different from those in a normal Haskell functions. +A monadic environment has a more imperative feel, in which your function definition interacts with the environment step-by-step, statement after statements. +This also gives rise to the scoping rules familiar to the imperative programmer: names cannot be used before they are declared. + +Next we define a nested `case`-statement that contains most of the actual behaviour of our memory manager component: + +```haskell +case content of + (Register memorySource) -> do + yield $ s {addressLookup = memorySource:(addressLookup s)} + + (Read addr) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- readMemory addr + respond MemoryManager retAddr addrVal + yield s + Just remote -> do + response <- invoke MemoryManager remote content + respond MemoryManager retAddr response + yield s + + (Write addr val) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- writeMemory addr val + yield s + Just remote -> do + invokeAsync MemoryManager remote content ignore + yield s +``` + +In the first alternative of our case-statement we handle a `Register` message, by updating our address lookup table with an additional memory source. +We `yield` to the simulator with our updated internal state. + +In the second alternative we handle a `Read` request. +The next line in our function definition, which checks which specific memory manager is responsible for the address, is: + +```haskell +let src = checkAddress (addressLookup s) addr +``` + +Haskell is white-space sensitive, so make sure that you have a good editor that does automatic indenting. +We use the `let` construct to bind the expression `checkAddress (addressLookup s) addr` to the name `src`. +We use these let-bindings to bind *pure* expressions to names, where *pure* means that the expression has no side-effects [3]. +We can now just use the name `src` instead of having to type `checkAddress (addressLookup s) addr` every time. +Don't worry about efficiency, the evaluation mechanics of Haskell will ensure that the actual expression is only calculated once, even when we use the `src` name multiple times. + +In the next case-statement we check if the current or a remote memory manager is responsible for handling the address. +In either alternative we must use the `do` keyword again because we will be executing multiple statements. +We will now finally use some of the API functions, the first we encounter is: + +```haskell +addrVal <- readMemory addr +``` + +The `readMemory` function accesses the simulator environment, retrieving the value of the memory location specified by `addr`. +We use the left-arrow `<-` to indicate that this is a side-effecting expression (we are accessing the simulator environment), and that `addrVal` is not bound to the expression itself, but the value belonging to the execution of this statement. + +After reading the memory, we send the value back to the module that initially requested the memory access. +We send the read value as a response to the return address (`retAddr`). +Having serviced the request, we use the `yield` function to give the (unaltered) internal state back to the simulation environment. + +If a remote memory manager is responsible for the address: + +```haskell +Just remote -> do + response <- invoke MemoryManager remote content + respond MemoryManager retAddr response + yield s +``` + +We then synchronously invoke the remote memory manager with the original read request, and forward the received response to the component making the original memory request. + +The third alternative, handling a write request, is analogous to handling a read request. + +In the situations which we didn't handle explicitly, such as receiving a `Tick`, we simply disregard the simulator event, and return our unaltered internal state to the simulator. + +#### ComponentInterface Instance +At the bottom of our `MemoryManager` module we see the following code: + +```haskell +instance ComponentInterface MemoryManager where + type State MemoryManager = MemState + type Receive MemoryManager = MemCommand + type Send MemoryManager = Dynamic + initState _ = (MemState []) + componentName _ = "MemoryManager" + componentBehaviour _ = memoryManager +``` + +Here we define a so-called type-class instance. +At this moment you do not need to know what a type-class is, just that you need to define this instance if you want your component to be able to be used by the SoOSiM simulator. + +We use our singleton datatype, `MemoryManager`, as the label/name for our ComponentInterface instance. +All (type-)functions in this interface receive the interface label as their first argument. +For the type-functions (such as `State s`) we must explicitly mention the label, for normal function we can just use the underscore (`_`) as a place holder. + +The instance must always contain the definitions for `State`, `Receive`, `Send`, `initState`, `componentName` and `componentBehaviour`. +The `State` indicates the datatype representing the internal state of a module. +The `Receive` indicates the datatype of messages that this component is expecting to receive. +The `Send` indicates the datatype of messages this component will send as responses to invocation. +The `initState` function returns a minimal internal state of your component. +The `componentName` is a function returning the globally unique name of your component. +Finally `componentBehaviour` is a function returning the behaviour of your component. +The behaviour of your component must always have the type: + +```haskell +(State iface) -> Input (Receive iface) -> Sim (State iface) +``` + +Where `State iface` is the datatype of your component's internal state, and `Receive iface` is the datetype of the type of messages the component handles. + +## SoOSiM API + +#### ComponentInterface Type Class +```haskell +-- | Type class that defines every OS component +class ComponentInterface s where + -- | Type of messages send by the component + type Send s + -- | Type of messages received by the component + type Receive s + -- | Type of internal state of the component + type State s + -- | The minimal internal state of your component + initState :: s -> State s + -- | A function returning the unique global name of your component + componentName :: s -> ComponentName + -- | The function defining the behaviour of your component + componentBehaviour :: s -> State s -> Input (Receive s) -> Sim (State s) +``` + +#### Simulator Events +```haskell +data Input a + = Message a ReturnAddress -- ^ A message send by another component: the + -- first field is the message content, the + -- second field is the address to send + -- responses to + | Tick -- ^ Event send every simulation round +``` + +#### Accessing the simulator +```haskell +-- | Create a new component +createComponent :: + (ComponentInterface iface, Typeable (Receive iface)) + => iface + -- ^ Component Interface + -> Sim ComponentId + -- ^ 'ComponentId' of the created component +``` + +```haskell +-- | Synchronously invoke another component +invoke :: + (ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface)) + => iface + -- ^ Interface type + -> ComponentId + -- ^ ComponentId of callee + -> Receive iface + -- ^ Argument + -> Sim (Send iface) + -- ^ Response from callee +``` + +```haskell +-- | Invoke another component, handle response asynchronously +invokeAsync :: + (ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface)) + => iface + -- ^ Interface type + -> ComponentId + -- ^ ComponentId of callee + -> Receive iface + -- ^ Argument + -> (Send iface -> Sim ()) + -- ^ Response Handler + -> Sim () + -- ^ Call returns immediately +``` + +```haskell +-- | Respond to an invocation +respond :: + (ComponentInterface iface, Typeable (Send iface)) + => iface + -- ^ Interface type + -> ReturnAddress + -- ^ Return address to send response to + -> (Send iface) + -- ^ Value to send as response + -> Sim () + -- ^ Call returns immediately +``` + +```haskell +-- | Yield internal state to the simulator scheduler +yield :: + a + -> Sim a +``` + +```haskell +-- | Get the component id of your component +getComponentId :: + Sim ComponentId +``` + +```haskell +-- | Get the node id of of the node your component is currently running on +getNodeId :: + SimM NodeId +``` + +```haskell +-- | Create a new node +createNode :: + Sim NodeId -- ^ NodeId of the created node +``` + +```haskell +-- | Write memory of local node +writeMemory :: + Typeable a + => Int + -- ^ Address to write + -> a + -- ^ Value to write + -> Sim () +``` + +```haskell +-- | Read memory of local node +readMemory :: + Int + -- ^ Address to read + -> Sim Dynamic +``` + +```haskell +-- | Return the component Id of the component that created the current +-- component +componentCreator :: + Sim ComponentId +``` + +```haskell +-- | Get the unique 'ComponentId' of a component implementing an interface +componentLookup :: + ComponentInterface iface + => iface + -- ^ Interface type of the component you are looking for + -> Sim (Maybe ComponentId) + -- ^ 'Just' 'ComponentID' if a component is found, 'Nothing' otherwise +``` + +#### Handling `Dynamic` Values + +```haskell +-- | Converts a 'Dynamic' object back into an ordinary Haskell value of the +-- correct type. +unmarshall :: + Typeable a + => Dynamic -- ^ The dynamically-typed object + -> a -- ^ Returns: the value of the first argument, if it has the + -- correct type, otherwise it gives an error. +``` + +References +---------- + +[1] Here is a chapter from a book that introduces the correspondence between Haskell types and C types: +http://book.realworldhaskell.org/read/defining-types-streamlining-functions.html + +[2] Some resources that discuss monads: http://book.realworldhaskell.org/read/monads.html and http://learnyouahaskell.com/a-fistful-of-monads + +[3] A more elaborate explanation of purity can be found here: http://learnyouahaskell.com/introduction#so-whats-haskell diff --git a/SoOSiM.cabal b/SoOSiM.cabal --- a/SoOSiM.cabal +++ b/SoOSiM.cabal @@ -1,5 +1,5 @@ Name: SoOSiM -Version: 0.1 +Version: 0.2.0.0 Synopsis: Abstract full system simulator Description: @@ -25,24 +25,30 @@ Cabal-version: >=1.6 +Extra-source-files: README.md + examples/MemoryManager.hs + examples/MemoryManager/Types.hs + examples/MemoryManager/Util.hs + Library HS-Source-Dirs: src Exposed-modules: SoOSiM, - SoOSiM.Simulator, SoOSiM.Types ghc-options: -Wall - Build-depends: base >= 4.3.1.0 && < 4.6, - containers >= 0.4.0.0 && < 0.5, - transformers >= 0.2.2.0 && < 2.3, - mtl >= 2.0.1.0 && < 2.1, - monad-coroutine >= 0.7.1 && < 0.8, - ghc >= 7.0.3 && < 7.5, - stm >= 2.3 && < 2.4 + Build-depends: base >= 4.3.1.0 && < 4.6, + concurrent-supply >= 0.1.1 && < 0.2, + containers >= 0.4.0.0 && < 0.5, + monad-coroutine >= 0.7.1 && < 0.8, + mtl >= 2.0.1.0 && < 2.1, + stm >= 2.3 && < 2.4, + transformers >= 0.2.2.0 && < 2.3 Other-modules: SoOSiM.SimMonad, + SoOSiM.Simulator, + SoOSiM.Simulator.Util, SoOSiM.Util source-repository head diff --git a/examples/MemoryManager.hs b/examples/MemoryManager.hs new file mode 100644 --- /dev/null +++ b/examples/MemoryManager.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeFamilies #-} +module MemoryManager where + +import SoOSiM + +import MemoryManager.Types +import MemoryManager.Util + +memoryManager :: MemState -> Input MemCommand -> Sim MemState +memoryManager s (Message content retAddr) = do + case content of + (Register memorySource) -> do + yield $ s {addressLookup = memorySource:(addressLookup s)} + + (Read addr) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- readMemory addr + respond MemoryManager retAddr addrVal + yield s + Just remote -> do + response <- invoke MemoryManager remote content + respond MemoryManager retAddr response + yield s + + (Write addr val) -> do + let src = checkAddress (addressLookup s) addr + case (sourceId src) of + Nothing -> do + addrVal <- writeMemory addr val + yield s + Just remote -> do + invokeAsync MemoryManager remote content ignore + yield s + +memoryManager s _ = yield s + +instance ComponentInterface MemoryManager where + type State MemoryManager = MemState + type Receive MemoryManager = MemCommand + type Send MemoryManager = Dynamic + initState _ = (MemState []) + componentName _ = "MemoryManager" + componentBehaviour _ = memoryManager diff --git a/examples/MemoryManager/Types.hs b/examples/MemoryManager/Types.hs new file mode 100644 --- /dev/null +++ b/examples/MemoryManager/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +module MemoryManager.Types where + +import SoOSiM + +data MemorySource + = MemorySource + { baseAddress :: Int + , scope :: Int + , sourceId :: Maybe ComponentId + } + +data MemState = + MemState { addressLookup :: [MemorySource] + } + +data MemCommand = Register MemorySource + | Read Int + | forall a . Typeable a => Write Int a + deriving Typeable + +data MemoryManager = MemoryManager diff --git a/examples/MemoryManager/Util.hs b/examples/MemoryManager/Util.hs new file mode 100644 --- /dev/null +++ b/examples/MemoryManager/Util.hs @@ -0,0 +1,13 @@ +module MemoryManager.Util where + +import MemoryManager.Types + +checkAddress :: + [MemorySource] + -> Int + -> MemorySource +checkAddress sources addr = case (filter containsAddr sources) of + [] -> error ("address unknown: " ++ show addr) + (x:_) -> x + where + containsAddr (MemorySource base sc _) = base <= addr && addr < sc diff --git a/src/SoOSiM.hs b/src/SoOSiM.hs --- a/src/SoOSiM.hs +++ b/src/SoOSiM.hs @@ -1,17 +1,29 @@ module SoOSiM - ( SimM + ( module SoOSiM.SimMonad + , Sim , ComponentId , NodeId - , ComponentIface (..) - , ComponentInput (..) - , module SoOSiM.SimMonad - , module Data.Dynamic - , module Unique + , ComponentInterface (..) + , Input (..) + , Typeable + , Dynamic + , ignore + , tick + , unmarshall + , returnAddress ) where -import Data.Dynamic -import Unique - -import SoOSiM.Types +import Data.Dynamic (Dynamic) +import Data.Typeable (Typeable) import SoOSiM.SimMonad +import SoOSiM.Simulator (tick) +import SoOSiM.Simulator.Util (returnAddress) +import SoOSiM.Types (ComponentId,ComponentInterface(..),Input(..) + ,NodeId,Sim) +import SoOSiM.Util (unmarshall) + +ignore :: + a + -> Sim () +ignore = const (return ()) diff --git a/src/SoOSiM/SimMonad.hs b/src/SoOSiM/SimMonad.hs --- a/src/SoOSiM/SimMonad.hs +++ b/src/SoOSiM/SimMonad.hs @@ -1,172 +1,321 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} 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 Control.Concurrent.STM (STM,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 +import SoOSiM.Simulator.Util import SoOSiM.Types import SoOSiM.Util -import Unique -import UniqSupply --- | Register a component interface with the simulator -registerComponent :: - ComponentIface s - => s - -> SimM () -registerComponent cstate = SimM $ do - lift $ modify (\s -> s {componentMap = Map.insert (componentName cstate) (SC cstate) (componentMap s)}) - -- | Create a new component createComponent :: - Maybe NodeId -- ^ Node to create component on, leave to 'Nothing' to create on current node - -> Maybe ComponentId -- ^ ComponentId to set as parent, set to 'Nothing' to use own ComponentId - -> String -- ^ Name of the registered component - -> SimM ComponentId -- ^ 'ComponentId' of the created component -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 + (ComponentInterface iface, Typeable (Receive iface)) + => iface + -- ^ Component Interface + -> Sim ComponentId + -- ^ 'ComponentId' of the created component +createComponent = createComponentNP Nothing Nothing - (SC cstate) <- fmap (fromJust . Map.lookup cname) $ lift $ gets componentMap - cstateTV <- (lift . lift) $ newTVarIO cstate +-- | Create a new component +createComponentN :: + (ComponentInterface iface, Typeable (Receive iface)) + => iface + -- ^ Component Interface + -> NodeId + -- Node to create component on + -> Sim ComponentId +createComponentN iface nId = createComponentNP (Just nId) Nothing iface - statusTV <- (lift . lift) $ newTVarIO Idle - bufferTV <- (lift . lift) $ newTVarIO [] +-- | Create a new component +createComponentNP :: + (ComponentInterface iface, Typeable (Receive iface)) + => Maybe NodeId + -- ^ Node to create component on, leave to 'Nothing' to create on current + -- node + -> Maybe ComponentId + -- ^ ComponentId to set as parent, set to 'Nothing' to use own ComponentId + -> iface + -- ^ Component Interface + -> Sim ComponentId + -- ^ 'ComponentId' of the created component +createComponentNP nodeIdM parentIdM iface = Sim $ do + nodeId <- fmap (`fromMaybe` nodeIdM) $ gets currentNode + parentId <- fmap (`fromMaybe` parentIdM) $ gets currentComponent + compId <- getUniqueM - let emptyMeta = SimMetaData 0 0 0 Map.empty Map.empty - emptyMetaTV <- (lift . lift) $ newTVarIO emptyMeta + statusTV <- (lift . lift) $ newTVar ReadyToRun + stateTV <- (lift . lift) $ newTVar (initState iface) + msgBufTV <- (lift . lift) $ newTVar [] + let meta = SimMetaData 0 0 0 Map.empty Map.empty + metaTV <- (lift . lift) $ newTVar meta - lift $ modifyNode nId (addComponent cId (CC cId statusTV cstateTV parentId bufferTV [] emptyMetaTV)) - return cId + let component = (CC iface compId parentId statusTV stateTV msgBufTV [] metaTV) + + lift $ modifyNode nodeId (addComponent compId component) + + return compId where - addComponent cId cc n@(Node {..}) = - n { nodeComponents = IntMap.insert (getKey cId) cc nodeComponents + cname = componentName iface + + addComponent cId comp n@(Node {..}) = + n { nodeComponents = IM.insert cId comp nodeComponents , nodeComponentLookup = Map.insert cname cId nodeComponentLookup - , nodeComponentOrder = nodeComponentOrder ++ [cId] } -- | Synchronously invoke another component invoke :: - Maybe ComponentId -- ^ Caller, leave 'Nothing' to set to current module - -> ComponentId -- ^ Callee - -> Dynamic -- ^ Argument - -> SimM Dynamic -- ^ Response from recipient -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)) + (ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface)) + => iface + -- ^ Interface type + -> ComponentId + -- ^ ComponentId of callee + -> Receive iface + -- ^ Argument + -> Sim (Send iface) + -- ^ Response from callee +invoke iface recipient content = invokeS iface Nothing recipient content + +-- | Synchronously invoke another component +invokeS :: + forall iface + . (ComponentInterface iface + , Typeable (Receive iface) + , Typeable (Send iface)) + => iface + -- ^ Interface type + -> Maybe ComponentId + -- ^ Caller, leave 'Nothing' to set to current module + -> ComponentId + -- ^ Callee + -> Receive iface + -- ^ Argument + -> Sim (Send iface) + -- ^ Response from recipient +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 --- | Invoke another component, don't wait for a response -invokeNoWait :: - Maybe ComponentId -- ^ Caller, leave 'Nothing' to set to current module - -> ComponentId -- ^ Callee - -> Dynamic -- ^ Argument - -> SimM () -- ^ Call returns immediately -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)) +-- | Invoke another component, handle response asynchronously +invokeAsync :: + (ComponentInterface iface, Typeable (Receive iface), Typeable (Send iface)) + => iface + -- ^ Interface type + -> ComponentId + -- ^ ComponentId of callee + -> Receive iface + -- ^ Argument + -> (Send iface -> Sim ()) + -- ^ Response Handler + -> Sim () + -- ^ Call returns immediately +invokeAsync iface recipient content handler = + invokeAsyncS iface Nothing recipient content handler --- | Yield to the simulator scheduler +-- | Invoke another component, handle response asynchronously +invokeAsyncS :: + forall iface + . (ComponentInterface iface + , Typeable (Receive iface) + , Typeable (Send iface)) + => iface + -- ^ Interface type + -> Maybe ComponentId + -- ^ Caller, leave 'Nothing' to set to current module + -> ComponentId + -- ^ Callee + -> (Receive iface) + -- ^ Argument + -> (Send iface -> Sim ()) + -- ^ Handler + -> Sim () + -- ^ Call returns immediately +invokeAsyncS _ 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) + +-- | Respond to an invocation +respond :: + (ComponentInterface iface, Typeable (Send iface)) + => iface + -- ^ Interface type + -> ReturnAddress + -- ^ Return address to send response to + -> (Send iface) + -- ^ Value to send as response + -> Sim () + -- ^ Call returns immediately +respond iface retAddr content = respondS iface Nothing retAddr content + +-- | Respond to an invocation +respondS :: + forall iface + . ( ComponentInterface iface + , Typeable (Send iface)) + => iface + -- ^ Interface type + -> Maybe ComponentId + -- ^ Callee Id, leave 'Nothing' to set to current module + -> ReturnAddress + -- ^ Return address + -> (Send iface) + -- ^ Value to send as response + -> Sim () + -- ^ Call returns immediately +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 internal state to the simulator scheduler yield :: - ComponentIface s - => s - -> SimM s -yield s = SimM $ suspend (Yield (return s)) + a + -> Sim a +yield s = Sim $ suspend (Yield (return s)) -- | Get the component id of your component getComponentId :: - SimM ComponentId -getComponentId = SimM $ lift $ gets currentComponent + Sim ComponentId +getComponentId = Sim $ gets currentComponent -- | Get the node id of of the node your component is currently running on getNodeId :: - SimM NodeId -getNodeId = SimM $ lift $ gets currentNode + Sim NodeId +getNodeId = Sim $ gets currentNode -- | Create a new node createNode :: - SimM NodeId -- ^ NodeId of the created node -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)}) + Sim NodeId -- ^ NodeId of the created node +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 -- | Write memory of local node writeMemory :: - Maybe NodeId -- ^ Node you want to write on, leave 'Nothing' to set to current node - -> Int -- ^ Address to write - -> Dynamic -- ^ Value to write - -> SimM () -writeMemory nodeId_maybe i val = SimM $ do - curNodeId <- lift $ gets currentNode - let nodeId = fromMaybe curNodeId nodeId_maybe - lift $ modifyNode nodeId writeVal + Typeable a + => Int + -- ^ Address to write + -> a + -- ^ Value to write + -> Sim () +writeMemory = writeMemoryN Nothing + +-- | Write memory of local node +writeMemoryN :: + Typeable a + => Maybe NodeId + -- ^ Node you want to write on, leave 'Nothing' to set to current node + -> Int + -- ^ Address to write + -> a + -- ^ Value to write + -> Sim () +writeMemoryN nodeM addr val = Sim $ do + node <- fmap (`fromMaybe` nodeM) $ gets currentNode + lift $ modifyNode node writeVal where - writeVal n@(Node {..}) = n { nodeMemory = IntMap.insert i val nodeMemory } + writeVal n@(Node {..}) = n { nodeMemory = IM.insert addr (toDyn val) + nodeMemory } -- | Read memory of local node readMemory :: - Maybe NodeId -- ^ Node you want to look on, leave 'Nothing' to set to current node - -> Int -- ^ Address to read - -> 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 + Int + -- ^ Address to read + -> Sim Dynamic +readMemory = readMemoryN Nothing + +-- | Read memory of local node +readMemoryN :: + Maybe NodeId + -- ^ Node you want to look on, leave 'Nothing' to set to current node + -> Int + -- ^ Address to read + -> 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 i ++ " from Node: " ++ show (fromMaybe curNodeId nodeId_maybe) + Nothing -> error $ "Trying to read empty memory location: " ++ + show addr ++ " from Node: " ++ show node --- | Return the 'ComponentId' of the component that created the current component +-- | Return the 'ComponentId' of the component that created the current +-- component 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 + 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 --- | Get the unique 'ComponentId' of a certain component +-- | Get the unique 'ComponentId' of a component implementing an interface componentLookup :: - Maybe NodeId -- ^ Node you want to look on, leave 'Nothing' to set to current node - -> ComponentName -- ^ Name of the component you are looking for - -> SimM (Maybe ComponentId) -- ^ 'Just' 'ComponentID' if the component is found, 'Nothing' otherwise -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 + ComponentInterface iface + => iface + -- ^ Interface type of the component you are looking for + -> Sim (Maybe ComponentId) + -- ^ 'Just' 'ComponentID' if a component is found, 'Nothing' otherwise +componentLookup = componentLookupN Nothing -runIO :: - IO a - -> SimM a -runIO = SimM . liftIO +-- | Get the unique 'ComponentId' of a component implementing an interface +componentLookupN :: + ComponentInterface iface + => Maybe NodeId + -- ^ Node you want to look on, leave 'Nothing' to set to current node + -> iface + -- ^ Interface type of the component you are looking for + -> Sim (Maybe ComponentId) + -- ^ 'Just' 'ComponentID' if a component is found, 'Nothing' otherwise +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 - -> SimM () -traceMsg msg = SimM $ do - curNodeId <- lift $ gets currentNode - curCompId <- lift $ gets currentComponent - lift $ modifyNode curNodeId (updateTraceBuffer curCompId msg) + -> 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 diff --git a/src/SoOSiM/Simulator.hs b/src/SoOSiM/Simulator.hs --- a/src/SoOSiM/Simulator.hs +++ b/src/SoOSiM/Simulator.hs @@ -1,190 +1,26 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE Rank2Types #-} -module SoOSiM.Simulator - ( modifyNode - , modifyNodeM - , incrSendCounter - , componentNode - , updateMsgBuffer - , updateTraceBuffer - , execStep - , execStepSmall - ) -where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +module SoOSiM.Simulator where -import Control.Concurrent.STM -import Control.Monad.Coroutine -import Control.Monad.State -import Control.Monad.Trans.Class () -import Data.IntMap as IM -import Data.Map as Map -import qualified Data.Traversable as T -import Unique +import Control.Applicative ((<$>),(<*>)) +import Control.Concurrent.STM (TVar,atomically,readTVar,writeTVar) +import Control.Monad.Coroutine (resume) +import Control.Monad.State (execStateT,gets,lift,modify) +import Data.Dynamic (Dynamic,Typeable) +import qualified Data.Traversable as T +import SoOSiM.Simulator.Util import SoOSiM.Types -modifyNode :: - NodeId -- ^ ID of the node you want to update - -> (Node -> Node) -- ^ Update function - -> SimMonad () -modifyNode i f = - modify (\s -> s {nodes = IM.adjust f (getKey i) (nodes s)}) - -modifyNodeM :: - NodeId -- ^ ID of the node you want to update - -> (Node -> SimMonad ()) -- ^ Update function - -> SimMonad () -modifyNodeM i f = do - ns <- gets nodes - f $ ns IM.! (getKey i) - -componentNode :: - ComponentId - -> SimMonad NodeId -componentNode cId = do - let key = getKey cId - ns <- gets nodes - let (node:_) = IM.elems $ IM.filter (\n -> IM.member key (nodeComponents n)) ns - return (nodeId node) - -updateMsgBuffer :: - ComponentId -- ^ Recipient component ID - -> ComponentInput -- ^ Actual message - -> Node -- ^ Node containing the component - -> SimMonad () -updateMsgBuffer recipientId msg@(ComponentMsg senderId _) node = do - let ce = (nodeComponents node) IM.! (getKey recipientId) - lift $ atomically $ modifyTVar (msgBuffer ce) (\msgs -> msgs ++ [msg]) - lift $ atomically $ modifyTVar (simMetaData ce) (\mData -> mData {msgsReceived = Map.insertWith (+) senderId 1 (msgsReceived mData)}) - -updateMsgBuffer recipientId msg node = do - let ce = (nodeComponents node) IM.! (getKey recipientId) - lift $ atomically $ modifyTVar (msgBuffer ce) (\msgs -> msgs ++ [msg]) - -incrSendCounter :: - ComponentId -- RecipientID - -> ComponentId -- SenderId - -> Node -- Node containing the sender - -> SimMonad () -incrSendCounter recipientId senderId node = do - let ce = (nodeComponents node) IM.! (getKey senderId) - lift $ atomically $ modifyTVar (simMetaData ce) (\mData -> mData {msgsSend = Map.insertWith (+) recipientId 1 (msgsSend mData)}) - -updateTraceBuffer :: - ComponentId - -> String - -> Node - -> Node -updateTraceBuffer componentId msg node = - node { nodeComponents = f (nodeComponents node)} +tick :: SimState -> IO SimState +tick = atomically . execStateT tick' where - f ccs = IM.adjust g (getKey componentId) ccs - g cc = cc { traceMsgs = msg:(traceMsgs cc)} - --- | Update component context according to simulator event -handleComponent :: - ComponentIface s - => TVar SimMetaData - -> ComponentStatus s -- ^ Current component context - -> s - -> ComponentInput -- ^ Simulator event - -> SimMonad (ComponentStatus s, s, Maybe ComponentInput) -- ^ Returns tuple of: ((potentially updated) component context, 'Nothing' when event is consumed; 'Just' 'ComponentInput' otherwise) - --- If a component receives the message from the sender it was waiting for -handleComponent mDataTV (WaitingForMsg waitingFor f) cstate (ComponentMsg sender content) - | waitingFor == sender - = do - incrRunningCount mDataTV - -- Run the resumable computation with the message content - res <- resume $ runSimM (f content) - case res of - -- Computation is finished, return to idle state - Right a -> return (Running, a, Nothing) - -- Computation is waiting for a message, store the resumable computation - Left (Request o c) -> return (WaitingForMsg o (SimM . c), cstate, Nothing) - Left (Yield c) -> do - res' <- resume c - case res' of - Right a -> return (Idle, a, Nothing) - Left _ -> error "yield did not return state!" - --- Don't change the execution context if we're not getting the message we're waiting for -handleComponent mDataTV st@(WaitingForMsg _ _) s msg - = incrWaitingCount mDataTV >> return (st, s, Just msg) - --- Not in an waiting state, just handle the message -handleComponent mDataTV _ cstate msg = do - incrRunningCount mDataTV - res <- resume $ runSimM (componentBehaviour cstate msg) - case res of - -- Computation is finished, return to idle state - Right a -> return (Running, a, Nothing) - -- Computation is waiting for a message, store the resumable computation - Left (Request o c) -> return (WaitingForMsg o (SimM . c), cstate, Nothing) - Left (Yield c) -> do - res' <- resume c - case res' of - Right a -> return (Idle, a, Nothing) - Left _ -> error "yield did not return state!" - -executeComponent :: - ComponentContext - -> SimMonad () -executeComponent (CC cId statusTvar cstateTvar _ bufferTvar _ mDataTV) = do - modify $ (\s -> s {currentComponent = cId}) - status <- lift $ readTVarIO statusTvar - cstate <- lift $ readTVarIO cstateTvar - buffer <- lift $ readTVarIO bufferTvar - - (status',cstate',buffer') <- case (status,buffer) of - (Running, []) -> do - incrRunningCount mDataTV - res <- resume $ runSimM (componentBehaviour cstate Tick) - case res of - Right a -> return (Running, a, []) - Left (Request o c) -> return (WaitingForMsg o (SimM . c), cstate, []) - Left (Yield c) -> do - res' <- resume c - case res' of - Right a -> return (Idle, a, []) - Left _ -> error "yield did not return state!" - (Idle, []) - -> do - incrIdleCount mDataTV - return (status,cstate,buffer) - (WaitingForMsg _ _, []) - -> do - incrWaitingCount mDataTV - return (status,cstate,buffer) - _ -> mapUntilNothingM (handleComponent mDataTV) status cstate buffer - - lift $ atomically $ writeTVar statusTvar status' - lift $ atomically $ writeTVar cstateTvar cstate' - lift $ atomically $ writeTVar bufferTvar buffer' - -incrIdleCount, incrWaitingCount, incrRunningCount :: - TVar SimMetaData - -> SimMonad () -incrIdleCount tv = lift $ atomically $ modifyTVar tv (\mdata -> mdata {cyclesIdling = cyclesIdling mdata + 1}) -incrWaitingCount tv = lift $ atomically $ modifyTVar tv (\mdata -> mdata {cyclesWaiting = cyclesWaiting mdata + 1}) -incrRunningCount tv = lift $ atomically $ modifyTVar tv (\mdata -> mdata {cyclesRunning = cyclesRunning mdata + 1}) - -mapUntilNothingM :: - ComponentIface s - => (ComponentStatus s -> s -> ComponentInput -> SimMonad (ComponentStatus s, s, Maybe ComponentInput)) - -> ComponentStatus s - -> s - -> [ComponentInput] - -> SimMonad (ComponentStatus s, s, [ComponentInput]) -mapUntilNothingM _ st s [] = return (st,s,[]) -mapUntilNothingM f st s (inp:inps) = do - (st', s', inp_maybe) <- f st s inp - case inp_maybe of - Nothing -> return (st',s',inps) - Just _ -> do - (st'',s'',inps') <- mapUntilNothingM f st s inps - return (st'',s'',inp:inps') + tick' :: SimMonad () + tick' = do + ns <- gets nodes + _ <- T.mapM executeNode ns + return () executeNode :: Node @@ -194,37 +30,95 @@ _ <- T.mapM executeComponent (nodeComponents node) return () -executeNodeSmall :: - Node +executeComponent :: + ComponentContext -> SimMonad () -executeNodeSmall node = do - modify $ (\s -> s {currentNode = nodeId node}) - --_ <- T.mapM executeComponent (nodeComponents node) - --return () - case (nodeComponentOrder node) of - [] -> return () - (c:_) -> do - executeComponent ((nodeComponents node) IM.! (getKey c)) - modifyNode (nodeId node) (\n -> n {nodeComponentOrder = rotate (nodeComponentOrder n)}) - where - rotate [] = [] - rotate (x:xs) = xs ++ [x] +executeComponent (CC token cId _ statusTV stateTV bufferTV _ metaTV) = do + modify $ (\s -> s {currentComponent = cId }) + (status,state,buffer) <- lift $ (,,) <$> readTVar statusTV + <*> readTVar stateTV + <*> readTVar bufferTV -tick :: SimMonad () -tick = do - ns <- gets nodes - _ <- T.mapM executeNode ns - return () + ((status',state'),buffer') <- case (status,buffer) of + (ReadyToRun, []) -> do + incrRunningCount metaTV + r <- handleResult (componentBehaviour token state Tick) state + return (r,[]) + (ReadyToIdle, []) -> do + incrIdleCount metaTV + return ((status,state),buffer) + (WaitingFor _ _, []) -> do + incrWaitingCount metaTV + return ((status,state),buffer) + _ -> runUntilNothingM handleInput token metaTV status state buffer -tickSmall :: SimMonad () -tickSmall = do - ns <- gets nodes - _ <- T.mapM executeNodeSmall ns - return () + lift $ writeTVar statusTV status' >> + writeTVar stateTV state' >> + writeTVar bufferTV buffer' -execStep :: SimState -> IO SimState -execStep = execStateT tick +resumeYield :: + ComponentInterface iface + => SimInternal (State iface) + -> SimMonad (ComponentStatus iface, State iface) +resumeYield c = do + res <- resume c + case res of + (Right state') -> return (ReadyToIdle, state') + (Left _) -> error "yield did not return state" -execStepSmall :: SimState -> IO SimState -execStepSmall = execStateT tickSmall +handleResult :: + ComponentInterface iface + => Sim (State iface) + -> State iface + -> SimMonad (ComponentStatus iface, State iface) +handleResult f state = do + res <- resume $ runSim f + case res of + Right state' -> return (ReadyToRun , state') + Left (Request o c) -> return (WaitingFor o (Sim . c), state) + Left (Yield c) -> resumeYield c +runUntilNothingM :: + Monad m + => (a -> b -> c -> d -> e -> m ((c,d),Maybe e)) + -> a -> b -> c -> d -> [e] + -> m ((c,d),[e]) +runUntilNothingM _ _ _ st s [] = return ((st, s), []) +runUntilNothingM f iface mTV st s (inp:inps) = do + (r, inpM) <- f iface mTV st s inp + case inpM of + Nothing -> return (r,inps) + Just _ -> do + (r',inps') <- runUntilNothingM f iface mTV st s inps + return (r',inp:inps') + +-- | Update component context according to simulator event +handleInput :: + (ComponentInterface iface, Typeable (Receive iface)) + => iface + -> TVar SimMetaData + -> ComponentStatus iface + -- ^ Current component context + -> State iface + -> Input Dynamic + -- ^ Simulator Event + -> SimMonad ((ComponentStatus iface, State iface), Maybe (Input Dynamic)) + -- ^ Returns tuple of: ((potentially updated) component context, + -- (potentially update) component state, 'Nothing' when event is consumed; + -- 'Just' 'ComponentInput' otherwise) +handleInput _ metaTV st@(WaitingFor waitingFor f) state + msg@(Message _ (RA (sender,_))) + | waitingFor == sender + = do + incrRunningCount metaTV + r <- handleResult (f ()) state + return (r,Nothing) + | otherwise + = incrWaitingCount metaTV >> return ((st, state), Just msg) + +handleInput iface metaTV _ state msg = do + incrRunningCount metaTV + r <- handleResult + (componentBehaviour iface state (fromDynMsg iface msg)) + state + return (r,Nothing) diff --git a/src/SoOSiM/Simulator/Util.hs b/src/SoOSiM/Simulator/Util.hs new file mode 100644 --- /dev/null +++ b/src/SoOSiM/Simulator/Util.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleContexts #-} +module SoOSiM.Simulator.Util where + +import Control.Concurrent.STM (TVar,modifyTVar) +import Control.Monad.State (gets,lift,modify) +import Data.Dynamic (Dynamic,Typeable) +import qualified Data.IntMap as IM +import qualified Data.Map as Map + +import SoOSiM.Types +import SoOSiM.Util + +modifyNode :: + NodeId + -- ^ ID of the node you want to update + -> (Node -> Node) + -- ^ Update function + -> SimMonad () +modifyNode i f = + modify (\s -> s {nodes = IM.adjust f i (nodes s)}) + +modifyNodeM :: + NodeId + -- ^ ID of the node you want to update + -> (Node -> SimMonad ()) + -- ^ Update function + -> SimMonad () +modifyNodeM i f = do + ns <- gets nodes + f $ ns IM.! i + +componentNode :: + ComponentId + -> SimMonad NodeId +componentNode cId = do + ns <- gets nodes + let (node:_) = IM.elems $ IM.filter (\n -> IM.member cId (nodeComponents n)) ns + return (nodeId node) + +updateMsgBuffer :: + ComponentId + -- ^ Recipient component ID + -> Input Dynamic + -- ^ Actual message + -> Node + -- ^ Node containing the component + -> SimMonad () +updateMsgBuffer recipient msg@(Message _ (RA (sender,_))) node = do + let ce = (nodeComponents node) IM.! recipient + lift $ modifyTVar (msgBuffer ce) (\msgs -> msgs ++ [msg]) + lift $ modifyTVar (simMetaData ce) + (\mData -> mData {msgsReceived = Map.insertWith (+) sender 1 + (msgsReceived mData)}) + +updateMsgBuffer _ _ _ = return () + +incrSendCounter :: + ComponentId + -- ^ RecipientID + -> ComponentId + -- ^ SenderId + -> Node + -- ^ Node containing the sender + -> SimMonad () +incrSendCounter recipient sender node = do + let ce = (nodeComponents node) IM.! sender + lift $ modifyTVar (simMetaData ce) + (\mData -> mData {msgsSend = Map.insertWith (+) recipient 1 + (msgsSend mData)}) + +updateTraceBuffer :: + ComponentId + -> String + -> Node + -> Node +updateTraceBuffer cmpId msg node = + node { nodeComponents = f (nodeComponents node)} + where + f ccs = IM.adjust g cmpId ccs + g cc = cc { traceMsgs = msg:(traceMsgs cc)} + +incrIdleCount, incrWaitingCount, incrRunningCount :: + TVar SimMetaData + -> SimMonad () +incrIdleCount tv = lift $ modifyTVar tv (\mdata -> mdata + {cyclesIdling = cyclesIdling mdata + 1}) +incrWaitingCount tv = lift $ modifyTVar tv (\mdata -> mdata + {cyclesWaiting = cyclesWaiting mdata + 1}) +incrRunningCount tv = lift $ modifyTVar tv (\mdata -> mdata + {cyclesRunning = cyclesRunning mdata + 1}) + + +fromDynMsg :: + (ComponentInterface i, Typeable (Receive i)) + => i + -> Input Dynamic + -> Input (Receive i) +fromDynMsg _ (Message content retChan) = + Message (unmarshall "fromDynMsg" content) retChan +fromDynMsg _ Tick = Tick + +returnAddress :: + ReturnAddress + -> ComponentId +returnAddress = fst . unRA diff --git a/src/SoOSiM/Types.hs b/src/SoOSiM/Types.hs --- a/src/SoOSiM/Types.hs +++ b/src/SoOSiM/Types.hs @@ -1,49 +1,66 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} module SoOSiM.Types where -import Control.Concurrent.STM -import Control.Monad.Coroutine -import Control.Monad.State -import Control.Monad.Trans.Class () -import Data.Dynamic -import Data.IntMap -import Data.Map -import Unique -import UniqSupply +import Control.Concurrent.STM (STM,TVar) +import Control.Concurrent.Supply (Supply,freshId) +import Control.Monad.Coroutine (Coroutine) +import qualified Control.Monad.State as State +import Control.Monad.State (lift,get,put) +import Data.Dynamic (Dynamic,Typeable) +import Data.IntMap (IntMap) +import Data.Map (Map) +import SoOSiM.Util (MonadUnique(..)) + +type Unique = Int type ComponentId = Unique type ComponentName = String -deriving instance Typeable Unique - -- | Type class that defines every OS component -class ComponentIface s where +class ComponentInterface s where + -- | Type of messages send by the component + type Send s + -- | Type of messages received by the component + type Receive s + -- | Type of internal state of the component + type State s -- | The minimal internal state of your component - initState :: s + initState :: s -> State s -- | A function returning the unique global name of your component componentName :: s -> ComponentName -- | The function defining the behaviour of your component - componentBehaviour :: s -> ComponentInput -> SimM s + componentBehaviour :: s -> State s -> Input (Receive s) -> Sim (State s) -- | Context of a running component in the simulator. -- --- We need rank-2 types because we need to make a single collection +-- We need existential types because we need to make a single collection -- of several component contexts, each having their own type representing -- their internal state. -data ComponentContext = forall s . ComponentIface s => - CC { componentId :: ComponentId - , currentStatus :: TVar (ComponentStatus s) -- ^ Status of the component - , componentState :: TVar s -- ^ State internal to the component - , creator :: ComponentId -- ^ 'ComponentId' of the component that created this component - , msgBuffer :: TVar [ComponentInput] -- ^ Message waiting to be processed by the component - , traceMsgs :: [String] -- ^ Trace message buffer - , simMetaData :: TVar SimMetaData -- ^ Statistical information regarding a component +data ComponentContext = forall s . (ComponentInterface s, Typeable (Receive s)) => + CC { componentIface :: s + -- ^ Interface type + , componentId :: ComponentId + -- ^ 'ComponentId' of this component + , creator :: ComponentId + -- ^ 'ComponentId' of the component that created this component + , currentStatus :: TVar (ComponentStatus s) + -- ^ Status of the component + , componentState :: TVar (State s) + -- ^ State internal to the component + , msgBuffer :: TVar [Input Dynamic] + -- ^ Message waiting to be processed by the component + , traceMsgs :: [String] + -- ^ Trace message buffer + , simMetaData :: TVar SimMetaData + -- ^ Statistical information regarding a component } data SimMetaData @@ -51,42 +68,62 @@ { cyclesRunning :: Int , cyclesWaiting :: Int , cyclesIdling :: Int - , msgsReceived :: Map ComponentId Int -- ^ Key: senderId; Value: number of messages - , msgsSend :: Map ComponentId Int -- ^ Key: receiverId: Value: number of messages + , msgsReceived :: Map ComponentId Int + -- ^ Key: senderId; Value: number of messages + , msgsSend :: Map ComponentId Int + -- ^ Key: receiverId: Value: number of messages } -- | Status of a running component data ComponentStatus a - = Idle -- ^ Component is doing nothing - | WaitingForMsg ComponentId (Dynamic -> SimM a) -- ^ Component is waiting for a message from 'ComponentId', will continue with computation ('Dynamic' -> 'SimM' a) once received - | Running -- ^ Component is busy doing computations + = ReadyToIdle + -- ^ Component is doing nothing + | WaitingFor ComponentId (() -> Sim (State a)) + -- ^ Component is waiting for a message from 'ComponentId', will continue + -- with computation ('(' -> 'SimM' a) once received + | ReadyToRun + -- ^ Component is busy doing computations -- | Events send to components by the simulator -data ComponentInput = ComponentMsg ComponentId Dynamic -- ^ A message send another component: the field argument is the 'ComponentId' of the sender, the second field the message content - | NodeMsg NodeId Dynamic -- ^ A message send by a node: the first field is the 'NodeId' of the sending node, the second field the message content - | Initialize -- ^ Event send when a component is first created - | Deinitialize -- ^ Event send when a component is about to be removed - | Tick -- ^ Event send every simulation round - deriving Show +data Input a + = Message a ReturnAddress + -- ^ A message send another component: the field argument is the + -- 'ComponentId' of the sender, the second field the message content + | Tick + -- ^ Event send every simulation round +newtype ReturnAddress = RA { unRA :: (ComponentId, TVar Dynamic) } + +instance Show (Input a) where + show (Message _ (RA (sender,_))) = "Mesage from: " ++ show sender + show Tick = "Tick" + type NodeId = Unique --- | Meta-data describing the functionaly of the computing node, currently just a singleton type. +-- | Meta-data describing the functionaly of the computing node, currently +-- just a singleton type. data NodeInfo = NodeInfo -- | Nodes represent computing entities in the simulator, -- and host the OS components and application threads -data Node = - Node { nodeId :: NodeId -- ^ Globally Unique ID of the node - , nodeInfo :: NodeInfo -- ^ Meta-data describing the node - , nodeComponentLookup :: Map ComponentName ComponentId -- ^ Lookup table of OS components running on the node, key: the 'ComponentName', value: unique 'ComponentId' - , nodeComponents :: IntMap ComponentContext -- ^ Map of component contexts, key is the 'ComponentId' - , nodeMemory :: IntMap Dynamic -- ^ Node-local memory - , nodeComponentOrder :: [ComponentId] - } +data Node + = Node + { nodeId :: NodeId + -- ^ Globally Unique ID of the node + , nodeInfo :: NodeInfo + -- ^ Meta-data describing the node + , nodeComponentLookup :: Map ComponentName ComponentId + -- ^ Lookup table of OS components running on the node, key: the + -- 'ComponentName', value: unique 'ComponentId' + , nodeComponents :: IntMap ComponentContext + -- ^ Map of component contexts, key is the 'ComponentId' + , nodeMemory :: IntMap Dynamic + -- ^ Node-local memory + , nodeComponentOrder :: [ComponentId] + } --- The simulator monad used by the OS components offers resumable computations --- in the form of coroutines. These resumable computations expect a value of --- type 'Dynamic', and return a value of type 'a'. +-- | The simulator monad used by the OS components offers resumable +-- computations in the form of coroutines. These resumable computations +-- expect a value of type 'Dynamic', and return a value of type 'a'. -- -- We need resumable computations to simulate synchronous messaging between -- two components. When a component synchronously sends a message to another @@ -101,9 +138,18 @@ -- message from. The execute a resumeable computation you simply do: -- 'resume ' -- -newtype SimM a = SimM { runSimM :: Coroutine (RequestOrYield Unique Dynamic) SimMonad a } - deriving (Functor, Monad) +newtype Sim a = Sim { runSim :: SimInternal a } + deriving (Functor, Monad, State.MonadState SimState, MonadUnique) +type SimInternal = Coroutine (RequestOrYield Unique ()) SimMonad + +instance State.MonadState SimState SimInternal where + get = lift get + put x = lift (put x) + +instance MonadUnique SimInternal where + getUniqueM = lift getUniqueM + data RequestOrYield request response x = Request request (response -> x) | Yield x @@ -112,25 +158,27 @@ fmap f (Request x g) = Request x (f . g) fmap f (Yield y) = Yield (f y) --- | The internal monad of the simulator is currently a simple state-monad wrapping IO -type SimMonad = StateT SimState IO +-- | The internal monad of the simulator is currently a simple state-monad +-- wrapping STM +type SimMonad = State.StateT SimState STM -- | The internal simulator state -data SimState = - SimState { currentComponent :: ComponentId -- ^ The 'ComponentId' of the component currently under evaluation - , currentNode :: NodeId -- ^ The 'NodeId' of the node containing the component currently under evaluation - , nodes :: IntMap Node -- ^ The set of nodes comprising the entire system - , uniqueSupply :: UniqSupply -- ^ Unlimited supply of unique values - , componentMap :: Map String StateContainer - } - -data StateContainer = forall s . ComponentIface s => SC s +data SimState + = SimState + { currentComponent :: ComponentId + -- ^ The 'ComponentId' of the component currently under evaluation + , currentNode :: NodeId + -- ^ The 'NodeId' of the node containing the component currently under + -- evaluation + , nodes :: IntMap Node + -- ^ The set of nodes comprising the entire system + , uniqueSupply :: Supply + -- ^ Unlimited supply of unique values + } instance MonadUnique SimMonad where - getUniqueSupplyM = gets uniqueSupply - getUniqueM = do - supply <- gets uniqueSupply - let (supply'',supply') = splitUniqSupply supply - unique = uniqFromSupply supply'' - modify (\s -> s {uniqueSupply = supply'}) + getUniqueM = do + supply <- State.gets uniqueSupply + let (unique,supply') = freshId supply + State.modify (\s -> s {uniqueSupply = supply'}) return unique diff --git a/src/SoOSiM/Util.hs b/src/SoOSiM/Util.hs --- a/src/SoOSiM/Util.hs +++ b/src/SoOSiM/Util.hs @@ -1,13 +1,13 @@ -module SoOSiM.Util - ( module SoOSiM.Util - , module Data.Dynamic - ) -where +{-# LANGUAGE ScopedTypeVariables #-} +module SoOSiM.Util where -import Data.Dynamic -import Data.IntMap -import Data.Monoid +import Data.Dynamic (Typeable,Dynamic,fromDyn,toDyn) +import Data.IntMap (IntMap,Key,member,adjust,insert) +import Data.Monoid (Monoid (..)) +class MonadUnique m where + getUniqueM :: m Int + adjustForce :: Monoid a => (a -> a) -> Key -> IntMap a -> IntMap a adjustForce f k m = case (member k m) of True -> adjust f k m @@ -19,3 +19,16 @@ (a',y) <- f a x (a'',ys) <- mapAccumLM f a' xs return (a'',y:ys) + +unmarshall :: forall a . Typeable a => String -> Dynamic -> a +unmarshall msg d = fromDyn d + (error $ "unmarshal failed: expected value of type: " + ++ show resDyn + ++ ", received value of type: " + ++ show d + ++ "\nmessage:\n" + ++ msg + ) + where + resDyn :: Dynamic + resDyn = toDyn (undefined :: a)