Clean up some remaining messy code after the passes rework.

This commit is contained in:
Adam Sampson 2008-06-02 17:04:30 +00:00
parent 13668f6e32
commit f811d2cdc9
2 changed files with 42 additions and 40 deletions

View File

@ -61,11 +61,11 @@ type PassType = (forall s. Data s => s -> PassM s)
-- | A description of an AST-mangling pass. -- | A description of an AST-mangling pass.
data Monad m => Pass_ m = Pass { data Monad m => Pass_ m = Pass {
passCode :: forall t. Data t => t -> m t passCode :: forall t. Data t => t -> m t
,passName :: String , passName :: String
,passPre :: Set.Set Property , passPre :: Set.Set Property
,passPost :: Set.Set Property , passPost :: Set.Set Property
,passEnabled :: CompState -> Bool , passEnabled :: CompState -> Bool
} }
instance Monad m => Eq (Pass_ m) where instance Monad m => Eq (Pass_ m) where
x == y = passName x == passName y x == y = passName x == passName y
@ -79,8 +79,8 @@ type PassR = Pass_ PassMR
-- | A property that can be asserted and tested against the AST. -- | A property that can be asserted and tested against the AST.
data Property = Property { data Property = Property {
propName :: String propName :: String
,propCheck :: A.AST -> PassMR () , propCheck :: A.AST -> PassMR ()
} }
instance Eq Property where instance Eq Property where
x == y = propName x == propName y x == y = propName x == propName y
@ -94,27 +94,30 @@ instance Show Property where
runPassR :: (A.AST -> PassMR A.AST) -> (A.AST -> PassM A.AST) runPassR :: (A.AST -> PassMR A.AST) -> (A.AST -> PassM A.AST)
runPassR p t runPassR p t
= do st <- get = do st <- get
(r,w) <- liftIO $ flip runStateT [] $ runReaderT (runErrorT (p t)) st (r, w) <- liftIO $ flip runStateT [] $ runReaderT (runErrorT (p t)) st
case r of case r of
Left err -> throwError err Left err -> throwError err
Right result -> mapM_ warnReport w >> return result Right result -> mapM_ warnReport w >> return result
runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState, [WarningReport]) runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState, [WarningReport])
runPassM cs pass = liftM flatten $ flip runStateT [] $ flip runStateT cs $ runErrorT pass runPassM cs pass
= liftM flatten $ flip runStateT [] $ flip runStateT cs $ runErrorT pass
where where
flatten :: ((a, b),c) -> (a, b, c) flatten :: ((a, b), c) -> (a, b, c)
flatten ((x, y), z) = (x, y, z) flatten ((x, y), z) = (x, y, z)
enablePassesWhen :: (CompState -> Bool) -> [Pass] -> [Pass] enablePassesWhen :: (CompState -> Bool) -> [Pass] -> [Pass]
enablePassesWhen f = map (\p -> p enablePassesWhen f
{passEnabled = \c -> f c && (passEnabled p c)}) = map (\p -> p { passEnabled = \c -> f c && (passEnabled p c) })
-- | A helper to run a pass at the top-level, or deliver an error otherwise -- | A helper to run a pass at the top-level, or deliver an error otherwise
passOnlyOnAST :: forall t. Data t => String -> (A.AST -> PassM A.AST) -> t -> PassM t passOnlyOnAST :: forall t. Data t => String -> (A.AST -> PassM A.AST) -> t -> PassM t
passOnlyOnAST name func x passOnlyOnAST name func x
= case cast x :: Maybe A.AST of = case cast x :: Maybe A.AST of
Nothing -> dieP emptyMeta $ name ++ " only operates at top-level" Nothing -> dieP emptyMeta $ name ++ " only operates at top-level"
Just x' -> func x' >>= \y -> case cast y :: Maybe t of Just x' ->
do y <- func x'
case cast y :: Maybe t of
Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level" Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level"
Just y' -> return y' Just y' -> return y'
@ -122,11 +125,11 @@ type PassMaker = String -> [Property] -> [Property] -> (forall t. Data t => t ->
passMakerHelper :: (CompState -> Bool) -> PassMaker passMakerHelper :: (CompState -> Bool) -> PassMaker
passMakerHelper f name pre post code passMakerHelper f name pre post code
= Pass {passCode = code = Pass { passCode = code
,passName = name , passName = name
,passPre = Set.fromList pre , passPre = Set.fromList pre
,passPost = Set.fromList post , passPost = Set.fromList post
,passEnabled = f , passEnabled = f
} }
rainOnlyPass :: PassMaker rainOnlyPass :: PassMaker
@ -141,14 +144,13 @@ cOnlyPass = passMakerHelper $ (== BackendC) . csBackend
cppOnlyPass :: PassMaker cppOnlyPass :: PassMaker
cppOnlyPass = passMakerHelper $ (== BackendCPPCSP) . csBackend cppOnlyPass = passMakerHelper $ (== BackendCPPCSP) . csBackend
pass :: String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass pass :: String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass
pass name pre post code pass name pre post code
= Pass {passCode = code = Pass { passCode = code
,passName = name , passName = name
,passPre = Set.fromList pre , passPre = Set.fromList pre
,passPost = Set.fromList post , passPost = Set.fromList post
,passEnabled = const True , passEnabled = const True
} }
-- | Compose a list of passes into a single pass by running them in the order given. -- | Compose a list of passes into a single pass by running them in the order given.

View File

@ -34,8 +34,8 @@ import Utils
simplifyComms :: [Pass] simplifyComms :: [Pass]
simplifyComms = simplifyComms =
[ outExprs [ outExprs
,transformInputCase , transformInputCase
,transformProtocolInput , transformProtocolInput
] ]
outExprs :: Pass outExprs :: Pass