Prune traversals of the AST (speeds up from 90s to 20s for ats1-q7)

fco2/Pass.hs

@@ -3,11 +3,13 @@ module Pass where
 
 import Control.Monad.Error
 import Control.Monad.State
+import Data.Generics
 import Data.List
 import System.IO
 
 import qualified AST as A
 import Errors
+import Metadata
 import ParseState
 import PrettyShow
 
@@ -78,3 +80,10 @@ numberLines s
     = concat $ intersperse "\n" $ [show n ++ ": " ++ s
                                    | (n, s) <- zip [1..] (lines s)]
 
+-- | Make a generic rule for a pass.
+makeGeneric :: (Data t) => (forall s. Data s => s -> PassM s) -> t -> PassM t
+makeGeneric top
+    = (gmapM top)
+        `extM` (return :: String -> PassM String)
+        `extM` (return :: Meta -> PassM Meta)
+

fco2/SimplifyExprs.hs

@@ -28,7 +28,7 @@ functionsToProcs :: Data t => t -> PassM t
 functionsToProcs = doGeneric `extM` doSpecification
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM functionsToProcs
+    doGeneric = makeGeneric functionsToProcs
 
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification (A.Specification m n (A.Function mf sm rts fs vp))
@@ -66,7 +66,7 @@ removeAfter :: Data t => t -> PassM t
 removeAfter = doGeneric `extM` doExpression
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM removeAfter
+    doGeneric = makeGeneric removeAfter
 
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.Dyadic m A.After a b)
@@ -82,7 +82,7 @@ expandArrayLiterals :: Data t => t -> PassM t
 expandArrayLiterals = doGeneric `extM` doArrayElem
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM expandArrayLiterals
+    doGeneric = makeGeneric expandArrayLiterals
 
     doArrayElem :: A.ArrayElem -> PassM A.ArrayElem
     doArrayElem ae@(A.ArrayElemExpr e)
@@ -107,7 +107,7 @@ pullUp :: Data t => t -> PassM t
 pullUp = doGeneric `extM` doStructured `extM` doProcess `extM` doSpecification `extM` doExpression `extM` doVariable `extM` doExpressionList
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM pullUp
+    doGeneric = makeGeneric pullUp
 
     -- | When we encounter a Structured, create a new pulled items state,
     -- recurse over it, then apply whatever pulled items we found to it.

fco2/SimplifyProcs.hs

@@ -25,7 +25,7 @@ parsToProcs :: Data t => t -> PassM t
 parsToProcs = doGeneric `extM` doProcess
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM parsToProcs
+    doGeneric = makeGeneric parsToProcs
 
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Par m pm s)
@@ -59,7 +59,7 @@ removeParAssign :: Data t => t -> PassM t
 removeParAssign = doGeneric `extM` doProcess
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM removeParAssign
+    doGeneric = makeGeneric removeParAssign
 
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))

fco2/Unnest.hs

@@ -25,11 +25,17 @@ type NameMap = Map.Map String A.Name
 
 -- | Get the set of free names within a block of code.
 freeNamesIn :: Data t => t -> NameMap
-freeNamesIn = doGeneric `extQ` doName `extQ` doStructured `extQ` doSpecType
+freeNamesIn = doGeneric
+                `extQ` (ignore :: String -> NameMap)
+                `extQ` (ignore :: Meta -> NameMap)
+                `extQ` doName `extQ` doStructured `extQ` doSpecType
   where
     doGeneric :: Data t => t -> NameMap
     doGeneric n = Map.unions $ gmapQ freeNamesIn n
 
+    ignore :: t -> NameMap
+    ignore s = Map.empty
+
     doName :: A.Name -> NameMap
     doName n = Map.singleton (A.nameName n) n
 
@@ -58,7 +64,10 @@ freeNamesIn = doGeneric `extQ` doName `extQ` doStructured `extQ` doSpecType
 
 -- | Replace names.
 replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
-replaceNames map p = everywhere (mkT $ doName) p
+replaceNames map p = everywhere (mkT doName
+                                   `extT` (id :: String -> String)
+                                   `extT` (id :: Meta -> Meta)
+                                ) p
   where
     smap = [(A.nameName f, t) | (f, t) <- map]
 
@@ -73,7 +82,7 @@ removeFreeNames :: Data t => t -> PassM t
 removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
   where
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM removeFreeNames
+    doGeneric = makeGeneric removeFreeNames
 
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification spec = case spec of
@@ -154,7 +163,7 @@ removeNesting p
     pullSpecs = doGeneric `extM` doStructured
 
     doGeneric :: Data t => t -> PassM t
-    doGeneric = gmapM pullSpecs
+    doGeneric = makeGeneric pullSpecs
 
     doStructured :: A.Structured -> PassM A.Structured
     doStructured s@(A.Spec m spec@(A.Specification _ n st) subS)