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