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@(MaxSimplifierIterations lvl)
 205         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 206     mk_assoc_elem k
 207         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 208
 209     -- cannot have duplicates if we are going to use the array thing
 210     rm_dups switches_so_far switch
 211       = if switch `is_elem` switches_so_far
 212         then switches_so_far
 213         else switch : switches_so_far
 214       where
 215         _  `is_elem` []     = False
 216         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 217                             || sw `is_elem` ss
 218 \end{code}
 219
 220 \begin{code}
 221 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 222 getSimplIntSwitch chkr switch
 223   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 224
 225 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 226
 227 switchIsOn lookup_fn switch
 228   = case (lookup_fn switch) of
 229       SwBool False -> False
 230       _            -> True
 231
 232 intSwitchSet :: (switch -> SwitchResult)
 233              -> (Int -> switch)
 234              -> Maybe Int
 235
 236 intSwitchSet lookup_fn switch
 237   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 238       SwInt int -> Just int
 239       _         -> Nothing
 240 \end{code}
 241
 242
 243 These things behave just like enumeration types.
 244
 245 \begin{code}
 246 instance Eq SimplifierSwitch where
 247     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 248
 249 instance Ord SimplifierSwitch where
 250     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 251     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 252
 253
 254 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
 255 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
 256 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
 257
 258 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 259
 260 lAST_SIMPL_SWITCH_TAG :: Int
 261 lAST_SIMPL_SWITCH_TAG = 2
 262 \end{code}
 263