actor-0.1: Chain.hs

{-# LANGUAGE MultiParamTypeClasses, PatternSignatures, TypeSynonymInstances, FlexibleInstances  #-}

-- creating some n number of actors which pass around some message


module Main where

import IO
import Monad
import Data.IORef 
import Control.Concurrent
import System.Environment
import Data.Time

import Actor.ActorBase
import Actor.ActorSyntax
import Actor.ActorCompiler
import Actor.ActorLinearSearch

-- boilerplate

data Msg = Blah deriving (Eq,Show)

valhashOp = HashOp { numberOfTables = 1, hashMsg = \ _ -> 1 }

instance EMatch Msg where
  match tags m1 m2 = return (m1 == m2, tags)

-- auxilliary

loop c = do { c; loop c}

ifonly b c = if b then c
             else return ()

-- actual actor code

toPID = actorToPID

chainedActor idx max exit neighbor self =
  do { loop
       ( do { --putStrLn ("Actor " ++ show idx ++ ": WAITING");
              receive self
               [ [Blah] .->. ( do { --putStrLn ("Actor " ++ show idx ++ ": RECEIVED");
                                  if idx == max
                                   then putMVar exit () -- EXIT
                                   else send (toPID neighbor) Blah
                                }
                           )
               ]
             }
       )
     }




createActors :: Int -> Int -> MVar () -> Act Msg -> IO ()
createActors idx max exit curr 
   | idx == max = runActor curr (chainedActor idx max exit curr)
                  -- last actor won't sent, only performs exit   
   | idx < max  = do { (next :: Act Msg) <- createActor valhashOp
                     ; runActor curr (chainedActor idx max exit next)
                     ; createActors (idx+1) max exit next 
                     }


main :: IO ()
main = do { let n = 50000
          ; exit <- newEmptyMVar
          ; start <- getCurrentTime
          ; (initialActor :: Act Msg) <- createActor valhashOp
          ; createActors 1 n exit initialActor
          ; end <- getCurrentTime
          ; putStrLn $ "creation time: " ++ show (diffUTCTime end start)
          ; send (toPID initialActor) Blah 
          ; readMVar exit -- blocks till done
          ; fin <- getCurrentTime
          ; putStrLn $ "message time: " ++ show (diffUTCTime fin end)
          ; putStrLn $ "Threads: " ++ show n
          }