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,
  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               ( mkSysLocal, mkIdWithNewUniq )
  29 import SimplEnv
  30 import SrcLoc           ( mkUnknownSrcLoc )
  31 import TyVar            ( cloneTyVar )
  32 import UniqSupply       ( getUnique, getUniques, splitUniqSupply,
  33                           UniqSupply
  34                         )
  35 import Util             ( zipWithEqual, panic )
  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 \end{code}
  98
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{Counting up what we've done}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 The assoc list isn't particularly costly, because we only use
 107 the number of ticks in ``real life.''
 108
 109 The right thing to do, if you want that to go fast, is thread
 110 a mutable array through @SimplM@.
 111
 112 \begin{code}
 113 data SimplCount
 114   = SimplCount  FAST_INT            -- number of ticks
 115                 [(TickType, Int)]   -- assoc list of all diff kinds of ticks
 116
 117 data TickType
 118   = UnfoldingDone    | MagicUnfold      | ConReused
 119   | CaseFloatFromLet | CaseOfCase
 120   | LetFloatFromLet  | LetFloatFromCase
 121   | KnownBranch      | Let2Case
 122   | CaseMerge        | CaseElim
 123   | CaseIdentity
 124   | AtomicRhs   -- Rhs of a let-expression was an atom
 125   | EtaExpansion
 126   | CaseOfError
 127   | TyBetaReduction
 128   | BetaReduction
 129   {- BEGIN F/B ENTRIES -}
 130   -- the 8 rules
 131   | FoldrBuild          -- foldr f z (build g) ==>
 132   | FoldrAugment        -- foldr f z (augment g z) ==>
 133   | Foldr_Nil           -- foldr f z [] ==>
 134   | Foldr_List          -- foldr f z (x:...) ==>
 135
 136   | FoldlBuild          -- foldl f z (build g) ==>
 137   | FoldlAugment        -- foldl f z (augment g z) ==>
 138   | Foldl_Nil           -- foldl f z [] ==>
 139   | Foldl_List          -- foldl f z (x:...) ==>
 140
 141   | Foldr_Cons_Nil      -- foldr (:) [] => id
 142   | Foldr_Cons          -- foldr (:) => flip (++)
 143
 144   | Str_FoldrStr        -- foldr f z "hello" => unpackFoldrPS__ f z "hello"
 145   | Str_UnpackCons      -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
 146   | Str_UnpackNil       -- unpackAppendPS__ [] "hello" => "hello"
 147   {- END F/B ENTRIES -}
 148   deriving (Eq, Ord, Ix)
 149
 150 instance Text TickType where
 151     showsPrec p UnfoldingDone   = showString "UnfoldingDone    "
 152     showsPrec p MagicUnfold     = showString "MagicUnfold      "
 153     showsPrec p ConReused       = showString "ConReused        "
 154     showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
 155     showsPrec p CaseOfCase      = showString "CaseOfCase       "
 156     showsPrec p LetFloatFromLet = showString "LetFloatFromLet  "
 157     showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
 158     showsPrec p KnownBranch     = showString "KnownBranch      "
 159     showsPrec p Let2Case        = showString "Let2Case         "
 160     showsPrec p CaseMerge       = showString "CaseMerge        "
 161     showsPrec p CaseElim        = showString "CaseElim         "
 162     showsPrec p CaseIdentity    = showString "CaseIdentity     "
 163     showsPrec p AtomicRhs       = showString "AtomicRhs        "
 164     showsPrec p EtaExpansion    = showString "EtaExpansion     "
 165     showsPrec p CaseOfError     = showString "CaseOfError      "
 166     showsPrec p TyBetaReduction = showString "TyBetaReduction  "
 167     showsPrec p BetaReduction   = showString "BetaReduction    "
 168         -- Foldr/Build Stuff:
 169     showsPrec p FoldrBuild      = showString "FoldrBuild       "
 170     showsPrec p FoldrAugment    = showString "FoldrAugment     "
 171     showsPrec p Foldr_Nil       = showString "Foldr_Nil        "
 172     showsPrec p Foldr_List      = showString "Foldr_List       "
 173
 174     showsPrec p FoldlBuild      = showString "FoldlBuild       "
 175     showsPrec p FoldlAugment    = showString "FoldlAugment     "
 176     showsPrec p Foldl_Nil       = showString "Foldl_Nil        "
 177     showsPrec p Foldl_List      = showString "Foldl_List       "
 178
 179     showsPrec p Foldr_Cons_Nil  = showString "Foldr_Cons_Nil   "
 180     showsPrec p Foldr_Cons      = showString "Foldr_Cons       "
 181
 182     showsPrec p Str_FoldrStr    = showString "Str_FoldrStr     "
 183     showsPrec p Str_UnpackCons  = showString "Str_UnpackCons   "
 184     showsPrec p Str_UnpackNil   = showString "Str_UnpackNil    "
 185
 186 showSimplCount :: SimplCount -> String
 187
 188 showSimplCount (SimplCount _ stuff)
 189   = shw stuff
 190   where
 191     shw []          = ""
 192     shw ((t,n):tns) | n /= 0    = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
 193                     | otherwise = shw tns
 194
 195 zeroSimplCount :: SimplCount
 196 zeroSimplCount
 197   = SimplCount ILIT(0)
 198       [ (UnfoldingDone, 0),
 199         (MagicUnfold, 0),
 200         (ConReused, 0),
 201         (CaseFloatFromLet, 0),
 202         (CaseOfCase, 0),
 203         (LetFloatFromLet, 0),
 204         (LetFloatFromCase, 0),
 205         (KnownBranch, 0),
 206         (Let2Case, 0),
 207         (CaseMerge, 0),
 208         (CaseElim, 0),
 209         (CaseIdentity, 0),
 210         (AtomicRhs, 0),
 211         (EtaExpansion, 0),
 212         (CaseOfError, 0),
 213         (TyBetaReduction,0),
 214         (BetaReduction,0),
 215         -- Foldr/Build Stuff:
 216         (FoldrBuild, 0),
 217         (FoldrAugment, 0),
 218         (Foldr_Nil, 0),
 219         (Foldr_List, 0),
 220         (FoldlBuild, 0),
 221         (FoldlAugment, 0),
 222         (Foldl_Nil, 0),
 223         (Foldl_List, 0),
 224         (Foldr_Cons_Nil, 0),
 225         (Foldr_Cons, 0),
 226
 227         (Str_FoldrStr, 0),
 228         (Str_UnpackCons, 0),
 229         (Str_UnpackNil, 0) ]
 230 --
 231 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
 232 --        [ i := 0 | i <- indices zeroSimplCount ]
 233 \end{code}
 234
 235 Counting-related monad functions:
 236 \begin{code}
 237 tick :: TickType -> SmplM ()
 238
 239 tick tick_type us (SimplCount n stuff)
 240   = ((), SimplCount (n _ADD_ ILIT(1))
 241 #ifdef OMIT_SIMPL_COUNTS
 242                     stuff -- don't change anything
 243 #else
 244                     (inc_tick stuff)
 245 #endif
 246     )
 247   where
 248     inc_tick [] = panic "couldn't inc_tick!"
 249     inc_tick (x@(ttype, cnt) : xs)
 250       = if ttype == tick_type then
 251             let
 252                 incd = cnt + 1
 253             in
 254             (ttype, incd) : xs
 255         else
 256             x : inc_tick xs
 257
 258 tickN :: TickType -> Int -> SmplM ()
 259
 260 tickN tick_type IBOX(increment) us (SimplCount n stuff)
 261   = ((), SimplCount (n _ADD_ increment)
 262 #ifdef OMIT_SIMPL_COUNTS
 263                     stuff -- don't change anything
 264 #else
 265                     (inc_tick stuff)
 266 #endif
 267     )
 268   where
 269     inc_tick [] = panic "couldn't inc_tick!"
 270     inc_tick (x@(ttype, cnt) : xs)
 271       = if ttype == tick_type then
 272             let
 273                 incd = cnt + IBOX(increment)
 274             in
 275             (ttype, incd) : xs
 276         else
 277             x : inc_tick xs
 278
 279 simplCount :: SmplM Int
 280 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
 281
 282 detailedSimplCount :: SmplM SimplCount
 283 detailedSimplCount us sc = (sc, sc)
 284
 285 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
 286
 287 #ifdef OMIT_SIMPL_COUNTS
 288 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 289   = SimplCount (n1 _ADD_ n2)
 290                stuff1 -- just pick one
 291 #else
 292 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 293   = SimplCount (n1 _ADD_ n2)
 294                (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
 295 #endif
 296 \end{code}
 297
 298 %************************************************************************
 299 %*                                                                      *
 300 \subsection{Monad primitives}
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 \begin{code}
 305 newId :: Type -> SmplM Id
 306 newId ty us sc
 307   = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
 308   where
 309     uniq = getUnique us
 310
 311 newIds :: [Type] -> SmplM [Id]
 312 newIds tys us sc
 313   = (zipWithEqual "newIds" mk_id tys uniqs, sc)
 314   where
 315     uniqs  = getUniques (length tys) us
 316     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
 317
 318 cloneTyVarSmpl :: TyVar -> SmplM TyVar
 319
 320 cloneTyVarSmpl tyvar us sc
 321   = (new_tyvar, sc)
 322   where
 323    uniq = getUnique us
 324    new_tyvar = cloneTyVar tyvar uniq
 325
 326 cloneId :: SimplEnv -> InBinder -> SmplM OutId
 327 cloneId env (id,_) us sc
 328   = (mkIdWithNewUniq id_with_new_ty uniq, sc)
 329   where
 330     id_with_new_ty = simplTyInId env id
 331     uniq = getUnique us
 332
 333 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
 334 cloneIds env binders = mapSmpl (cloneId env) binders
 335 \end{code}