SimplMonad.lhs 7.59 KB
Newer Older
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1 2 3 4 5 6 7
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}

\begin{code}
module SimplMonad (
8 9
        -- The monad
        SimplM,
10
        initSmpl, traceSmpl,
11
        getSimplRules, getFamEnvs,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
12 13 14 15

        -- Unique supply
        MonadUnique(..), newId,

16 17 18
        -- Counting
        SimplCount, tick, freeTick, checkedTick,
        getSimplCount, zeroSimplCount, pprSimplCount,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
19 20 21
        plusSimplCount, isZeroSimplCount
    ) where

22
import Id               ( Id, mkSysLocal )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
23
import Type             ( Type )
24 25
import FamInstEnv       ( FamInstEnv )
import Rules            ( RuleBase )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
26
import UniqSupply
27
import DynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
28 29 30
import CoreMonad
import Outputable
import FastString
pcapriotti's avatar
pcapriotti committed
31
import MonadUtils
32
import ErrUtils
Austin Seipp's avatar
Austin Seipp committed
33
import Control.Monad       ( when, liftM, ap )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
34 35 36
\end{code}

%************************************************************************
37
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
38
\subsection{Monad plumbing}
39
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
40 41 42 43 44 45 46
%************************************************************************

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
47 48 49 50 51
  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
                -> UniqSupply   -- We thread the unique supply because
                                -- constantly splitting it is rather expensive
                -> SimplCount
                -> IO (result, UniqSupply, SimplCount)}
pcapriotti's avatar
pcapriotti committed
52
  -- we only need IO here for dump output
Simon Peyton Jones's avatar
Simon Peyton Jones committed
53

54 55 56 57 58 59
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) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
60 61 62
\end{code}

\begin{code}
63 64 65
initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
         -> UniqSupply          -- No init count; set to 0
         -> Int                 -- Size of the bindings, used to limit
66
                                -- the number of ticks we allow
67 68
         -> SimplM a
         -> IO (a, SimplCount)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
69 70

initSmpl dflags rules fam_envs us size m
pcapriotti's avatar
pcapriotti committed
71 72
  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
       return (result, count)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73
  where
74
    env = STE { st_flags = dflags, st_rules = rules
75
              , st_max_ticks = computeMaxTicks dflags size
76 77 78 79 80
              , st_fams = fam_envs }

computeMaxTicks :: DynFlags -> Int -> Int
-- Compute the max simplifier ticks as
--     (base-size + pgm-size) * magic-multiplier * tick-factor/100
81
-- where
82 83 84 85 86 87 88
--    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
89
    tick_factor      = simplTickFactor dflags
90
    base_size        = 100
91
    magic_multiplier = 40
92 93 94 95
        -- 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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
96 97 98 99 100

{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}

Austin Seipp's avatar
Austin Seipp committed
101 102 103 104 105 106 107 108

instance Functor SimplM where
    fmap = liftM

instance Applicative SimplM where
    pure = return
    (<*>) = ap

Simon Peyton Jones's avatar
Simon Peyton Jones committed
109 110 111 112 113 114
instance Monad SimplM where
   (>>)   = thenSmpl_
   (>>=)  = thenSmpl
   return = returnSmpl

returnSmpl :: a -> SimplM a
pcapriotti's avatar
pcapriotti committed
115
returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
116 117 118 119

thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b

pcapriotti's avatar
pcapriotti committed
120 121 122 123
thenSmpl m k
  = SM $ \st_env us0 sc0 -> do
      (m_result, us1, sc1) <- unSM m st_env us0 sc0
      unSM (k m_result) st_env us1 sc1
Simon Peyton Jones's avatar
Simon Peyton Jones committed
124

pcapriotti's avatar
pcapriotti committed
125 126 127 128
thenSmpl_ m k
  = SM $ \st_env us0 sc0 -> do
      (_, us1, sc1) <- unSM m st_env us0 sc0
      unSM k st_env us1 sc1
Simon Peyton Jones's avatar
Simon Peyton Jones committed
129 130 131 132 133

-- 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]) #-}
134 135 136 137 138 139 140

traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl herald doc
  = do { dflags <- getDynFlags
       ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $ 
         printInfoForUser dflags alwaysQualify $
         hang (text herald) 2 doc }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
141 142 143 144
\end{code}


%************************************************************************
145
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
146
\subsection{The unique supply}
147
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
148 149 150 151 152 153
%************************************************************************

\begin{code}
instance MonadUnique SimplM where
    getUniqueSupplyM
       = SM (\_st_env us sc -> case splitUniqSupply us of
pcapriotti's avatar
pcapriotti committed
154
                                (us1, us2) -> return (us1, us2, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
155 156

    getUniqueM
157 158
       = SM (\_st_env us sc -> case takeUniqFromSupply us of
                                (u, us') -> return (u, us', sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
159 160 161

    getUniquesM
        = SM (\_st_env us sc -> case splitUniqSupply us of
pcapriotti's avatar
pcapriotti committed
162
                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
163

164
instance HasDynFlags SimplM where
pcapriotti's avatar
pcapriotti committed
165
    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
166

pcapriotti's avatar
pcapriotti committed
167 168 169 170 171
instance MonadIO SimplM where
    liftIO m = SM $ \_ us sc -> do
      x <- m
      return (x, us, sc)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
172
getSimplRules :: SimplM RuleBase
pcapriotti's avatar
pcapriotti committed
173
getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
174 175

getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
pcapriotti's avatar
pcapriotti committed
176
getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
177 178 179 180 181 182 183 184

newId :: FastString -> Type -> SimplM Id
newId fs ty = do uniq <- getUniqueM
                 return (mkSysLocal fs uniq ty)
\end{code}


%************************************************************************
185
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
186
\subsection{Counting up what we've done}
187
%*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188 189 190 191
%************************************************************************

\begin{code}
getSimplCount :: SimplM SimplCount
pcapriotti's avatar
pcapriotti committed
192
getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
193 194

tick :: Tick -> SimplM ()
195 196
tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
                              in sc' `seq` return ((), us, sc'))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
197 198 199

checkedTick :: Tick -> SimplM ()
-- Try to take a tick, but fail if too many
200
checkedTick t
Simon Peyton Jones's avatar
Simon Peyton Jones committed
201 202
  = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc
                         then pprPanic "Simplifier ticks exhausted" (msg sc)
203
                         else let sc' = doSimplTick (st_flags st_env) t sc
pcapriotti's avatar
pcapriotti committed
204
                              in sc' `seq` return ((), us, sc'))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
205 206 207 208 209 210 211 212 213
  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")
214

Simon Peyton Jones's avatar
Simon Peyton Jones committed
215 216 217 218

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
219
freeTick t
Simon Peyton Jones's avatar
Simon Peyton Jones committed
220
   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
pcapriotti's avatar
pcapriotti committed
221
                           in sc' `seq` return ((), us, sc'))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
222
\end{code}