{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {- -------------------------------------------------------------------------------- -- -- Copyright (C) 2008 Martin Sulzmann, Edmund Lam. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Isaac Jones nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Actor.ActorCompiler where {- version using memoization, the programmer must explicitly provide the "line number" -} import Actor.ActorBase import Actor.ActorSyntax -- the bare actor class, minimal functionality required to -- implement the multi-set message matching algorithm -- TODO: we need rm -> a (which seems too strong), otherwise some constraints cant be deduced class EMatch m => Actor a m rm idx st | a -> m rm idx st, rm -> a where -- we could use type functions here -- a is the actor type -- m is the (plain) message -- rm is the (rich) message with more (internal) information, eg the message's location -- idx is the search index where to start -- st is the current state of our search getMessage :: a -> Maybe Int -> IO (Maybe rm) deleteMsg :: a -> rm -> IO () getIndex :: a -> m -> IO idx -- m is a pattern message initSearch :: a -> idx -> IO st nextMsg :: a -> st -> IO (Maybe rm) resetMB :: a -> IO () extractMsg :: rm -> IO (InternalMsg m) -- memoization codeLookup :: a -> Int -> IO (Maybe [CompClause a rm ()]) memoCode :: a -> (Int,[CompClause a rm ()]) -> IO () {- getMessage gets the most recent active message which is then put into the store (pool of inactive messages) a time-out (microseconds, action) is an additional parameter if getMessage returns Nothing the time for waiting for an incoming message has exceeded the time-out limit, if Just x then x is the next incoming message deleteMsg deletes message in the store getIndex computes the index for each message initSearch sets up the search based on a given index idx nextMsg gets the next message matching a given index idx resetMB restores the mailbox by putting store contraints back into the queue/mailbox -} -- behavior of receive clauses can be specified via the following data type data MemoFlag = NoMemo | Memo Int data ReceiveParameters = RecParm { memo :: MemoFlag -- we'll use the provided Int to store the 'compiled' clauses , resetAction :: IO () -- the action to be executed before executing the body (rhs) -- typically, resetMB , timeOut :: Maybe (Int, IO ()) -- waits number of microseconds for incoming message, then executes action -- and 'aborts' receive clause } -- (compiled) receive clauses representation ----------------------------------------------- type Code_RHS a = IO a -- external receive clauses are pairs of ([MatchTask msg], Code_RHS a) -- we compile them to a function type CompClause act rmsg code = rmsg -> act -> IO (Maybe (Code_RHS code)) -- rmsg is the currently active message (in rich format) -- search for matching lhs performed in IO -- if match found commit and return code for rhs -- otherwise return Nothing -- receive clauses execution scheme ------------------------------------------ -- NOTE: We can only support memo for receive bodies returning () "unit", -- For any other return type, some types would be too polymorphic. -- standard reveive, no memoization, always reset MB, no timeout receive :: (Actor act msg rmsg idx st, Show msg) => act -> [([MatchTask msg], Code_RHS a)] -> IO a receive act prog = receiveInternal act (build prog) where build [] = [] build ((tasks,body):rest) = (compile (do {resetMB act; body}) tasks) ++ (build rest) -- maintain order of clauses! -- generalized, parameterized receive receiveParm :: (Actor act msg rmsg idx st, Show msg) => act -> ReceiveParameters -> [([MatchTask msg], Code_RHS ())] -> IO () receiveParm act parm prog = let -- 'compilation' of match clauses build [] = [] build ((tasks,body):rest) = (compile (do {resetAction parm; body}) tasks) ++ (build rest) -- we plug in the resetAction before we execute the body -- maintain order of clauses (important in case of sequential execution) in case (memo parm) of NoMemo -> receiveInternal2 act parm (build prog) -- no memoization Memo idx -> do res <- codeLookup act idx -- memoization case res of -- check if already stored Just code -> receiveInternal2 act parm code Nothing -> do let code = build prog memoCode act (idx,code) receiveInternal2 act parm code receiveInternal :: (Actor a m rm idx st, Show m) => a -> [CompClause a rm c] -> IO c receiveInternal act comp = do { Just active_msg <- getMessage act Nothing -- no timeout --; putStr "** StartSearch with getMessage **\n" ; res <- select active_msg act comp ; case res of Just action -> action Nothing -> receiveInternal act comp } -- get active message (which we then put into the store, pool of inactive messages) -- check if the active messages fires any of the receive clauses (tried from top to bottom) -- if yes, simply execute rhs/body, otherwise repeat, get a next/new active message ... receiveInternal2 :: (Actor a m rm idx st, Show m) => a -> ReceiveParameters -> [CompClause a rm ()] -> IO () receiveInternal2 act parm compiled_clauses = let setupTimeOut = case (timeOut parm) of Nothing -> Nothing Just (t,_) -> Just t timeOutAction = let Just (_,action) = timeOut parm in action choose Nothing a1 a2 = a1 choose (Just x) a1 a2 = a2 x seqMsgSeqCls = -- sequential processing of incoming messages, and -- sequential, top to bottom, application of clauses do active_msg_res <- getMessage act setupTimeOut case active_msg_res of Just active_msg -> do --putStrLn $ "Msg arrived" res <- select active_msg act compiled_clauses case res of Just action -> do --putStrLn "fire" action Nothing -> do --putStrLn "failed, try again" seqMsgSeqCls Nothing -> timeOutAction in seqMsgSeqCls select :: Actor a m rm idx st => rm -> a -> [CompClause a rm c] -> IO (Maybe (Code_RHS c)) select _ _ [] = return Nothing select msg act (comp:comps) = do { res <- comp msg act ; case res of Just action -> return (Just action) Nothing -> select msg act comps } -- based on the given message, check if any of the (compiled) clauses can be executed -- compilation scheme for receive clauses ------------------------------------------------------ -- compilation of a single receive clause -- yields several compiled clauses, any of the messages -- in the pattern could be matched first compile :: (Actor act msg rmsg idx st, Show msg) => Code_RHS a -> [MatchTask msg] -> [CompClause act rmsg a] compile body tasks = map compileClause (optimize (generateTasks tasks)) where -- compileClause tries to match the first message pattern -- the search for the remaining message patterns are done by compileSingle --compileClause :: [MatchTask msg] -> rmsg -> act -> IO (Maybe (IO a)) compileClause tasks msg act = -- msg is a message in rich format -- \msg -> \act -> case (head tasks) of -- get the first task Simp active_msg -> do { -- putStr "Matchsearch start:\n" -- ; putStr ("active_msg = " ++ show active_msg ++ "\n") -- ; putStr ("msg = " ++ show msg ++ "\n") plain_msg <- extractMsg msg ;(b,var_env) <- internal_match [] plain_msg active_msg -- multi-set matching, see definition of internal_match -- where we use tags to remember already matched messages ; if b then compileSingle act (do {deleteMsg act msg; body}) var_env (tail tasks) -- compileSingle accumulates all deletes by putting them -- in front of body else return Nothing } Prop active_msg -> do { plain_msg <- extractMsg msg ; (b,var_env) <- internal_match [] plain_msg active_msg -- multi-set matching, see definition of internal_match ; if b then compileSingle act (do {body}) var_env (tail tasks) -- no delete for props else return Nothing } Guard _ -> error "A guard can't be the first match task" -- nothing at the moment -- early guard scheduling, alternative semantics (best match), ... optimize :: [[MatchTask msg]] -> [[MatchTask msg]] optimize = id -- we only need to guarantee that each element appears once in front generateTasks tasks = [ ys ++ guards | ys <- genTasks simps_props] where test (Prop _) = True test (Simp _) = True test (Guard _) = False simps_props = filter (\t -> test t) tasks guards = filter (\t -> not (test t)) tasks genTasks [] = error "simps/props can't be empty" genTasks xs = let go 1 xs = [xs] go n xs = [xs] ++ go (n-1) (shuffle xs) in go (length xs) xs shuffle [] = [] shuffle (x:xs) = xs ++ [x] -- we permute tasks, -- the first tasks must be either Simp or Prop -- all guards are at the tail to ensure that there're no unbound variables -- NOTE: But we don't catch cases like [ x > y ] ! permuteTasks :: [MatchTask msg] -> [[MatchTask msg]] permuteTasks tasks = [ ys ++ guards | ys <- permute simps_props ] where test (Prop _) = True test (Simp _) = True test (Guard _) = False simps_props = filter (\t -> test t) tasks guards = filter (\t -> not (test t)) tasks -- brute-force permutation, unnecessary permute [] = [] permute [x] = [[x]] permute (x:xs) = [ zs | ys <- permute xs, zs <- patch x ys ] patch x zs = [x:zs] ++ [(take n zs) ++ [x] ++ (drop n zs) | n <- [1..length zs]] -- compilation for a fixed sequence of match tasks -- we thread through a list of tags, var_env, to check for already bound pattern variables -- and already matched messages compileSingle :: (Actor act msg rmsg idx st, Show msg) => act -> Code_RHS a -> [Tag] -> [MatchTask msg] -> IO (Maybe (Code_RHS a)) compileSingle act body _ [] = return (Just body) compileSingle act body var_env ((Guard guard):tasks) = do { b <- guard ; if b then compileSingle act body var_env tasks else return Nothing } compileSingle act body var_env (task:tasks) = let getMsg (Simp x) = x getMsg (Prop x) = x getMsg _ = error "the impossible has happened, always check for guards first" in case getMsg task of active_msg -> -- we perform a linear search of the store to find a match for active_msg -- st is a store pointer, points to the current "inactive" message in the store -- nextMsg will update st to the next "inactive" message do { idx <- getIndex act active_msg ; st <- initSearch act idx ; search st } where search st = do { result <- nextMsg act st ; case result of Nothing -> return Nothing -- back-track Just msg -> do { -- putStr "Matchsearch2 \n" -- ; putStr ("active_msg = " ++ show active_msg ++ "\n") -- ; putStr ("msg = " ++ show msg ++ "\n") plain_msg <- extractMsg msg ; (b,var_env2) <- internal_match var_env plain_msg active_msg -- side-effect of binding pattern variables -- multi-set matching, see definition of internal_match ; if b then do { rest <- compileSingle act body var_env2 tasks -- choice point ; case rest of Nothing -> search st Just code_rest -> case task of Simp _ -> return (Just (do {deleteMsg act msg; code_rest})) -- we must delete msg, not active_msg -- we use syntactic equality testing for delete Prop _ -> return (Just code_rest) -- nothing to delete } else search st --return Nothing is wrong -- we must continue the search !!!!! } }