← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/simplCore/SimplMonad.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/simplCore/SimplMonad.lhs
 
1
%
 
2
% (c) The AQUA Project, Glasgow University, 1993-1998
 
3
%
 
4
\section[SimplMonad]{The simplifier Monad}
 
5
 
 
6
\begin{code}
 
7
module SimplMonad (
 
8
        -- The monad
 
9
        SimplM,
 
10
        initSmpl,
 
11
        getDOptsSmpl, getSimplRules, getFamEnvs,
 
12
 
 
13
        -- Unique supply
 
14
        MonadUnique(..), newId,
 
15
 
 
16
        -- Counting
 
17
        SimplCount, tick, freeTick,
 
18
        getSimplCount, zeroSimplCount, pprSimplCount, 
 
19
        plusSimplCount, isZeroSimplCount,
 
20
 
 
21
        -- Switch checker
 
22
        SwitchChecker, SwitchResult(..), getSimplIntSwitch,
 
23
        isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
 
24
    ) where
 
25
 
 
26
import Id               ( Id, mkSysLocal )
 
27
import Type             ( Type )
 
28
import FamInstEnv       ( FamInstEnv )
 
29
import Rules            ( RuleBase )
 
30
import UniqSupply
 
31
import DynFlags         ( DynFlags )
 
32
import Maybes           ( expectJust )
 
33
import CoreMonad
 
34
import FastString
 
35
import Outputable
 
36
import FastTypes
 
37
 
 
38
import Data.Array
 
39
import Data.Array.Base (unsafeAt)
 
40
\end{code}
 
41
 
 
42
%************************************************************************
 
43
%*                                                                      *
 
44
\subsection{Monad plumbing}
 
45
%*                                                                      *
 
46
%************************************************************************
 
47
 
 
48
For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 
49
(Command-line switches move around through the explicitly-passed SimplEnv.)
 
50
 
 
51
\begin{code}
 
52
newtype SimplM result
 
53
  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
 
54
                -> UniqSupply   -- We thread the unique supply because
 
55
                                -- constantly splitting it is rather expensive
 
56
                -> SimplCount 
 
57
                -> (result, UniqSupply, SimplCount)}
 
58
 
 
59
data SimplTopEnv = STE  { st_flags :: DynFlags 
 
60
                        , st_rules :: RuleBase
 
61
                        , st_fams  :: (FamInstEnv, FamInstEnv) }
 
62
\end{code}
 
63
 
 
64
\begin{code}
 
65
initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) 
 
66
         -> UniqSupply          -- No init count; set to 0
 
67
         -> SimplM a
 
68
         -> (a, SimplCount)
 
69
 
 
70
initSmpl dflags rules fam_envs us m
 
71
  = case unSM m env us (zeroSimplCount dflags) of 
 
72
        (result, _, count) -> (result, count)
 
73
  where
 
74
    env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
 
