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