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