ghc/compiler/simplCore/SimplMonad.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplMonad]{The simplifier Monad}
   5
   6 \begin{code}
   7 module SimplMonad (
   8         SmplM,
   9         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
  10         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  11
  12         -- Unique supply
  13         getUniqueSmpl, getUniquesSmpl,
  14
  15         -- Counting
  16         SimplCount{-abstract-}, TickType(..), tick, tickN, tickUnfold,
  17         simplCount, detailedSimplCount,
  18         zeroSimplCount, showSimplCount, combineSimplCounts
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import Id               ( GenId, mkSysLocal, mkIdWithNewUniq, Id )
  24 import SimplEnv
  25 import SrcLoc           ( noSrcLoc )
  26 import TyVar            ( TyVar )
  27 import Type             ( Type )
  28 import UniqSupply       ( getUnique, getUniques, splitUniqSupply,
  29                           UniqSupply
  30                         )
  31 import Unique           ( Unique )
  32 import Util             ( zipWithEqual, Eager, appEager )
  33 import Outputable
  34 import Ix
  35
  36 infixr 9  `thenSmpl`, `thenSmpl_`
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection{Monad plumbing}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
  46 (Command-line switches move around through the explicitly-passed SimplEnv.)
  47
  48 \begin{code}
  49 type SmplM result
  50   = UniqSupply
  51   -> SimplCount    -- things being threaded
  52   -> (result, SimplCount)
  53 \end{code}
  54
  55 \begin{code}
  56 initSmpl :: UniqSupply -- no init count; set to 0
  57           -> SmplM a
  58           -> (a, SimplCount)
  59
  60 initSmpl us m = m us zeroSimplCount
  61
  62 {-# INLINE thenSmpl #-}
  63 {-# INLINE thenSmpl_ #-}
  64 {-# INLINE returnSmpl #-}
  65
  66 returnSmpl :: a -> SmplM a
  67 returnSmpl e us sc = (e, sc)
  68
  69 thenSmpl  :: SmplM a -> (a -> SmplM b) -> SmplM b
  70 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
  71
  72 thenSmpl m k us sc0
  73   = case splitUniqSupply us of { (s1, s2) ->
  74     case (m s1 sc0)         of { (m_result, sc1) ->
  75     k m_result s2 sc1 }}
  76
  77 thenSmpl_ m k us sc0
  78   = case splitUniqSupply us of { (s1, s2) ->
  79     case (m s1 sc0)         of { (_, sc1) ->
  80     k s2 sc1 }}
  81
  82 mapSmpl         :: (a -> SmplM b) -> [a] -> SmplM [b]
  83 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
  84
  85 mapSmpl f [] = returnSmpl []
  86 mapSmpl f (x:xs)
  87   = f x             `thenSmpl` \ x'  ->
  88     mapSmpl f xs    `thenSmpl` \ xs' ->
  89     returnSmpl (x':xs')
  90
  91 mapAndUnzipSmpl f [] = returnSmpl ([],[])
  92 mapAndUnzipSmpl f (x:xs)
  93   = f x                     `thenSmpl` \ (r1,  r2)  ->
  94     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
  95     returnSmpl (r1:rs1, r2:rs2)
  96
  97 mapAccumLSmpl f acc []     = returnSmpl (acc, [])
  98 mapAccumLSmpl f acc (x:xs) = f acc x    `thenSmpl` \ (acc', x') ->
  99                              mapAccumLSmpl f acc' xs    `thenSmpl` \ (acc'', xs') ->
 100                              returnSmpl (acc'', x':xs')
 101
 102 getUniqueSmpl :: SmplM Unique
 103 getUniqueSmpl us sc = (getUnique us, sc)
 104
 105 getUniquesSmpl :: Int -> SmplM [Unique]
 106 getUniquesSmpl n us sc = (getUniques n us, sc)
 107 \end{code}
 108
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{Counting up what we've done}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 The assoc list isn't particularly costly, because we only use
 117 the number of ticks in ``real life.''
 118
 119 The right thing to do, if you want that to go fast, is thread
 120 a mutable array through @SimplM@.
 121
 122 \begin{code}
 123 data SimplCount
 124   = SimplCount  FAST_INT            -- number of ticks
 125                 [(TickType, Int)]   -- assoc list of all diff kinds of ticks
 126                 UnfoldingHistory
 127
 128 type UnfoldingHistory = (Int,           -- N
 129                          [(Id,Int)],    -- Last N unfoldings
 130                          [(Id,Int)])    -- The MaxUnfoldHistory unfoldings before that
 131
 132 data TickType
 133   = UnfoldingDone    | MagicUnfold      | ConReused
 134   | CaseFloatFromLet | CaseOfCase
 135   | LetFloatFromLet  | LetFloatFromCase
 136   | KnownBranch      | Let2Case
 137   | CaseMerge        | CaseElim
 138   | CaseIdentity
 139   | AtomicRhs   -- Rhs of a let-expression was an atom
 140   | EtaExpansion
 141   | CaseOfError
 142   | TyBetaReduction
 143   | BetaReduction
 144   | SpecialisationDone
 145   {- BEGIN F/B ENTRIES -}
 146   -- the 8 rules
 147   | FoldrBuild          -- foldr f z (build g) ==>
 148   | FoldrAugment        -- foldr f z (augment g z) ==>
 149   | Foldr_Nil           -- foldr f z [] ==>
 150   | Foldr_List          -- foldr f z (x:...) ==>
 151
 152   | FoldlBuild          -- foldl f z (build g) ==>
 153   | FoldlAugment        -- foldl f z (augment g z) ==>
 154   | Foldl_Nil           -- foldl f z [] ==>
 155   | Foldl_List          -- foldl f z (x:...) ==>
 156
 157   | Foldr_Cons_Nil      -- foldr (:) [] => id
 158   | Foldr_Cons          -- foldr (:) => flip (++)
 159
 160   | Str_FoldrStr        -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
 161   | Str_UnpackCons      -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
 162   | Str_UnpackNil       -- unpackAppendPS__ [] "hello" => "hello"
 163   {- END F/B ENTRIES -}
 164   deriving (Eq, Ord, Ix)
 165
 166 instance Text TickType where
 167     showsPrec p UnfoldingDone   = showString "UnfoldingDone    "
 168     showsPrec p MagicUnfold     = showString "MagicUnfold      "
 169     showsPrec p ConReused       = showString "ConReused        "
 170     showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
 171     showsPrec p CaseOfCase      = showString "CaseOfCase       "
 172     showsPrec p LetFloatFromLet = showString "LetFloatFromLet  "
 173     showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
 174     showsPrec p KnownBranch     = showString "KnownBranch      "
 175     showsPrec p Let2Case        = showString "Let2Case         "
 176     showsPrec p CaseMerge       = showString "CaseMerge        "
 177     showsPrec p CaseElim        = showString "CaseElim         "
 178     showsPrec p CaseIdentity    = showString "CaseIdentity     "
 179     showsPrec p AtomicRhs       = showString "AtomicRhs        "
 180     showsPrec p EtaExpansion    = showString "EtaExpansion     "
 181     showsPrec p CaseOfError     = showString "CaseOfError      "
 182     showsPrec p TyBetaReduction = showString "TyBetaReduction  "
 183     showsPrec p BetaReduction   = showString "BetaReduction    "
 184     showsPrec p SpecialisationDone
 185                                 = showString "Specialisation   "
 186
 187         -- Foldr/Build Stuff:
 188     showsPrec p FoldrBuild      = showString "FoldrBuild       "
 189     showsPrec p FoldrAugment    = showString "FoldrAugment     "
 190     showsPrec p Foldr_Nil       = showString "Foldr_Nil        "
 191     showsPrec p Foldr_List      = showString "Foldr_List       "
 192
 193     showsPrec p FoldlBuild      = showString "FoldlBuild       "
 194     showsPrec p FoldlAugment    = showString "FoldlAugment     "
 195     showsPrec p Foldl_Nil       = showString "Foldl_Nil        "
 196     showsPrec p Foldl_List      = showString "Foldl_List       "
 197
 198     showsPrec p Foldr_Cons_Nil  = showString "Foldr_Cons_Nil   "
 199     showsPrec p Foldr_Cons      = showString "Foldr_Cons       "
 200
 201     showsPrec p Str_FoldrStr    = showString "Str_FoldrStr     "
 202     showsPrec p Str_UnpackCons  = showString "Str_UnpackCons   "
 203     showsPrec p Str_UnpackNil   = showString "Str_UnpackNil    "
 204
 205 showSimplCount :: SimplCount -> String
 206
 207 showSimplCount (SimplCount _ stuff (_, unf1, unf2))
 208   = shw stuff ++ "\nMost recent unfoldings: " ++ showSDoc (ppr (reverse unf2 ++ reverse unf1))
 209   where
 210     shw []          = ""
 211     shw ((t,n):tns) | n /= 0    = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
 212                     | otherwise = shw tns
 213
 214 zeroSimplCount :: SimplCount
 215 zeroSimplCount
 216   = SimplCount ILIT(0) stuff (0, [], [])
 217   where
 218     stuff =
 219       [ (UnfoldingDone, 0),
 220         (MagicUnfold, 0),
 221         (ConReused, 0),
 222         (CaseFloatFromLet, 0),
 223         (CaseOfCase, 0),
 224         (LetFloatFromLet, 0),
 225         (LetFloatFromCase, 0),
 226         (KnownBranch, 0),
 227         (Let2Case, 0),
 228         (CaseMerge, 0),
 229         (CaseElim, 0),
 230         (CaseIdentity, 0),
 231         (AtomicRhs, 0),
 232         (EtaExpansion, 0),
 233         (CaseOfError, 0),
 234         (TyBetaReduction,0),
 235         (BetaReduction,0),
 236         (SpecialisationDone,0),
 237         -- Foldr/Build Stuff:
 238         (FoldrBuild, 0),
 239         (FoldrAugment, 0),
 240         (Foldr_Nil, 0),
 241         (Foldr_List, 0),
 242         (FoldlBuild, 0),
 243         (FoldlAugment, 0),
 244         (Foldl_Nil, 0),
 245         (Foldl_List, 0),
 246         (Foldr_Cons_Nil, 0),
 247         (Foldr_Cons, 0),
 248
 249         (Str_FoldrStr, 0),
 250         (Str_UnpackCons, 0),
 251         (Str_UnpackNil, 0) ]
 252 --
 253 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
 254 --        [ i := 0 | i <- indices zeroSimplCount ]
 255 \end{code}
 256
 257 Counting-related monad functions:
 258 \begin{code}
 259 tick :: TickType -> SmplM ()
 260
 261 tick tick_type us (SimplCount n stuff unf)
 262   = -- pprTrace "Tick: " (text (show tick_type)) $
 263 #ifdef OMIT_SIMPL_COUNTS
 264     ((), SimplCount (n _ADD_ ILIT(1) stuff unf))                    stuff -- don't change anything
 265 #else
 266     new_stuff `seqL`
 267     ((), SimplCount (n _ADD_ ILIT(1)) new_stuff unf)
 268   where
 269     new_stuff = inc_tick tick_type ILIT(1) stuff
 270 #endif
 271
 272 maxUnfoldHistory :: Int
 273 maxUnfoldHistory = 20
 274
 275 tickUnfold :: Id -> SmplM ()
 276 tickUnfold id us (SimplCount n stuff (n_unf, unf1, unf2))
 277   = -- pprTrace "Unfolding: " (ppr id) $
 278     new_stuff `seqL`
 279     new_unf   `seqTriple`
 280     ((), SimplCount (n _ADD_ ILIT(1)) new_stuff new_unf)
 281   where
 282      new_stuff = inc_tick UnfoldingDone ILIT(1) stuff
 283
 284      new_unf | n_unf >= maxUnfoldHistory = (1, [unf_item], unf1)
 285              | otherwise                 = (n_unf+1, unf_item:unf1, unf2)
 286
 287      unf_item = (id, IBOX(n))
 288
 289
 290     -- force list to avoid getting a chain of @inc_tick@ applications
 291     -- building up on the heap. (Only true when not dumping stats).
 292 seqL []    y = y
 293 seqL (_:_) y = y
 294
 295 seqTriple (_,_,_) y = y
 296
 297 tickN :: TickType -> Int -> SmplM ()
 298
 299 tickN tick_type 0 us counts
 300   = ((), counts)
 301 tickN tick_type IBOX(increment) us (SimplCount n stuff unf)
 302   = -- pprTrace "Tick: " (text (show tick_type)) $
 303 #ifdef OMIT_SIMPL_COUNTS
 304     ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything
 305 #else
 306     new_stuff   `seqL`
 307     ((), SimplCount (n _ADD_ increment) new_stuff unf)
 308   where
 309     new_stuff = inc_tick tick_type increment stuff
 310
 311
 312 inc_tick tick_type n [] = panic "couldn't inc_tick!"
 313
 314 inc_tick tick_type n (x@(ttype, I# cnt#) : xs)
 315   | ttype == tick_type = case cnt# +# n of
 316                               incd -> (ttype,IBOX(incd)) : xs
 317
 318   | otherwise          = case inc_tick tick_type n xs of { [] -> [x]; ls -> x:ls }
 319 #endif
 320
 321 simplCount :: SmplM Int
 322 simplCount us sc@(SimplCount n _ _) = (IBOX(n), sc)
 323
 324 detailedSimplCount :: SmplM SimplCount
 325 detailedSimplCount us sc = (sc, sc)
 326
 327 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
 328
 329 #ifdef OMIT_SIMPL_COUNTS
 330 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
 331   = SimplCount (n1 _ADD_ n2)
 332                stuff2 -- just pick one
 333                unf2
 334 #else
 335 combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2)
 336   = new_stuff `seqL`
 337     SimplCount (n1 _ADD_ n2) new_stuff unf2     -- Just pick the second for unfold history
 338   where
 339     new_stuff = zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2
 340 #endif
 341 \end{code}
 342