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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  27 IMPORT_DELOOPER(SmplLoop)               -- well, cheating sort of
  28 #else
  29 import {-# SOURCE #-} Simplify
  30 import {-# SOURCE #-} MagicUFs
  31 #endif
  32
  33 import Id               ( GenId, mkSysLocal, mkIdWithNewUniq, SYN_IE(Id) )
  34 import CoreUnfold       ( SimpleUnfolding )
  35 import SimplEnv
  36 import SrcLoc           ( noSrcLoc )
  37 import TyVar            ( cloneTyVar, SYN_IE(TyVar) )
  38 import Type             ( SYN_IE(Type) )
  39 import UniqSupply       ( getUnique, getUniques, splitUniqSupply,
  40                           UniqSupply
  41                         )
  42 import Util             ( zipWithEqual, panic, SYN_IE(Eager), appEager, pprTrace )
  43 import Pretty
  44 import Outputable       ( PprStyle(..), Outputable(..) )
  45
  46 infixr 9  `thenSmpl`, `thenSmpl_`
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{Monad plumbing}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
  56 (Command-line switches move around through the explicitly-passed SimplEnv.)
  57
  58 \begin{code}
  59 type SmplM result
  60   = UniqSupply
  61   -> SimplCount    -- things being threaded
  62   -> (result, SimplCount)
  63 \end{code}
  64
  65 \begin{code}
  66 initSmpl :: UniqSupply -- no init count; set to 0
  67           -> SmplM a
  68           -> (a, SimplCount)
  69
  70 initSmpl us m = m us zeroSimplCount
  71
  72 {-# INLINE thenSmpl #-}
  73 {-# INLINE thenSmpl_ #-}
  74 {-# INLINE returnSmpl #-}
  75
  76 returnSmpl :: a -> SmplM a
  77 returnSmpl e us sc = (e, sc)
  78
  79 thenSmpl  :: SmplM a -> (a -> SmplM b) -> SmplM b
  80 thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
  81
  82 thenSmpl m k us sc0
  83   = case splitUniqSupply us of { (s1, s2) ->
  84     case (m s1 sc0)         of { (m_result, sc1) ->
  85     k m_result s2 sc1 }}
  86
  87 thenSmpl_ m k us sc0
  88   = case splitUniqSupply us of { (s1, s2) ->
  89     case (m s1 sc0)         of { (_, sc1) ->
  90     k s2 sc1 }}
  91
  92 mapSmpl         :: (a -> SmplM b) -> [a] -> SmplM [b]
  93 mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
  94
  95 mapSmpl f [] = returnSmpl []
  96 mapSmpl f (x:xs)
  97   = f x             `thenSmpl` \ x'  ->
  98     mapSmpl f xs    `thenSmpl` \ xs' ->
  99     returnSmpl (x':xs')
 100
 101 mapAndUnzipSmpl f [] = returnSmpl ([],[])
 102 mapAndUnzipSmpl f (x:xs)
 103   = f x                     `thenSmpl` \ (r1,  r2)  ->
 104     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
 105     returnSmpl (r1:rs1, r2:rs2)
 106 \end{code}
 107
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{Counting up what we've done}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 The assoc list isn't particularly costly, because we only use
 116 the number of ticks in ``real life.''
 117
 118 The right thing to do, if you want that to go fast, is thread
 119 a mutable array through @SimplM@.
 120
 121 \begin{code}
 122 data SimplCount
 123   = SimplCount  FAST_INT            -- number of ticks
 124                 [(TickType, Int)]   -- assoc list of all diff kinds of ticks
 125                 UnfoldingHistory
 126
 127 type UnfoldingHistory = (Int,           -- N
 128                          [(Id,Int)],    -- Last N unfoldings
 129                          [(Id,Int)])    -- The MaxUnfoldHistory unfoldings before that
 130
 131 data TickType
 132   = UnfoldingDone    | MagicUnfold      | ConReused
 133   | CaseFloatFromLet | CaseOfCase
 134   | LetFloatFromLet  | LetFloatFromCase
 135   | KnownBranch      | Let2Case
 136   | CaseMerge        | CaseElim
 137   | CaseIdentity
 138   | AtomicRhs   -- Rhs of a let-expression was an atom
 139   | EtaExpansion
 140   | CaseOfError
 141   | TyBetaReduction
 142   | BetaReduction
 143   | SpecialisationDone
 144   {- BEGIN F/B ENTRIES -}
 145   -- the 8 rules
 146   | FoldrBuild          -- foldr f z (build g) ==>
 147   | FoldrAugment        -- foldr f z (augment g z) ==>
 148   | Foldr_Nil           -- foldr f z [] ==>
 149   | Foldr_List          -- foldr f z (x:...) ==>
 150
 151   | FoldlBuild          -- foldl f z (build g) ==>
 152   | FoldlAugment        -- foldl f z (augment g z) ==>
 153   | Foldl_Nil           -- foldl f z [] ==>
 154   | Foldl_List          -- foldl f z (x:...) ==>
 155
 156   | Foldr_Cons_Nil      -- foldr (:) [] => id
 157   | Foldr_Cons          -- foldr (:) => flip (++)
 158
 159   | Str_FoldrStr        -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
 160   | Str_UnpackCons      -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
 161   | Str_UnpackNil       -- unpackAppendPS__ [] "hello" => "hello"
 162   {- END F/B ENTRIES -}
 163   deriving (Eq, Ord, Ix)
 164
 165 instance Text TickType where
 166     showsPrec p UnfoldingDone   = showString "UnfoldingDone    "
 167     showsPrec p MagicUnfold     = showString "MagicUnfold      "
 168     showsPrec p ConReused       = showString "ConReused        "
 169     showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
 170     showsPrec p CaseOfCase      = showString "CaseOfCase       "
 171     showsPrec p LetFloatFromLet = showString "LetFloatFromLet  "
 172     showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
 173     showsPrec p KnownBranch     = showString "KnownBranch      "
 174     showsPrec p Let2Case        = showString "Let2Case         "
 175     showsPrec p CaseMerge       = showString "CaseMerge        "
 176     showsPrec p CaseElim        = showString "CaseElim         "
 177     showsPrec p CaseIdentity    = showString "CaseIdentity     "
 178     showsPrec p AtomicRhs       = showString "AtomicRhs        "
 179     showsPrec p EtaExpansion    = showString "EtaExpansion     "
 180     showsPrec p CaseOfError     = showString "CaseOfError      "
 181     showsPrec p TyBetaReduction = showString "TyBetaReduction  "
 182     showsPrec p BetaReduction   = showString "BetaReduction    "
 183     showsPrec p SpecialisationDone
 184                                 = showString "Specialisation   "
 185
 186         -- Foldr/Build Stuff:
 187     showsPrec p FoldrBuild      = showString "FoldrBuild       "
 188     showsPrec p FoldrAugment    = showString "FoldrAugment     "
 189     showsPrec p Foldr_Nil       = showString "Foldr_Nil        "
 190     showsPrec p Foldr_List      = showString "Foldr_List       "
 191
 192     showsPrec p FoldlBuild      = showString "FoldlBuild       "
 193     showsPrec p FoldlAugment    = showString "FoldlAugment     "
 194     showsPrec p Foldl_Nil       = showString "Foldl_Nil        "
 195     showsPrec p Foldl_List      = showString "Foldl_List       "
 196
 197     showsPrec p Foldr_Cons_Nil  = showString "Foldr_Cons_Nil   "
 198     showsPrec p Foldr_Cons      = showString "Foldr_Cons       "
 199
 200     showsPrec p Str_FoldrStr    = showString "Str_FoldrStr     "
 201     showsPrec p Str_UnpackCons  = showString "Str_UnpackCons   "
 202     showsPrec p Str_UnpackNil   = showString "Str_UnpackNil    "
 203
 204 showSimplCount :: SimplCount -> String
 205
 206 showSimplCount (SimplCount _ stuff (_, unf1, unf2))
 207   = shw stuff ++ "\nMost recent unfoldings: " ++ show (ppr PprDebug (reverse unf2 ++ reverse unf1))
 208   where
 209     shw []          = ""
 210     shw ((t,n):tns) | n /= 0    = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
 211                     | otherwise = shw tns
 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}