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