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