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