diff --git a/Main.hs b/Main.hs index 09cd788..56a814d 100644 --- a/Main.hs +++ b/Main.hs @@ -278,7 +278,7 @@ compile mode fn outHandle ModeCompile -> do progress "Passes:" - let passes = getPassList optsPS + passes <- calculatePassList ast2 <- runPasses passes ast1 debug "{{{ Generate code" diff --git a/common/PassList.hs b/common/PassList.hs index 70d6b65..4b90e0a 100644 --- a/common/PassList.hs +++ b/common/PassList.hs @@ -17,19 +17,28 @@ with this program. If not, see . -} -- | Lists of passes -module PassList (getPassList) where +module PassList (calculatePassList, getPassList) where + +import Control.Monad.Error +import Data.Graph.Inductive +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set import Check import CompState +import Errors import GenerateC import GenerateCPPCSP import Pass +import qualified Properties as Prop import RainPasses import SimplifyComms import SimplifyExprs import SimplifyProcs import SimplifyTypes import Unnest +import Utils commonPasses :: CompState -> [Pass] commonPasses opts = concat $ @@ -51,3 +60,95 @@ getPassList optsPS = filterPasses optsPS $ concat , genCPasses , genCPPCSPPasses ] + +calculatePassList :: (Die m, CSMR m) => m [Pass] +calculatePassList + = do rawList <- getCompState >>* getPassList + case buildGraph rawList of + Left err -> dieReport (Nothing, "Error working out pass list: " ++ err) + Right g -> return $ graphToList (g :: Gr Pass ()) + +-- Note that the pass execution is "strict" -- that is, all passes +-- are executed, it is only the order that is calculated. In future, +-- providing we construct the post-conditions carefully, we could +-- have "lazy" passes where we only execute those that have a post- +-- condition that we need later on +graphToList :: Graph gr => gr Pass () -> [Pass] +graphToList = topsort' + +buildGraph :: forall gr. Graph gr => [Pass] -> Either String (gr Pass ()) +buildGraph passes = do checked <- checkedRelations + checkPassUnique + checkGraph + nodes <- labelledNodes + edges <- edgeList checked + return $ mkGraph nodes edges + where + prefixPropName :: String -> String + prefixPropName = ("_prop_" ++) + + allProperties :: [Property] -- find all properties in the passes + allProperties = nub $ concatMap (\p -> Set.toList (passPre p) ++ Set.toList (passPost p)) passes + + propToPass :: Property -> Pass + propToPass prop = Pass { + passCode = runPassR (\t -> propCheck prop t >> return t) + ,passName = prefixPropName (propName prop) + ,passPre = Set.empty + ,passPost = Set.empty + ,passEnabled = const True} + + passesAndProps :: [Pass] + passesAndProps = passes ++ map propToPass allProperties + + checkPassUnique :: Either String () + checkPassUnique = when (length (nub passesAndProps) /= length passesAndProps) $ + throwError "Not all pass-names were unique" + + -- Maps a property from those with it as a post-condition to those with it as a pre-condition + relations :: Map.Map Property (Set.Set Pass, Set.Set Pass) + relations = Map.fromListWith merge $ concatMap toRelation passes + where + merge :: (Ord a, Ord b) => (Set.Set a, Set.Set b) -> (Set.Set a, Set.Set b) -> (Set.Set a, Set.Set b) + merge (xa, xb) (ya, yb) = (Set.union xa ya, Set.union xb yb) + + toRelation :: Pass -> [(Property, (Set.Set Pass, Set.Set Pass))] + toRelation pass = map toPost (Set.toList $ passPost pass) ++ map toPre (Set.toList $ passPre pass) + where + toPost :: Property -> (Property, (Set.Set Pass, Set.Set Pass)) + toPost prop = (prop, (Set.singleton pass, Set.empty)) + toPre :: Property -> (Property, (Set.Set Pass, Set.Set Pass)) + toPre prop = (prop, (Set.empty, Set.singleton pass)) + + checkedRelations :: Either String (Map.Map Property (Set.Set Pass, Set.Set Pass)) + checkedRelations = liftM Map.fromList $ mapM check $ Map.toList relations + where + check :: (Property, (Set.Set Pass, Set.Set Pass)) -> Either String (Property, (Set.Set Pass, Set.Set Pass)) + check (prop, (post, pre)) + = do when (Set.null post && not (Set.null pre)) $ + throwError $ "Property in dependency graph is required by a pass but not provided by any: " + ++ show (map passName $ Set.toList pre) + return (prop, (post, pre)) --TODO this is an identity transformation, so just check separately + + checkGraph :: Either String () + checkGraph = return () -- TODO check for cycles + + nodeLabels :: Map.Map Pass Node + nodeLabels = Map.fromList $ zip passesAndProps [0..] + + lookupPass :: Pass -> Either String Node + lookupPass p = transformEither ("Internal, should-be-impossible error in lookupPass " ++) id $ Map.lookup p nodeLabels + + lookupProp :: Property -> Either String Node + lookupProp p = transformEither ("Internal, should-be-impossible error in lookupProp " ++) id $ Map.lookup (propToPass p) nodeLabels + + labelledNodes :: Either String [LNode Pass] + labelledNodes = mapM (\p -> do {lp <- lookupPass p; return (lp, p)}) passesAndProps + + edgeList :: Map.Map Property (Set.Set Pass, Set.Set Pass) -> Either String [LEdge ()] + edgeList = concatMapM (\(prop, (froms, tos)) -> + do tos' <- mapM lookupPass (Set.toList tos) + froms' <- mapM lookupPass (Set.toList froms) + prop' <- lookupProp prop + return $ [(f, prop', ()) | f <- froms'] ++ [(prop', t, ()) | t <- tos']) . Map.toList +