2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
11 getDOptsSmpl, getSimplRules, getFamEnvs,
14 MonadUnique(..), newId,
17 SimplCount, tick, freeTick,
18 getSimplCount, zeroSimplCount, pprSimplCount,
19 plusSimplCount, isZeroSimplCount
22 import Id ( Id, mkSysLocal )
24 import FamInstEnv ( FamInstEnv )
25 import Rules ( RuleBase )
27 import DynFlags ( DynFlags )
32 %************************************************************************
34 \subsection{Monad plumbing}
36 %************************************************************************
38 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
39 (Command-line switches move around through the explicitly-passed SimplEnv.)
43 = SM { unSM :: SimplTopEnv -- Envt that does not change much
44 -> UniqSupply -- We thread the unique supply because
45 -- constantly splitting it is rather expensive
47 -> (result, UniqSupply, SimplCount)}
49 data SimplTopEnv = STE { st_flags :: DynFlags
50 , st_rules :: RuleBase
51 , st_fams :: (FamInstEnv, FamInstEnv) }
55 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
56 -> UniqSupply -- No init count; set to 0
60 initSmpl dflags rules fam_envs us m
61 = case unSM m env us (zeroSimplCount dflags) of
62 (result, _, count) -> (result, count)
64 env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
66 {-# INLINE thenSmpl #-}
67 {-# INLINE thenSmpl_ #-}
68 {-# INLINE returnSmpl #-}
70 instance Monad SimplM where
75 returnSmpl :: a -> SimplM a
76 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
78 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
79 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
82 = SM (\ st_env us0 sc0 ->
83 case (unSM m st_env us0 sc0) of
84 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
87 = SM (\st_env us0 sc0 ->
88 case (unSM m st_env us0 sc0) of
89 (_, us1, sc1) -> unSM k st_env us1 sc1)
91 -- TODO: this specializing is not allowed
92 -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
93 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
94 -- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
98 %************************************************************************
100 \subsection{The unique supply}
102 %************************************************************************
105 instance MonadUnique SimplM where
107 = SM (\_st_env us sc -> case splitUniqSupply us of
108 (us1, us2) -> (us1, us2, sc))
111 = SM (\_st_env us sc -> case splitUniqSupply us of
112 (us1, us2) -> (uniqFromSupply us1, us2, sc))
115 = SM (\_st_env us sc -> case splitUniqSupply us of
116 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
118 getDOptsSmpl :: SimplM DynFlags
119 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
121 getSimplRules :: SimplM RuleBase
122 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
124 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
125 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
127 newId :: FastString -> Type -> SimplM Id
128 newId fs ty = do uniq <- getUniqueM
129 return (mkSysLocal fs uniq ty)
133 %************************************************************************
135 \subsection{Counting up what we've done}
137 %************************************************************************
140 getSimplCount :: SimplM SimplCount
141 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
143 tick :: Tick -> SimplM ()
145 = SM (\_st_env us sc -> let sc' = doSimplTick t sc
146 in sc' `seq` ((), us, sc'))
148 freeTick :: Tick -> SimplM ()
149 -- Record a tick, but don't add to the total tick count, which is
150 -- used to decide when nothing further has happened
152 = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
153 in sc' `seq` ((), us, sc'))