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