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