Commit a2c3d0b7 authored by Philipp Meyer's avatar Philipp Meyer

Testing different simplifications in parallel

parent 48963ebf
...@@ -22,7 +22,7 @@ executable slapnet ...@@ -22,7 +22,7 @@ executable slapnet
other-modules: other-modules:
-- other-extensions: -- other-extensions:
build-depends: base >=4 && <5, sbv, parsec, containers, transformers, build-depends: base >=4 && <5, sbv, parsec, containers, transformers,
bytestring, mtl bytestring, mtl, stm, async, parallel-io
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -fsimpl-tick-factor=1000 ghc-options: -fsimpl-tick-factor=1000 -threaded -rtsopts -with-rtsopts=-N
...@@ -3,6 +3,7 @@ module Main where ...@@ -3,6 +3,7 @@ module Main where
import System.Exit import System.Exit
import System.IO import System.IO
import Control.Monad import Control.Monad
import Control.Concurrent.ParallelIO
import Control.Arrow (first) import Control.Arrow (first)
import Data.List (partition) import Data.List (partition)
import Data.Maybe import Data.Maybe
...@@ -405,14 +406,19 @@ main = do ...@@ -405,14 +406,19 @@ main = do
exitSuccessWith :: String -> IO () exitSuccessWith :: String -> IO ()
exitSuccessWith msg = do exitSuccessWith msg = do
putStrLn msg putStrLn msg
exitSuccess cleanupAndExitWith ExitSuccess
exitFailureWith :: String -> IO () exitFailureWith :: String -> IO ()
exitFailureWith msg = do exitFailureWith msg = do
putStrLn msg putStrLn msg
exitWith $ ExitFailure 2 cleanupAndExitWith $ ExitFailure 2
exitErrorWith :: String -> IO () exitErrorWith :: String -> IO ()
exitErrorWith msg = do exitErrorWith msg = do
hPutStrLn stderr msg hPutStrLn stderr msg
exitWith $ ExitFailure 3 cleanupAndExitWith $ ExitFailure 3
cleanupAndExitWith :: ExitCode -> IO ()
cleanupAndExitWith code = do
stopGlobalPool
exitWith code
...@@ -59,7 +59,7 @@ startOptions = Options { inputFormat = PNET ...@@ -59,7 +59,7 @@ startOptions = Options { inputFormat = PNET
, optShowVersion = False , optShowVersion = False
, optProperties = [] , optProperties = []
, optTransformations = [] , optTransformations = []
, optSimpFormula = 6 , optSimpFormula = 100
, optRefinementType = Just SComponentWithCutRefinement , optRefinementType = Just SComponentWithCutRefinement
, optMinimizeRefinement = 0 , optMinimizeRefinement = 0
, optInvariant = False , optInvariant = False
......
...@@ -7,6 +7,9 @@ module Solver.Simplifier ( ...@@ -7,6 +7,9 @@ module Solver.Simplifier (
import Data.SBV import Data.SBV
import Data.Maybe import Data.Maybe
import Data.Ord (comparing)
import Data.List (minimumBy)
import Control.Arrow (second)
import Control.Monad import Control.Monad
import Control.Monad.Identity import Control.Monad.Identity
import qualified Data.Map as M import qualified Data.Map as M
...@@ -50,47 +53,66 @@ checkSubsumptionSat c0 cs = ...@@ -50,47 +53,66 @@ checkSubsumptionSat c0 cs =
cutTransitions :: SimpleCut -> S.Set Transition cutTransitions :: SimpleCut -> S.Set Transition
cutTransitions (c0, cs) = S.unions (c0:cs) cutTransitions (c0, cs) = S.unions (c0:cs)
generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut] type SimpConfig = ([[SimpleCut] -> OptIO [SimpleCut]], SimpleCut, SimpleCut, Int)
generateCuts net f cuts = do
simpWithoutFormula :: PetriNet -> Formula Transition -> SimpConfig
simpWithoutFormula net f =
(
[ return . simplifyCuts
, return . removeImplicants
, greedySimplify net f
, return . combineCuts
, simplifyBySubsumption
]
, (S.empty, [])
, second (S.fromList (transitions net) :) (formulaToCut f)
, 2
)
simpWithFormula :: PetriNet -> Formula Transition -> SimpConfig
simpWithFormula net f =
(
[ return . simplifyCuts
, return . removeImplicants
, return . filterInvariantTransitions net
, greedySimplify net FTrue
, return . combineCuts
, simplifyBySubsumption
]
, second (S.fromList (transitions net) :) (formulaToCut f)
, (S.empty, [])
, 2
)
applySimpConfig :: SimpConfig -> [Cut] -> OptIO [SimpleCut]
applySimpConfig (simpFunctions, initialCut, afterCut, otfIndex) cuts = do
simp <- opt optSimpFormula simp <- opt optSimpFormula
let (otfSimps, afterSimps) = splitAt otfIndex $ take simp simpFunctions
let simpFunctions =
[ return . simplifyCuts
, return . removeImplicants
, simplifyBySubsumption
, greedySimplify net f
, simplifyBySubsumption
]
let (otfSimps, afterSimps) = splitAt 2 $ take simp simpFunctions
let simpFunction = foldl (>=>) return afterSimps let simpFunction = foldl (>=>) return afterSimps
let otfFunction = foldl (>=>) return otfSimps let otfFunction = foldl (>=>) return otfSimps
let cnfCuts = map cutToSimpleDNFCuts cuts let cnfCuts = map cutToSimpleDNFCuts cuts
dnfCuts <- foldM (combine otfFunction) [(S.empty, [])] cnfCuts dnfCuts <- foldM (combine otfFunction) [initialCut] cnfCuts
simpCuts <- simpFunction dnfCuts simpCuts <- simpFunction dnfCuts
combine otfFunction [afterCut] simpCuts
let simpFunctions' =
[ return . simplifyCuts
, return . removeImplicants
, return . filterInvariantTransitions net
, simplifyBySubsumption
, greedySimplify net FTrue
, simplifyBySubsumption
]
let (otfSimps', afterSimps') = splitAt 2 $ take simp simpFunctions'
let simpFunction' = foldl (>=>) return afterSimps'
let otfFunction' = foldl (>=>) return otfSimps'
let (fc0, fcs) = formulaToCut f
let addedTransitions = S.fromList (transitions net)
let addedCut = (fc0, addedTransitions : fcs)
simpCutsWithFormula <- combine otfFunction' [addedCut] simpCuts
simpCuts' <- simpFunction' simpCutsWithFormula
return simpCuts'
where where
combine simpFunction cs1 cs2 = combine simpFunction cs1 cs2 =
simpFunction [ (c1c0 `S.union` c2c0, c1cs ++ c2cs) simpFunction [ (c1c0 `S.union` c2c0, c1cs ++ c2cs)
| (c1c0, c1cs) <- cs1, (c2c0, c2cs) <- cs2 ] | (c1c0, c1cs) <- cs1, (c2c0, c2cs) <- cs2 ]
generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut]
generateCuts net f cuts = do
let configs = [simpWithFormula, simpWithoutFormula]
let tasks = map (\c -> applySimpConfig (c net f) cuts) configs
rs <- parallelIO tasks
return $ minimumBy (comparing length) rs
combineCuts :: [SimpleCut] -> [SimpleCut]
combineCuts cuts =
M.toList $ M.fromListWith combineFunc cuts
where
combineFunc cs cs' =
simplifyPositiveCut [ c `S.union` c' | c <- cs, c' <- cs' ]
filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut] filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut]
filterInvariantTransitions net = filterInvariantTransitions net =
let ts = S.fromList $ invariantTransitions net let ts = S.fromList $ invariantTransitions net
...@@ -115,12 +137,15 @@ simplifyCuts = mapMaybe simplifyCut ...@@ -115,12 +137,15 @@ simplifyCuts = mapMaybe simplifyCut
simplifyCut :: SimpleCut -> Maybe SimpleCut simplifyCut :: SimpleCut -> Maybe SimpleCut
simplifyCut (c0, cs) = simplifyCut (c0, cs) =
let remove b a = a `S.difference` b let remove b a = a `S.difference` b
cs' = removeWith S.isSubsetOf $ map (remove c0) cs cs' = simplifyPositiveCut $ map (remove c0) cs
in if any S.null cs' then in if any S.null cs' then
Nothing Nothing
else else
Just (c0, cs') Just (c0, cs')
simplifyPositiveCut :: [S.Set Transition] -> [S.Set Transition]
simplifyPositiveCut = removeWith S.isSubsetOf
simplifyBySubsumption :: [SimpleCut] -> OptIO [SimpleCut] simplifyBySubsumption :: [SimpleCut] -> OptIO [SimpleCut]
simplifyBySubsumption = simplifyBySubsumption' [] simplifyBySubsumption = simplifyBySubsumption' []
......
...@@ -5,15 +5,16 @@ module Util ...@@ -5,15 +5,16 @@ module Util
listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal, listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal,
makeVarMap,makeVarMapWith,buildVector,makeVector,getNames, makeVarMap,makeVarMapWith,buildVector,makeVector,getNames,
Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted, Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted,
OptIO,verbosePut,opt,putLine) OptIO,verbosePut,opt,putLine,parallelIO)
where where
import Data.SBV import Data.SBV
import qualified Data.Map as M import qualified Data.Map as M
import Control.Monad
import Data.List import Data.List
import Data.Ord import Data.Ord
import Data.Function import Data.Function
import Control.Concurrent.ParallelIO
import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import System.IO import System.IO
...@@ -115,6 +116,11 @@ verbosePut level str = do ...@@ -115,6 +116,11 @@ verbosePut level str = do
putLine :: String -> OptIO () putLine :: String -> OptIO ()
putLine = liftIO . putStrLn putLine = liftIO . putStrLn
parallelIO :: [OptIO a] -> OptIO [a]
parallelIO tasks = do
opts <- ask
liftIO $ parallel $ map (`runReaderT` opts) tasks
{- {-
- String functions - String functions
-} -}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment