actor-0.1: Actor/ActorCompiler.hs
{-# 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 [] = error "simps/props can't be empty"
generateTasks 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 !!!!!
}
}