never executed always true always false
1 {-# LANGUAGE PatternSynonyms #-}
2 {-
3 (c) The AQUA Project, Glasgow University, 1993-1998
4
5 \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
6 -}
7
8 module GHC.Core.Opt.Simplify.Monad (
9 -- The monad
10 SimplM,
11 initSmpl, traceSmpl,
12 getSimplRules, getFamEnvs, getOptCoercionOpts,
13
14 -- Unique supply
15 MonadUnique(..), newId, newJoinId,
16
17 -- Counting
18 SimplCount, tick, freeTick, checkedTick,
19 getSimplCount, zeroSimplCount, pprSimplCount,
20 plusSimplCount, isZeroSimplCount
21 ) where
22
23 import GHC.Prelude
24
25 import GHC.Types.Var ( Var, isId, mkLocalVar )
26 import GHC.Types.Name ( mkSystemVarName )
27 import GHC.Types.Id ( Id, mkSysLocalOrCoVar )
28 import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo )
29 import GHC.Core.Type ( Type, Mult )
30 import GHC.Core.FamInstEnv ( FamInstEnv )
31 import GHC.Core ( RuleEnv(..) )
32 import GHC.Core.Utils ( mkLamTypes )
33 import GHC.Core.Coercion.Opt
34 import GHC.Types.Unique.Supply
35 import GHC.Driver.Session
36 import GHC.Driver.Config
37 import GHC.Core.Opt.Monad
38 import GHC.Utils.Outputable
39 import GHC.Data.FastString
40 import GHC.Utils.Monad
41 import GHC.Utils.Logger as Logger
42 import GHC.Utils.Misc ( count )
43 import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..))
44 import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf )
45 import Control.Monad ( ap )
46 import GHC.Core.Multiplicity ( pattern Many )
47 import GHC.Exts( oneShot )
48
49 {-
50 ************************************************************************
51 * *
52 \subsection{Monad plumbing}
53 * *
54 ************************************************************************
55
56 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
57 (Command-line switches move around through the explicitly-passed SimplEnv.)
58 -}
59
60 newtype SimplM result
61 = SM' { unSM :: SimplTopEnv -- Envt that does not change much
62 -> SimplCount
63 -> IO (result, SimplCount)}
64 -- We only need IO here for dump output, but since we already have it
65 -- we might as well use it for uniques.
66
67 pattern SM :: (SimplTopEnv -> SimplCount
68 -> IO (result, SimplCount))
69 -> SimplM result
70 -- This pattern synonym makes the simplifier monad eta-expand,
71 -- which as a very beneficial effect on compiler performance
72 -- (worth a 1-2% reduction in bytes-allocated). See #18202.
73 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
74 pattern SM m <- SM' m
75 where
76 SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct)
77
78 data SimplTopEnv
79 = STE { st_flags :: DynFlags
80 , st_logger :: !Logger
81 , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run
82 , st_rules :: RuleEnv
83 , st_fams :: (FamInstEnv, FamInstEnv)
84
85 , st_co_opt_opts :: !OptCoercionOpts
86 -- ^ Coercion optimiser options
87 }
88
89 initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
90 -> Int -- Size of the bindings, used to limit
91 -- the number of ticks we allow
92 -> SimplM a
93 -> IO (a, SimplCount)
94
95 initSmpl logger dflags rules fam_envs size m
96 = do -- No init count; set to 0
97 let simplCount = zeroSimplCount dflags
98 (result, count) <- unSM m env simplCount
99 return (result, count)
100 where
101 env = STE { st_flags = dflags
102 , st_logger = logger
103 , st_rules = rules
104 , st_max_ticks = computeMaxTicks dflags size
105 , st_fams = fam_envs
106 , st_co_opt_opts = initOptCoercionOpts dflags
107 }
108
109 computeMaxTicks :: DynFlags -> Int -> IntWithInf
110 -- Compute the max simplifier ticks as
111 -- (base-size + pgm-size) * magic-multiplier * tick-factor/100
112 -- where
113 -- magic-multiplier is a constant that gives reasonable results
114 -- base-size is a constant to deal with size-zero programs
115 computeMaxTicks dflags size
116 = treatZeroAsInf $
117 fromInteger ((toInteger (size + base_size)
118 * toInteger (tick_factor * magic_multiplier))
119 `div` 100)
120 where
121 tick_factor = simplTickFactor dflags
122 base_size = 100
123 magic_multiplier = 40
124 -- MAGIC NUMBER, multiplies the simplTickFactor
125 -- We can afford to be generous; this is really
126 -- just checking for loops, and shouldn't usually fire
127 -- A figure of 20 was too small: see #5539.
128
129 {-# INLINE thenSmpl #-}
130 {-# INLINE thenSmpl_ #-}
131 {-# INLINE returnSmpl #-}
132 {-# INLINE mapSmpl #-}
133
134 instance Functor SimplM where
135 fmap = mapSmpl
136
137 instance Applicative SimplM where
138 pure = returnSmpl
139 (<*>) = ap
140 (*>) = thenSmpl_
141
142 instance Monad SimplM where
143 (>>) = (*>)
144 (>>=) = thenSmpl
145
146 mapSmpl :: (a -> b) -> SimplM a -> SimplM b
147 mapSmpl f m = thenSmpl m (returnSmpl . f)
148
149 returnSmpl :: a -> SimplM a
150 returnSmpl e = SM (\_st_env sc -> return (e, sc))
151
152 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
153 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
154
155 thenSmpl m k
156 = SM $ \st_env sc0 -> do
157 (m_result, sc1) <- unSM m st_env sc0
158 unSM (k m_result) st_env sc1
159
160 thenSmpl_ m k
161 = SM $ \st_env sc0 -> do
162 (_, sc1) <- unSM m st_env sc0
163 unSM k st_env sc1
164
165 -- TODO: this specializing is not allowed
166 -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
167 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
168 -- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
169
170 traceSmpl :: String -> SDoc -> SimplM ()
171 traceSmpl herald doc
172 = do logger <- getLogger
173 liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace"
174 FormatText
175 (hang (text herald) 2 doc)
176 {-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities]
177
178 {-
179 ************************************************************************
180 * *
181 \subsection{The unique supply}
182 * *
183 ************************************************************************
184 -}
185
186 -- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
187 simplMask :: Char
188 simplMask = 's'
189
190 instance MonadUnique SimplM where
191 getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask
192 getUniqueM = liftIO $ uniqFromMask simplMask
193
194 instance HasDynFlags SimplM where
195 getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc))
196
197 instance HasLogger SimplM where
198 getLogger = SM (\st_env sc -> return (st_logger st_env, sc))
199
200 instance MonadIO SimplM where
201 liftIO m = SM $ \_ sc -> do
202 x <- m
203 return (x, sc)
204
205 getSimplRules :: SimplM RuleEnv
206 getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))
207
208 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
209 getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))
210
211 getOptCoercionOpts :: SimplM OptCoercionOpts
212 getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))
213
214 newId :: FastString -> Mult -> Type -> SimplM Id
215 newId fs w ty = do uniq <- getUniqueM
216 return (mkSysLocalOrCoVar fs uniq w ty)
217
218 newJoinId :: [Var] -> Type -> SimplM Id
219 newJoinId bndrs body_ty
220 = do { uniq <- getUniqueM
221 ; let name = mkSystemVarName uniq (fsLit "$j")
222 join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes]
223 arity = count isId bndrs
224 -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core
225 join_arity = length bndrs
226 details = JoinId join_arity
227 id_info = vanillaIdInfo `setArityInfo` arity
228 -- `setOccInfo` strongLoopBreaker
229
230 ; return (mkLocalVar details name Many join_id_ty id_info) }
231
232 {-
233 ************************************************************************
234 * *
235 \subsection{Counting up what we've done}
236 * *
237 ************************************************************************
238 -}
239
240 getSimplCount :: SimplM SimplCount
241 getSimplCount = SM (\_st_env sc -> return (sc, sc))
242
243 tick :: Tick -> SimplM ()
244 tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc
245 in sc' `seq` return ((), sc'))
246
247 checkedTick :: Tick -> SimplM ()
248 -- Try to take a tick, but fail if too many
249 checkedTick t
250 = SM (\st_env sc ->
251 if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
252 then throwGhcExceptionIO $
253 PprProgramError "Simplifier ticks exhausted" (msg sc)
254 else let sc' = doSimplTick (st_flags st_env) t sc
255 in sc' `seq` return ((), sc'))
256 where
257 msg sc = vcat
258 [ text "When trying" <+> ppr t
259 , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
260 , space
261 , text "In addition try adjusting -funfolding-case-threshold=N and"
262 , text "-funfolding-case-scaling=N for the module in question."
263 , text "Using threshold=1 and scaling=5 should break most inlining loops."
264 , space
265 , text "If you need to increase the tick factor substantially, while also"
266 , text "adjusting unfolding parameters please file a bug report and"
267 , text "indicate the factor you needed."
268 , space
269 , text "If GHC was unable to complete compilation even"
270 <+> text "with a very large factor"
271 , text "(a thousand or more), please consult the"
272 <+> doubleQuotes (text "Known bugs or infelicities")
273 , text "section in the Users Guide before filing a report. There are a"
274 , text "few situations unlikely to occur in practical programs for which"
275 , text "simplifier non-termination has been judged acceptable."
276 , space
277 , pp_details sc
278 , pprSimplCount sc ]
279 pp_details sc
280 | hasDetailedCounts sc = empty
281 | otherwise = text "To see detailed counts use -ddump-simpl-stats"
282
283
284 freeTick :: Tick -> SimplM ()
285 -- Record a tick, but don't add to the total tick count, which is
286 -- used to decide when nothing further has happened
287 freeTick t
288 = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc
289 in sc' `seq` return ((), sc'))