Prepare source-tree for base-4.13 MFP bump
[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, newJoinId,
15
16 -- Counting
17 SimplCount, tick, freeTick, checkedTick,
18 getSimplCount, zeroSimplCount, pprSimplCount,
19 plusSimplCount, isZeroSimplCount
20 ) where
21
22 import GhcPrelude
23
24 import Var ( Var, isTyVar, mkLocalVar )
25 import Name ( mkSystemVarName )
26 import Id ( Id, mkSysLocalOrCoVar )
27 import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo )
28 import Type ( Type, mkLamTypes )
29 import FamInstEnv ( FamInstEnv )
30 import CoreSyn ( RuleEnv(..) )
31 import UniqSupply
32 import DynFlags
33 import CoreMonad
34 import Outputable
35 import FastString
36 import MonadUtils
37 import ErrUtils as Err
38 import Panic (throwGhcExceptionIO, GhcException (..))
39 import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf )
40 import Control.Monad ( liftM, ap )
41
42 {-
43 ************************************************************************
44 * *
45 \subsection{Monad plumbing}
46 * *
47 ************************************************************************
48
49 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
50 (Command-line switches move around through the explicitly-passed SimplEnv.)
51 -}
52
53 newtype SimplM result
54 = SM { unSM :: SimplTopEnv -- Envt that does not change much
55 -> UniqSupply -- We thread the unique supply because
56 -- constantly splitting it is rather expensive
57 -> SimplCount
58 -> IO (result, UniqSupply, SimplCount)}
59 -- we only need IO here for dump output
60
61 data SimplTopEnv
62 = STE { st_flags :: DynFlags
63 , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run
64 , st_rules :: RuleEnv
65 , st_fams :: (FamInstEnv, FamInstEnv) }
66
67 initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
68 -> UniqSupply -- No init count; set to 0
69 -> Int -- Size of the bindings, used to limit
70 -- the number of ticks we allow
71 -> SimplM a
72 -> IO (a, SimplCount)
73
74 initSmpl dflags rules fam_envs us size m
75 = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
76 return (result, count)
77 where
78 env = STE { st_flags = dflags, st_rules = rules
79 , st_max_ticks = computeMaxTicks dflags size
80 , st_fams = fam_envs }
81
82 computeMaxTicks :: DynFlags -> Int -> IntWithInf
83 -- Compute the max simplifier ticks as
84 -- (base-size + pgm-size) * magic-multiplier * tick-factor/100
85 -- where
86 -- magic-multiplier is a constant that gives reasonable results
87 -- base-size is a constant to deal with size-zero programs
88 computeMaxTicks dflags size
89 = treatZeroAsInf $
90 fromInteger ((toInteger (size + base_size)
91 * toInteger (tick_factor * magic_multiplier))
92 `div` 100)
93 where
94 tick_factor = simplTickFactor dflags
95 base_size = 100
96 magic_multiplier = 40
97 -- MAGIC NUMBER, multiplies the simplTickFactor
98 -- We can afford to be generous; this is really
99 -- just checking for loops, and shouldn't usually fire
100 -- A figure of 20 was too small: see Trac #5539.
101
102 {-# INLINE thenSmpl #-}
103 {-# INLINE thenSmpl_ #-}
104 {-# INLINE returnSmpl #-}
105
106
107 instance Functor SimplM where
108 fmap = liftM
109
110 instance Applicative SimplM where
111 pure = returnSmpl
112 (<*>) = ap
113 (*>) = thenSmpl_
114
115 instance Monad SimplM where
116 (>>) = (*>)
117 (>>=) = thenSmpl
118
119 returnSmpl :: a -> SimplM a
120 returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
121
122 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
123 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
124
125 thenSmpl m k
126 = SM $ \st_env us0 sc0 -> do
127 (m_result, us1, sc1) <- unSM m st_env us0 sc0
128 unSM (k m_result) st_env us1 sc1
129
130 thenSmpl_ m k
131 = SM $ \st_env us0 sc0 -> do
132 (_, us1, sc1) <- unSM m st_env us0 sc0
133 unSM k st_env us1 sc1
134
135 -- TODO: this specializing is not allowed
136 -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
137 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
138 -- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
139
140 traceSmpl :: String -> SDoc -> SimplM ()
141 traceSmpl herald doc
142 = do { dflags <- getDynFlags
143 ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
144 (hang (text herald) 2 doc) }
145
146 {-
147 ************************************************************************
148 * *
149 \subsection{The unique supply}
150 * *
151 ************************************************************************
152 -}
153
154 instance MonadUnique SimplM where
155 getUniqueSupplyM
156 = SM (\_st_env us sc -> case splitUniqSupply us of
157 (us1, us2) -> return (us1, us2, sc))
158
159 getUniqueM
160 = SM (\_st_env us sc -> case takeUniqFromSupply us of
161 (u, us') -> return (u, us', sc))
162
163 getUniquesM
164 = SM (\_st_env us sc -> case splitUniqSupply us of
165 (us1, us2) -> return (uniqsFromSupply us1, us2, sc))
166
167 instance HasDynFlags SimplM where
168 getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
169
170 instance MonadIO SimplM where
171 liftIO m = SM $ \_ us sc -> do
172 x <- m
173 return (x, us, sc)
174
175 getSimplRules :: SimplM RuleEnv
176 getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
177
178 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
179 getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
180
181 newId :: FastString -> Type -> SimplM Id
182 newId fs ty = do uniq <- getUniqueM
183 return (mkSysLocalOrCoVar fs uniq ty)
184
185 newJoinId :: [Var] -> Type -> SimplM Id
186 newJoinId bndrs body_ty
187 = do { uniq <- getUniqueM
188 ; let name = mkSystemVarName uniq (fsLit "$j")
189 join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes]
190 arity = length (filter (not . isTyVar) bndrs)
191 join_arity = length bndrs
192 details = JoinId join_arity
193 id_info = vanillaIdInfo `setArityInfo` arity
194 -- `setOccInfo` strongLoopBreaker
195
196 ; return (mkLocalVar details name join_id_ty id_info) }
197
198 {-
199 ************************************************************************
200 * *
201 \subsection{Counting up what we've done}
202 * *
203 ************************************************************************
204 -}
205
206 getSimplCount :: SimplM SimplCount
207 getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
208
209 tick :: Tick -> SimplM ()
210 tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
211 in sc' `seq` return ((), us, sc'))
212
213 checkedTick :: Tick -> SimplM ()
214 -- Try to take a tick, but fail if too many
215 checkedTick t
216 = SM (\st_env us sc ->
217 if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
218 then throwGhcExceptionIO $
219 PprProgramError "Simplifier ticks exhausted" (msg sc)
220 else let sc' = doSimplTick (st_flags st_env) t sc
221 in sc' `seq` return ((), us, sc'))
222 where
223 msg sc = vcat
224 [ text "When trying" <+> ppr t
225 , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
226 , space
227 , text "If you need to increase the limit substantially, please file a"
228 , text "bug report and indicate the factor you needed."
229 , space
230 , text "If GHC was unable to complete compilation even"
231 <+> text "with a very large factor"
232 , text "(a thousand or more), please consult the"
233 <+> doubleQuotes (text "Known bugs or infelicities")
234 , text "section in the Users Guide before filing a report. There are a"
235 , text "few situations unlikely to occur in practical programs for which"
236 , text "simplifier non-termination has been judged acceptable."
237 , space
238 , pp_details sc
239 , pprSimplCount sc ]
240 pp_details sc
241 | hasDetailedCounts sc = empty
242 | otherwise = text "To see detailed counts use -ddump-simpl-stats"
243
244
245 freeTick :: Tick -> SimplM ()
246 -- Record a tick, but don't add to the total tick count, which is
247 -- used to decide when nothing further has happened
248 freeTick t
249 = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
250 in sc' `seq` return ((), us, sc'))