{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} -------------------------------------------------------------------------------- -- -- 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. The names of the copyright holders may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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 MultiSetRewrite.RuleCompiler where -- The compiler for firing multi-set rewrite rules parameterized in terms of an underlying store representation import IO import Control.Concurrent import Control.Concurrent.STM import MultiSetRewrite.Base import MultiSetRewrite.RuleSyntax class EMatch m => RuleCompiler a m rm idx st | a -> m rm idx st, rm -> a where -- we could use type functions here -- a is the store type -- m is the (plain) message (aka method, constraint) -- 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 atomicVerifyAndDeleteCnt :: a -> Code_RHS c -> [(Check rm, IO (Maybe (Code_RHS c)))] -> IO (Maybe (Code_RHS c)) getIndex :: a -> m -> IO idx -- m is a pattern message initSearch :: a -> idx -> IO st nextMsg :: a -> st -> IO (Maybe rm) extractMsg :: rm -> IO (Maybe (InternalMsg m)) printMsg :: a -> rm -> IO String printReachMsg :: a -> st -> IO String -- (compiled) rule representation ----------------------------------------------- type Code_RHS a = IO a -- external rules are pairs of ([MatchTask msg], Code_RHS a) -- we compile them to a function type CompClause store rmsg code = rmsg -> store -> IO (Maybe (Code_RHS code)) -- in a concurrent setting there are two reasons for failure -- (1) the search failed, or -- (2) atomic reverification&delete of matched messages failed -- therefore we will accumulate the to be deleted messages and -- reverifyAndDelete them once all tasks could be matched -- important to perform the reverifyAndDelete as part of the search, -- cause if reverifyAndDelete fails we must continue the search data Check a = Verify a | VerifyAndDelete a uncheck (Verify x) = x uncheck (VerifyAndDelete x) = x addCheck task a = case task of Simp _ -> VerifyAndDelete a Prop _ -> Verify a _ -> error "addCheck: impossible" -- executing rules select :: RuleCompiler a m rm idx st => a -> rm -> [CompClause a rm c] -> IO (Maybe (Code_RHS c)) select _ _ [] = return Nothing select act active_msg (comp:comps) = do res <- comp active_msg act case res of Just _ -> return res Nothing -> select act active_msg comps -- compilation scheme for rules --------------------------------------------------- -- generation of match tasks -- 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] -- nothing at the moment -- early guard scheduling, alternative semantics (best match), ... optimize :: [[MatchTask msg]] -> [[MatchTask msg]] optimize = id -- extract msg from match task getMsg (Simp x) = x getMsg (Prop x) = x getMsg _ = error "the impossible has happened, always check for guards first" -- match search compiler written in continuation-passing style -- allows easy pruning of search space in case 'higher-level' nodes -- have been deleted (we simply abandon the current continuation -- and use continuations to jump up higher in the search tree) type Cnt a = IO (Maybe (Code_RHS a)) compileCnt :: (RuleCompiler act msg rmsg idx st, Show msg) => Code_RHS a -> [MatchTask msg] -> [CompClause act rmsg a] compileCnt 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 compileSingleCnt --compileClause :: [MatchTask msg] -> rmsg -> act -> IO (Maybe (Code_RHS a)) compileClause tasks msg act = -- msg is a message in rich format let currentTask = head tasks -- get the first task active_msg = getMsg currentTask in do plainMsg <- extractMsg msg case plainMsg of -- check if msg not already deleted Nothing -> return Nothing Just plain_msg -> do (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 do { compileSingleCnt act (return Nothing) -- the current continuation -- is failure, cause the 'top' msg is fixed ([(addCheck currentTask msg, return Nothing)] -- the 'local' continuation, allows us to fail quickly -- in case the 'top' msg is deleted , body) var_env (tail tasks) -- Continue the search for the next message } else return Nothing -- compileSingleCnt, takes care of the remaining patterns -- we pass through a continuation which we possibly drop by another continuation -- to prune the search space compileSingleCnt :: (RuleCompiler act msg rmsg idx st, Show msg) => act -> Cnt a -> ([(Check rmsg, Cnt a)],Code_RHS a) -> [Tag] -> [MatchTask msg] -> IO (Maybe (Code_RHS a)) compileSingleCnt act cnt_search (verifyAndDeleteMsgs, body) _ [] = atomicVerifyAndDeleteCnt act body verifyAndDeleteMsgs -- based on the 'atomic' check we can perform some optimizations -- ie pruning of the search space compileSingleCnt act cnt_search msgsAndbody var_env ((Guard guard):tasks) = do { b <- guard ; if b then compileSingleCnt act cnt_search msgsAndbody var_env tasks else cnt_search } compileSingleCnt act cnt_search (verifyAndDeleteMsgs, body) var_env (task:tasks) = case getMsg task of active_msg -> -- our task is to find a match for active_msg, we use the hash tables for this search -- st is a store pointer, points to the current "inactive" message in the appropriate hash table -- 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 { --putStrLn "start search for remaining patterns" --t <- myThreadId; --es <- printReachMsg act st; --logString $ show t ++ " " ++ es; result <- nextMsg act st ; case result of Nothing -> do --logString $ "BT " ++ show t cnt_search -- back-track, ie continue search Just msg -> do --putStr "Matchsearch2 \n"; -- ; putStr ("active_msg = " ++ show active_msg ++ "\n") -- ; putStr ("msg = " ++ show msg ++ "\n") --s <- printMsg act msg; --logString $ "CntSearchHave " ++ show t ++ "Msg: " ++ s; plainMsg <- extractMsg msg case plainMsg of Nothing -> search st Just plain_msg -> do (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 { compileSingleCnt act (search st) -- the current continuation (verifyAndDeleteMsgs ++ -- we first check higher nodes to perform [(addCheck task msg, search st)] -- more aggressive pruning , body) var_env2 tasks } else search st --return Nothing is wrong -- we must continue the search !!!!! } {- Further thoughts: Support 'async' pruning of search tree. For example, if top-level node, the active_msg, gets deleted, we can 'kill' the entire search. Could be support via asynchronous exceptions. Each search thread registers its Id with the active_msg, a logical delete will kill all other (search) threads operating on this msg. -}