Do not inline or apply rules on LHS of rules
[ghc.git] / compiler / simplCore / SimplMonad.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section[SimplMonad]{The simplifier Monad}
5 -}
6
7 module SimplMonad (
8 -- The monad
9 SimplM,
10 initSmpl, traceSmpl,
11 getSimplRules, getFamEnvs,
12
13 -- Unique supply
14 MonadUnique(..), newId,
15
16 -- Counting
17 SimplCount, tick, freeTick, checkedTick,
18 getSimplCount, zeroSimplCount, pprSimplCount,
19 plusSimplCount, isZeroSimplCount
20 ) where
21
22 import Id ( Id, mkSysLocal )
23 import Type ( Type )
24 import FamInstEnv ( FamInstEnv )
25 import CoreSyn ( RuleEnv(..) )
26 import UniqSupply
27 import DynFlags
28 import CoreMonad
29 import Outputable
30 import FastString
31 import MonadUtils
32 import ErrUtils
33 import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf )
34 import Control.Monad ( when, liftM, ap )
35
36 {-
37 ************************************************************************
38 * *
39 \subsection{Monad plumbing}
40 * *
41 ************************************************************************
42
43 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
44 (Command-line switches move around through the explicitly-passed SimplEnv.)
45 -}
46
47 newtype SimplM result
48 = SM { unSM :: SimplTopEnv -- Envt that does not change much
49 -> UniqSupply -- We thread the unique supply because
50 -- constantly splitting it is rather expensive
51 -> SimplCount
52 -> IO (result, UniqSupply, SimplCount)}
53 -- we only need IO here for dump output
54
55 data SimplTopEnv
56 = STE { st_flags :: DynFlags
57 , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run
58 , st_rules :: RuleEnv
59 , st_fams :: (FamInstEnv, FamInstEnv) }
60
61 initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
62 -> UniqSupply -- No init count; set to 0
63 -> Int -- Size of the bindings, used to limit
64 -- the number of ticks we allow
65 -> SimplM a
66 -> IO (a, SimplCount)
67
68 initSmpl dflags rules fam_envs us size m
69 = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
70 return (result, count)
71 where
72 env = STE { st_flags = dflags, st_rules = rules
73 , st_max_ticks = computeMaxTicks dflags size
74 , st_fams = fam_envs }
75
76 computeMaxTicks :: DynFlags -> Int -> IntWithInf
77 -- Compute the max simplifier ticks as
78 -- (base-size + pgm-size) * magic-multiplier * tick-factor/100
79 -- where
80 -- magic-multiplier is a constant that gives reasonable results
81 -- base-size is a constant to deal with size-zero programs
82 computeMaxTicks dflags size
83 = treatZeroAsInf $
84 fromInteger ((toInteger (size + base_size)
85 * toInteger (tick_factor * magic_multiplier))
86 `div` 100)
87 where
88 tick_factor = simplTickFactor dflags
89 base_size = 100
90 magic_multiplier = 40
91 -- MAGIC NUMBER, multiplies the simplTickFactor
92 -- We can afford to be generous; this is really
93 -- just checking for loops, and shouldn't usually fire
94 -- A figure of 20 was too small: see Trac #5539.
95
96 {-# INLINE thenSmpl #-}
97 {-# INLINE thenSmpl_ #-}
98 {-# INLINE returnSmpl #-}
99
100
101 instance Functor SimplM where
102 fmap = liftM
103
104 instance Applicative SimplM where
105 pure = returnSmpl
106 (<*>) = ap
107 (*>) = thenSmpl_
108
109 instance Monad SimplM where
110 (>>) = thenSmpl_
111 (>>=) = thenSmpl
112 return = returnSmpl
113
114 returnSmpl :: a -> SimplM a
115 returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
116
117 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
118 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
119
120 thenSmpl m k
121 = SM $ \st_env us0 sc0 -> do
122 (m_result, us1, sc1) <- unSM m st_env us0 sc0
123 unSM (k m_result) st_env us1 sc1
124
125 thenSmpl_ m k
126 = SM $ \st_env us0 sc0 -> do
127 (_, us1, sc1) <- unSM m st_env us0 sc0
128 unSM k st_env us1 sc1
129
130 -- TODO: this specializing is not allowed
131 -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
132 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
133 -- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
134
135 traceSmpl :: String -> SDoc -> SimplM ()
136 traceSmpl herald doc
137 = do { dflags <- getDynFlags
138 ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $
139 printOutputForUser dflags alwaysQualify $
140 hang (text herald) 2 doc }
141
142 {-
143 ************************************************************************
144 * *
145 \subsection{The unique supply}
146 * *
147 ************************************************************************
148 -}
149
150 instance MonadUnique SimplM where
151 getUniqueSupplyM
152 = SM (\_st_env us sc -> case splitUniqSupply us of
153 (us1, us2) -> return (us1, us2, sc))
154
155 getUniqueM
156 = SM (\_st_env us sc -> case takeUniqFromSupply us of
157 (u, us') -> return (u, us', sc))
158
159 getUniquesM
160 = SM (\_st_env us sc -> case splitUniqSupply us of
161 (us1, us2) -> return (uniqsFromSupply us1, us2, sc))
162
163 instance HasDynFlags SimplM where
164 getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
165
166 instance MonadIO SimplM where
167 liftIO m = SM $ \_ us sc -> do
168 x <- m
169 return (x, us, sc)
170
171 getSimplRules :: SimplM RuleEnv
172 getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
173
174 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
175 getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
176
177 newId :: FastString -> Type -> SimplM Id
178 newId fs ty = do uniq <- getUniqueM
179 return (mkSysLocal fs uniq ty)
180
181 {-
182 ************************************************************************
183 * *
184 \subsection{Counting up what we've done}
185 * *
186 ************************************************************************
187 -}
188
189 getSimplCount :: SimplM SimplCount
190 getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
191
192 tick :: Tick -> SimplM ()
193 tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
194 in sc' `seq` return ((), us, sc'))
195
196 checkedTick :: Tick -> SimplM ()
197 -- Try to take a tick, but fail if too many
198 checkedTick t
199 = SM (\st_env us sc -> if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
200 then pprPanic "Simplifier ticks exhausted" (msg sc)
201 else let sc' = doSimplTick (st_flags st_env) t sc
202 in sc' `seq` return ((), us, sc'))
203 where
204 msg sc = vcat [ ptext (sLit "When trying") <+> ppr t
205 , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)")
206 , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed")
207 , pp_details sc
208 , pprSimplCount sc ]
209 pp_details sc
210 | hasDetailedCounts sc = empty
211 | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats")
212
213
214 freeTick :: Tick -> SimplM ()
215 -- Record a tick, but don't add to the total tick count, which is
216 -- used to decide when nothing further has happened
217 freeTick t
218 = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
219 in sc' `seq` return ((), us, sc'))