SoOSiM 0.1 → 0.2.0.0

raw patch · 11 files changed

+1211/−427 lines, 11 filesdep +concurrent-supplydep −ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: concurrent-supply

Dependencies removed: ghc

API changes (from Hackage documentation)

Files

• README.md +476/−0
• SoOSiM.cabal +15/−9
• examples/MemoryManager.hs +45/−0
• examples/MemoryManager/Types.hs +23/−0
• examples/MemoryManager/Util.hs +13/−0
• src/SoOSiM.hs +22/−10
• src/SoOSiM/SimMonad.hs +271/−122
• src/SoOSiM/Simulator.hs +104/−210
• src/SoOSiM/Simulator/Util.hs +105/−0
• src/SoOSiM/Types.hs +116/−68
• src/SoOSiM/Util.hs +21/−8

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ())

@@ -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

@@ -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)

@@ -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

@@ -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 <comp>' ---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

@@ -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)