75
 
 
76
{-# INLINE thenSmpl #-}
 
77
{-# INLINE thenSmpl_ #-}
 
78
{-# INLINE returnSmpl #-}
 
79
 
 
80
instance Monad SimplM where
 
81
   (>>)   = thenSmpl_
 
82
   (>>=)  = thenSmpl
 
83
   return = returnSmpl
 
84
 
 
85
returnSmpl :: a -> SimplM a
 
86
returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
 
87
 
 
88
thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 
89
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 
90
 
 
91
thenSmpl m k 
 
92
  = SM (\ st_env us0 sc0 ->
 
93
          case (unSM m st_env us0 sc0) of 
 
94
                (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
 
95
 
 
96
thenSmpl_ m k 
 
97
  = SM (\st_env us0 sc0 ->
 
98
         case (unSM m st_env us0 sc0) of 
 
99
                (_, us1, sc1) -> unSM k st_env us1 sc1)
 
100
 
 
101
-- TODO: this specializing is not allowed
 
102
-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
 
103
-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
 
104
-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
 
105
\end{code}
 
106
 
 
107
 
 
108
%************************************************************************
 
109
%*                                                                      *
 
110
\subsection{The unique supply}
 
111
%*                                                                      *
 
112
%************************************************************************
 
113
 
 
114
\begin{code}
 
115
instance MonadUnique SimplM where
 
116
    getUniqueSupplyM
 
117
       = SM (\_st_env us sc -> case splitUniqSupply us of
 
118
                                (us1, us2) -> (us1, us2, sc))
 
119
 
 
120
    getUniqueM
 
121
       = SM (\_st_env us sc -> case splitUniqSupply us of
 
122
                                (us1, us2) -> (uniqFromSupply us1, us2, sc))
 
123
 
 
124
    getUniquesM
 
125
        = SM (\_st_env us sc -> case splitUniqSupply us of
 
126
                                (us1, us2) -> (uniqsFromSupply us1, us2, sc))
 
127
 
 
128
getDOptsSmpl :: SimplM DynFlags
 
129
getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
 
130
 
 
131
getSimplRules :: SimplM RuleBase
 
132
getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
 
133
 
 
134
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
 
135
getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
 
136
 
 
137
newId :: FastString -> Type -> SimplM Id
 
138
newId fs ty = do uniq <- getUniqueM
 
139
                 return (mkSysLocal fs uniq ty)
 
140
\end{code}
 
141
 
 
142
 
 
143
%************************************************************************
 
144
%*                                                                      *
 
145
\subsection{Counting up what we've done}
 
146
%*                                                                      *
 
147
%************************************************************************
 
148
 
 
149
\begin{code}
 
150
getSimplCount :: SimplM SimplCount
 
151
getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
 
152
 
 
153
tick :: Tick -> SimplM ()
 
154
tick t 
 
155
   = SM (\_st_env us sc -> let sc' = doSimplTick t sc 
 
156
                           in sc' `seq` ((), us, sc'))
 
157
 
 
158
freeTick :: Tick -> SimplM ()
 
159
-- Record a tick, but don't add to the total tick count, which is
 
160
-- used to decide when nothing further has happened
 
161
freeTick t 
 
162
   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
 
163
                           in sc' `seq` ((), us, sc'))
 
164
\end{code}
 
165
 
 
166
 
 
167
%************************************************************************
 
168
%*                                                                      *
 
169
\subsubsection{Command-line switches}
 
170
%*                                                                      *
 
171
%************************************************************************
 
172
 
 
173
\begin{code}
 
174
type SwitchChecker = SimplifierSwitch -> SwitchResult
 
175
 
 
176
data SwitchResult
 
177
  = SwBool      Bool            -- on/off
 
178
  | SwString    FastString      -- nothing or a String
 
179
  | SwInt       Int             -- nothing or an Int
 
180
 
 
181
allOffSwitchChecker :: SwitchChecker
 
182
allOffSwitchChecker _ = SwBool False
 
183
 
 
184
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 
185
isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 
186
                                        -- in the list; defaults right at the end.
 
187
  = let
 
188
        tidied_on_switches = foldl rm_dups [] on_switches
 
189
                -- The fold*l* ensures that we keep the latest switches;
 
190
                -- ie the ones that occur earliest in the list.
 
191
 
 
192
        sw_tbl :: Array Int SwitchResult
 
193
        sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 
194
                        all_undefined)
 
195
                 // defined_elems
 
196
 
 
197
        all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 
198
 
 
199
        defined_elems = map mk_assoc_elem tidied_on_switches
 
200
    in
 
201
    -- (avoid some unboxing, bounds checking, and other horrible things:)
 
202
    \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
 
203
  where
 
204
    mk_assoc_elem k
 
205
        = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 
206
 
 
207
    -- cannot have duplicates if we are going to use the array thing
 
208
    rm_dups switches_so_far switch
 
209
      = if switch `is_elem` switches_so_far
 
210
        then switches_so_far
 
211
        else switch : switches_so_far
 
212
      where
 
213
        _  `is_elem` []     = False
 
214
        sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 
215
                            || sw `is_elem` ss
 
216
\end{code}
 
217
 
 
218
\begin{code}
 
219
getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 
220
getSimplIntSwitch chkr switch
 
221
  = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 
222
 
 
223
switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 
224
 
 
225
switchIsOn lookup_fn switch
 
226
  = case (lookup_fn switch) of
 
227
      SwBool False -> False
 
228
      _            -> True
 
229
 
 
230
intSwitchSet :: (switch -> SwitchResult)
 
231
             -> (Int -> switch)
 
232
             -> Maybe Int
 
233
 
 
234
intSwitchSet lookup_fn switch
 
235
  = case (lookup_fn (switch (panic "intSwitchSet"))) of
 
236
      SwInt int -> Just int
 
237
      _         -> Nothing
 
238
\end{code}
 
239
 
 
240
 
 
241
These things behave just like enumeration types.
 
242
 
 
243
\begin{code}
 
244
instance Eq SimplifierSwitch where
 
245
    a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 
246
 
 
247
instance Ord SimplifierSwitch where
 
248
    a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 
249
    a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 
250
 
 
251
 
 
252
tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
 
253
tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(1)
 
254
 
 
255
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 
256
 
 
257
lAST_SIMPL_SWITCH_TAG :: Int
 
258
lAST_SIMPL_SWITCH_TAG = 2
 
259
\end{code}
 
260