Adjusted all the remaining modules in the transformations directory to work with the new Pass system

This commit is contained in:
Neil Brown 2008-12-14 18:30:02 +00:00
parent 1d73b56988
commit a0c58ae836
3 changed files with 11 additions and 24 deletions

View File

@ -183,7 +183,7 @@ effectMoveCopyDecisions g decs = foldFuncsM $ map effect $ Map.toList decs
Nothing -> const $ dieP (findMeta v) "Could not find label for node" Nothing -> const $ dieP (findMeta v) "Could not find label for node"
Just mod -> effectDecision v dec mod Just mod -> effectDecision v dec mod
implicitMobility :: Pass implicitMobility :: Pass A.AST
implicitMobility implicitMobility
= pass "Implicit mobility optimisation" = pass "Implicit mobility optimisation"
[] [] --TODO properties [] [] --TODO properties

View File

@ -41,7 +41,7 @@ import Traversal
import UsageCheckUtils import UsageCheckUtils
import Utils import Utils
simplifyAbbrevs :: [Pass] simplifyAbbrevs :: [Pass A.AST]
simplifyAbbrevs = simplifyAbbrevs =
[ removeInitial [ removeInitial
, removeResult , removeResult
@ -49,14 +49,14 @@ simplifyAbbrevs =
] ]
-- | Rewrite 'InitialAbbrev' into a variable and an assignment. -- | Rewrite 'InitialAbbrev' into a variable and an assignment.
removeInitial :: Pass removeInitial :: PassOnOps (ExtOpMSP BaseOp)
removeInitial removeInitial
= pass "Remove INITIAL abbreviations" = pass "Remove INITIAL abbreviations"
[] []
[Prop.initialRemoved] [Prop.initialRemoved]
(applyDepthSM doStructured) (applyBottomUpMS doStructured)
where where
doStructured :: Data t => A.Structured t -> PassM (A.Structured t) doStructured :: TransformStructured (ExtOpMSP BaseOp)
doStructured (A.Spec m spec s) = doSpec m spec s doStructured (A.Spec m spec s) = doSpec m spec s
doStructured s = return s doStructured s = return s
@ -166,25 +166,24 @@ removeInitial
specVar (A.Specification m n _) = A.Variable m n specVar (A.Specification m n _) = A.Variable m n
-- | Rewrite 'ResultAbbrev' into just 'Abbrev'. -- | Rewrite 'ResultAbbrev' into just 'Abbrev'.
removeResult :: Pass removeResult :: Polyplate t (OneOp A.AbbrevMode) () => Pass t
removeResult removeResult
= pass "Remove RESULT abbreviations" = pass "Remove RESULT abbreviations"
[] []
[Prop.resultRemoved] [Prop.resultRemoved]
(applyDepthM (return . doAbbrevMode)) (return . applyBottomUp doAbbrevMode)
where where
doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode
doAbbrevMode A.ResultAbbrev = A.Abbrev doAbbrevMode A.ResultAbbrev = A.Abbrev
doAbbrevMode s = s doAbbrevMode s = s
-- | Rewrite abbreviation modes in the state. -- | Rewrite abbreviation modes in the state.
updateAbbrevsInState :: Pass updateAbbrevsInState :: Pass t
updateAbbrevsInState updateAbbrevsInState
= pass "Update INITIAL and RESULT abbreviations in state" = pass "Update INITIAL and RESULT abbreviations in state"
[Prop.initialRemoved, Prop.resultRemoved] [Prop.initialRemoved, Prop.resultRemoved]
[] []
(\v -> get >>* doNameAbbrevs >>= applyDepthM (return . doAbbrevMode) (\v -> get >>= applyDepthM (return . doAbbrevMode) >>= put >> return v)
>>= put >> return v)
where where
doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode
doAbbrevMode A.InitialAbbrev = A.Original doAbbrevMode A.InitialAbbrev = A.Original

View File

@ -34,13 +34,13 @@ import Traversal
import Types import Types
import Utils import Utils
simplifyTypes :: [Pass] simplifyTypes :: [Pass A.AST]
simplifyTypes simplifyTypes
= [ resolveNamedTypes = [ resolveNamedTypes
] ]
-- | Turn named data types into their underlying types. -- | Turn named data types into their underlying types.
resolveNamedTypes :: Pass resolveNamedTypes :: PassOn A.Type
resolveNamedTypes resolveNamedTypes
= pass "Resolve user-defined types" = pass "Resolve user-defined types"
(Prop.agg_namesDone (Prop.agg_namesDone
@ -49,21 +49,9 @@ resolveNamedTypes
(\t -> do get >>= resolve >>= flatten >>= onCsNames (flatten <.< resolve) >>= put (\t -> do get >>= resolve >>= flatten >>= onCsNames (flatten <.< resolve) >>= put
resolve t >>= flatten) resolve t >>= flatten)
where where
-- Work-around for data types not being resolved:
onCsNames :: Transform A.NameDef -> Transform CompState
onCsNames f cs = do csNames' <- T.mapM f $ csNames cs
return $ cs { csNames = csNames' }
resolve :: PassType resolve :: PassType
resolve = applyDepthM doType resolve = applyDepthM doType
where where
doType :: A.Type -> PassM A.Type doType :: A.Type -> PassM A.Type
doType t@(A.UserDataType _) = underlyingType emptyMeta t doType t@(A.UserDataType _) = underlyingType emptyMeta t
doType t = return t doType t = return t
flatten :: PassType
flatten = applyDepthM doType
where
doType :: Transform A.Type
doType (A.Array dsA (A.Array dsB t)) = return $ A.Array (dsA++dsB) t
doType t = return t