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