Compute demand signatures assuming idArity
[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, isId, 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 #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 -- Note [idArity for join points] in SimplUtils
191 arity = length (filter isId bndrs)
192 join_arity = length bndrs
193 details = JoinId join_arity
194 id_info = vanillaIdInfo `setArityInfo` arity
195 -- `setOccInfo` strongLoopBreaker
196
197 ; return (mkLocalVar details name join_id_ty id_info) }
198
199 {-
200 ************************************************************************
201 * *
202 \subsection{Counting up what we've done}
203 * *
204 ************************************************************************
205 -}
206
207 getSimplCount :: SimplM SimplCount
208 getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
209
210 tick :: Tick -> SimplM ()
211 tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
212 in sc' `seq` return ((), us, sc'))
213
214 checkedTick :: Tick -> SimplM ()
215 -- Try to take a tick, but fail if too many
216 checkedTick t
217 = SM (\st_env us sc ->
218 if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
219 then throwGhcExceptionIO $
220 PprProgramError "Simplifier ticks exhausted" (msg sc)
221 else let sc' = doSimplTick (st_flags st_env) t sc
222 in sc' `seq` return ((), us, sc'))
223 where
224 msg sc = vcat
225 [ text "When trying" <+> ppr t
226 , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
227 , space
228 , text "If you need to increase the limit substantially, please file a"
229 , text "bug report and indicate the factor you needed."
230 , space
231 , text "If GHC was unable to complete compilation even"
232 <+> text "with a very large factor"
233 , text "(a thousand or more), please consult the"
234 <+> doubleQuotes (text "Known bugs or infelicities")
235 , text "section in the Users Guide before filing a report. There are a"
236 , text "few situations unlikely to occur in practical programs for which"
237 , text "simplifier non-termination has been judged acceptable."
238 , space
239 , pp_details sc
240 , pprSimplCount sc ]
241 pp_details sc
242 | hasDetailedCounts sc = empty
243 | otherwise = text "To see detailed counts use -ddump-simpl-stats"
244
245
246 freeTick :: Tick -> SimplM ()
247 -- Record a tick, but don't add to the total tick count, which is
248 -- used to decide when nothing further has happened
249 freeTick t
250 = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
251 in sc' `seq` return ((), us, sc'))