Added functions to PassList that build a dependency graph from a list of properties (based on their pre- and post- properties) and use it to return an ordered pass list

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"

common/PassList.hs

@@ -17,19 +17,28 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | 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
+