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     ) where
  21
  22 import Id               ( Id, mkSysLocal )
  23 import Type             ( Type )
  24 import FamInstEnv       ( FamInstEnv )
  25 import Rules            ( RuleBase )
  26 import UniqSupply
  27 import DynFlags         ( DynFlags )
  28 import CoreMonad
  29 import FastString
  30 \end{code}
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{Monad plumbing}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
  39 (Command-line switches move around through the explicitly-passed SimplEnv.)
  40
  41 \begin{code}
  42 newtype SimplM result
  43   =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
  44                 -> UniqSupply   -- We thread the unique supply because
  45                                 -- constantly splitting it is rather expensive
  46                 -> SimplCount
  47                 -> (result, UniqSupply, SimplCount)}
  48
  49 data SimplTopEnv = STE  { st_flags :: DynFlags
  50                         , st_rules :: RuleBase
  51                         , st_fams  :: (FamInstEnv, FamInstEnv) }
  52 \end{code}
  53
  54 \begin{code}
  55 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
  56          -> UniqSupply          -- No init count; set to 0
  57          -> SimplM a
  58          -> (a, SimplCount)
  59
  60 initSmpl dflags rules fam_envs us m
  61   = case unSM m env us (zeroSimplCount dflags) of
  62         (result, _, count) -> (result, count)
  63   where
  64     env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
  65
  66 {-# INLINE thenSmpl #-}
  67 {-# INLINE thenSmpl_ #-}
  68 {-# INLINE returnSmpl #-}
  69
  70 instance Monad SimplM where
  71    (>>)   = thenSmpl_
  72    (>>=)  = thenSmpl
  73    return = returnSmpl
  74
  75 returnSmpl :: a -> SimplM a
  76 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
  77
  78 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
  79 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
  80
  81 thenSmpl m k
  82   = SM (\ st_env us0 sc0 ->
  83           case (unSM m st_env us0 sc0) of
  84                 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
  85
  86 thenSmpl_ m k
  87   = SM (\st_env us0 sc0 ->
  88          case (unSM m st_env us0 sc0) of
  89                 (_, us1, sc1) -> unSM k st_env us1 sc1)
  90
  91 -- TODO: this specializing is not allowed
  92 -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
  93 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
  94 -- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{The unique supply}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 instance MonadUnique SimplM where
 106     getUniqueSupplyM
 107        = SM (\_st_env us sc -> case splitUniqSupply us of
 108                                 (us1, us2) -> (us1, us2, sc))
 109
 110     getUniqueM
 111        = SM (\_st_env us sc -> case splitUniqSupply us of
 112                                 (us1, us2) -> (uniqFromSupply us1, us2, sc))
 113
 114     getUniquesM
 115         = SM (\_st_env us sc -> case splitUniqSupply us of
 116                                 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
 117
 118 getDOptsSmpl :: SimplM DynFlags
 119 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
 120
 121 getSimplRules :: SimplM RuleBase
 122 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
 123
 124 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
 125 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
 126
 127 newId :: FastString -> Type -> SimplM Id
 128 newId fs ty = do uniq <- getUniqueM
 129                  return (mkSysLocal fs uniq ty)
 130 \end{code}
 131
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{Counting up what we've done}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 \begin{code}
 140 getSimplCount :: SimplM SimplCount
 141 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
 142
 143 tick :: Tick -> SimplM ()
 144 tick t
 145    = SM (\_st_env us sc -> let sc' = doSimplTick t sc
 146                            in sc' `seq` ((), us, sc'))
 147
 148 freeTick :: Tick -> SimplM ()
 149 -- Record a tick, but don't add to the total tick count, which is
 150 -- used to decide when nothing further has happened
 151 freeTick t
 152    = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
 153                            in sc' `seq` ((), us, sc'))
 154 \end{code}