ghc/compiler/simplCore/SimplMonad.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SimplMonad]{The simplifier Monad}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplMonad (
  10         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
  22         -- and to make the interface self-sufficient...
  23         BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType,
  24         SplitUniqSupply
  25
  26         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
  27     ) where
  28
  29 IMPORT_Trace            -- ToDo: rm (debugging)
  30
  31 import TaggedCore
  32 import PlainCore
  33
  34 import AbsUniType       ( cloneTyVar )
  35 import CmdLineOpts
  36 import Id               ( mkIdWithNewUniq, mkSysLocal )
  37 import IdInfo
  38 import SimplEnv
  39 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  40 import SplitUniq
  41 import Unique
  42 import Util
  43
  44 infixr 9  `thenSmpl`, `thenSmpl_`
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection[Monad]{Monad plumbing}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
  54 (Command-line switches move around through the explicitly-passed SimplEnv.)
  55
  56 \begin{code}
  57 type SmplM result
  58   = SplitUniqSupply
  59   -> SimplCount    -- things being threaded
  60   -> (result, SimplCount)
  61 \end{code}
  62
  63 \begin{code}
  64 initSmpl :: SplitUniqSupply -- no init count; set to 0
  65           -> SmplM a
  66           -> (a, SimplCount)
  67
  68 initSmpl us m = m us zeroSimplCount
  69
  70 #ifdef __GLASGOW_HASKELL__
  71 {-# INLINE thenSmpl #-}
  72 {-# INLINE thenSmpl_ #-}
  73 {-# INLINE returnSmpl #-}
  74 #endif
  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[SimplCount]{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
 126 data TickType
 127   = UnfoldingDone    {-UNUSED: | Unused -}
 128   | FoldrBuild       | MagicUnfold      | ConReused
 129   | CaseFloatFromLet | CaseOfCase       {-UNUSED: | CaseFloatFromApp -}
 130   | LetFloatFromLet  | LetFloatFromCase {-UNUSED: | LetFloatFromApp -}
 131   | KnownBranch      | Let2Case         {-UNUSED: | UnboxingLet2Case -}
 132   | CaseMerge        {-UNUSED: | CaseToLet-}    | CaseElim
 133   | CaseIdentity
 134   | AtomicRhs   -- Rhs of a let-expression was an atom
 135   | EtaExpansion     {-UNUSED: | ArityExpand-}
 136   {-UNUSED: | ConstantFolding-}  | CaseOfError  {-UNUSED: | InlineRemoved -}
 137   | FoldrConsNil
 138   | Foldr_Nil
 139   | FoldrFoldr
 140   | Foldr_List
 141   | FoldrCons
 142   | FoldrInline
 143   | TyBetaReduction
 144   | BetaReduction
 145   deriving (Eq, Ord, Ix)
 146
 147 instance Text TickType where
 148     showsPrec p UnfoldingDone   = showString "UnfoldingDone    "
 149 --UNUSED:    showsPrec p Unused         = showString "Unused           "
 150     showsPrec p FoldrBuild      = showString "FoldrBuild       "
 151     showsPrec p MagicUnfold     = showString "MagicUnfold      "
 152     showsPrec p ConReused       = showString "ConReused        "
 153     showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
 154     showsPrec p CaseOfCase      = showString "CaseOfCase       "
 155 --UNUSED:    showsPrec p CaseFloatFromApp= showString "CaseFloatFromApp "
 156     showsPrec p LetFloatFromLet = showString "LetFloatFromLet  "
 157     showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
 158 --UNUSED:    showsPrec p LetFloatFromApp        = showString "LetFloatFromApp  "
 159     showsPrec p KnownBranch     = showString "KnownBranch      "
 160     showsPrec p Let2Case        = showString "Let2Case         "
 161 --UNUSED:    showsPrec p UnboxingLet2Case= showString "UnboxingLet2Case "
 162     showsPrec p CaseMerge       = showString "CaseMerge        "
 163 --UNUSED:    showsPrec p CaseToLet      = showString "CaseToLet        "
 164     showsPrec p CaseElim        = showString "CaseElim         "
 165     showsPrec p CaseIdentity    = showString "CaseIdentity     "
 166     showsPrec p AtomicRhs       = showString "AtomicRhs        "
 167     showsPrec p EtaExpansion    = showString "EtaExpansion     "
 168 --UNUSED:    showsPrec p ArityExpand    = showString "ArityExpand      "
 169 --UNUSED:    showsPrec p ConstantFolding        = showString "ConstantFolding  "
 170     showsPrec p CaseOfError     = showString "CaseOfError      "
 171 --UNUSED:    showsPrec p InlineRemoved  = showString "InlineRemoved    "
 172     showsPrec p FoldrConsNil    = showString "FoldrConsNil     "
 173     showsPrec p Foldr_Nil       = showString "Foldr_Nil        "
 174     showsPrec p FoldrFoldr      = showString "FoldrFoldr       "
 175     showsPrec p Foldr_List      = showString "Foldr_List       "
 176     showsPrec p FoldrCons       = showString "FoldrCons        "
 177     showsPrec p FoldrInline     = showString "FoldrInline      "
 178     showsPrec p TyBetaReduction = showString "TyBetaReduction  "
 179     showsPrec p BetaReduction   = showString "BetaReduction    "
 180
 181 showSimplCount :: SimplCount -> String
 182
 183 showSimplCount (SimplCount _ stuff)
 184   = shw stuff
 185   where
 186     shw []          = ""
 187     shw ((t,n):tns) | n /= 0    = show t ++ ('\t' : show n) ++ ('\n' : shw tns)
 188                     | otherwise = shw tns
 189
 190 zeroSimplCount :: SimplCount
 191 zeroSimplCount
 192   = SimplCount ILIT(0)
 193         [(UnfoldingDone, 0),
 194 --UNUSED:        (Unused, 0),
 195          (FoldrBuild, 0),
 196          (MagicUnfold, 0),
 197          (ConReused, 0),
 198          (CaseFloatFromLet, 0),
 199          (CaseOfCase, 0),
 200 --UNUSED:        (CaseFloatFromApp, 0),
 201          (LetFloatFromLet, 0),
 202          (LetFloatFromCase, 0),
 203 --UNUSED:        (LetFloatFromApp, 0),
 204          (KnownBranch, 0),
 205          (Let2Case, 0),
 206 --UNUSED:        (UnboxingLet2Case, 0),
 207          (CaseMerge, 0),
 208 --UNUSED:        (CaseToLet, 0),
 209          (CaseElim, 0),
 210          (CaseIdentity, 0),
 211          (AtomicRhs, 0),
 212          (EtaExpansion, 0),
 213 --UNUSED:        (ArityExpand,0),
 214 --UNUSED:        (ConstantFolding, 0),
 215          (CaseOfError, 0),
 216 --UNUSED:        (InlineRemoved,0),
 217          (FoldrConsNil,0),
 218          (Foldr_Nil,0),
 219          (FoldrFoldr,0),
 220          (Foldr_List,0),
 221          (FoldrCons,0),
 222          (FoldrInline,0),
 223          (TyBetaReduction,0),
 224          (BetaReduction,0) ]
 225 --
 226 --= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
 227 --        [ i := 0 | i <- indices zeroSimplCount ]
 228 \end{code}
 229
 230 Counting-related monad functions:
 231 \begin{code}
 232 tick :: TickType -> SmplM ()
 233
 234 tick tick_type us (SimplCount n stuff)
 235   = ((), SimplCount (n _ADD_ ILIT(1))
 236 #ifdef OMIT_SIMPL_COUNTS
 237                     stuff -- don't change anything
 238 #else
 239                     (inc_tick stuff)
 240 #endif
 241     )
 242   where
 243     inc_tick [] = panic "couldn't inc_tick!"
 244     inc_tick (x@(ttype, cnt) : xs)
 245       = if ttype == tick_type then
 246             let
 247                 incd = cnt + 1
 248             in
 249             (ttype, incd) : xs
 250         else
 251             x : inc_tick xs
 252
 253 tickN :: TickType -> Int -> SmplM ()
 254
 255 tickN tick_type IBOX(increment) us (SimplCount n stuff)
 256   = ((), SimplCount (n _ADD_ increment)
 257 #ifdef OMIT_SIMPL_COUNTS
 258                     stuff -- don't change anything
 259 #else
 260                     (inc_tick stuff)
 261 #endif
 262     )
 263   where
 264     inc_tick [] = panic "couldn't inc_tick!"
 265     inc_tick (x@(ttype, cnt) : xs)
 266       = if ttype == tick_type then
 267             let
 268                 incd = cnt + IBOX(increment)
 269             in
 270             (ttype, incd) : xs
 271         else
 272             x : inc_tick xs
 273
 274 simplCount :: SmplM Int
 275 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
 276
 277 detailedSimplCount :: SmplM SimplCount
 278 detailedSimplCount us sc = (sc, sc)
 279
 280 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
 281
 282 #ifdef OMIT_SIMPL_COUNTS
 283 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 284   = SimplCount (n1 _ADD_ n2)
 285                stuff1 -- just pick one
 286 #else
 287 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 288   = SimplCount (n1 _ADD_ n2)
 289                (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
 290 #endif
 291 \end{code}
 292
 293 %************************************************************************
 294 %*                                                                      *
 295 \subsection{Monad primitives}
 296 %*                                                                      *
 297 %************************************************************************
 298
 299 \begin{code}
 300 newId :: UniType -> SmplM Id
 301 newId ty us sc
 302   = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
 303   where
 304     uniq = getSUnique us
 305
 306 newIds :: [UniType] -> SmplM [Id]
 307 newIds tys us sc
 308   = (zipWith mk_id tys uniqs, sc)
 309   where
 310     uniqs  = getSUniques (length tys) us
 311     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
 312
 313 cloneTyVarSmpl :: TyVar -> SmplM TyVar
 314
 315 cloneTyVarSmpl tyvar us sc
 316   = (new_tyvar, sc)
 317   where
 318    uniq = getSUnique us
 319    new_tyvar = cloneTyVar tyvar uniq
 320
 321 cloneId :: SimplEnv -> InBinder -> SmplM OutId
 322 cloneId env (id,_) us sc
 323   = (mkIdWithNewUniq id_with_new_ty uniq, sc)
 324   where
 325     id_with_new_ty = simplTyInId env id
 326     uniq = getSUnique us
 327
 328 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
 329 cloneIds env binders = mapSmpl (cloneId env) binders
 330 \end{code}