Clean up some remaining messy code after the passes rework.
This commit is contained in:
parent
13668f6e32
commit
f811d2cdc9
50
pass/Pass.hs
50
pass/Pass.hs
|
@ -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.
|
||||||
|
|
|
@ -34,8 +34,8 @@ import Utils
|
||||||
simplifyComms :: [Pass]
|
simplifyComms :: [Pass]
|
||||||
simplifyComms =
|
simplifyComms =
|
||||||
[ outExprs
|
[ outExprs
|
||||||
,transformInputCase
|
, transformInputCase
|
||||||
,transformProtocolInput
|
, transformProtocolInput
|
||||||
]
|
]
|
||||||
|
|
||||||
outExprs :: Pass
|
outExprs :: Pass
|
||||||
|
|
Loading…
Reference in New Issue
Block a user