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