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 #ifdef OMIT_SIMPL_COUNTS
 247   = ((), SimplCount (n _ADD_ ILIT(1) stuff))                stuff -- don't change anything
 248 #else
 249   = case inc_tick stuff of
 250       [] -> ((), SimplCount (n _ADD_ ILIT(1)) [])
 251       ls -> ((), SimplCount (n _ADD_ ILIT(1)) ls)
 252   where
 253     inc_tick [] = panic "couldn't inc_tick!"
 254     inc_tick (x@(ttype, I# cnt#) : xs)
 255       = if ttype == tick_type then
 256             case cnt# +# 1# of { incd -> (ttype, IBOX(incd)) : xs }
 257         else
 258             case inc_tick xs of { [] -> [x]; ls -> x:ls }
 259
 260 #endif
 261
 262 tickN :: TickType -> Int -> SmplM ()
 263
 264 tickN tick_type 0 us counts
 265   = ((), counts)
 266 tickN tick_type IBOX(increment) us (SimplCount n stuff)
 267 #ifdef OMIT_SIMPL_COUNTS
 268   = ((), SimplCount (n _ADD_ increment) stuff) -- don't change anything
 269 #else
 270     -- force list to avoid getting a chain of @inc_tick@ applications
 271     -- building up on the heap. (Only true when not dumping stats).
 272   = case inc_tick stuff of
 273       [] -> ((), SimplCount (n _ADD_ increment) [] )
 274       ls -> ((), SimplCount (n _ADD_ increment) ls )
 275   where
 276     inc_tick [] = panic "couldn't inc_tick!"
 277     inc_tick (x@(ttype, I# cnt#) : xs)
 278       = if ttype == tick_type then
 279             case cnt# +# increment of
 280               incd -> (ttype,IBOX(incd)) : xs
 281         else
 282             case inc_tick xs of { [] -> [x]; ls -> x:ls }
 283 #endif
 284
 285 simplCount :: SmplM Int
 286 simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
 287
 288 detailedSimplCount :: SmplM SimplCount
 289 detailedSimplCount us sc = (sc, sc)
 290
 291 combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
 292
 293 #ifdef OMIT_SIMPL_COUNTS
 294 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 295   = SimplCount (n1 _ADD_ n2)
 296                stuff1 -- just pick one
 297 #else
 298 combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
 299   = case (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) of
 300       [] -> SimplCount (n1 _ADD_ n2) []
 301       ls -> SimplCount (n1 _ADD_ n2) ls
 302 #endif
 303 \end{code}
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsection{Monad primitives}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311 \begin{code}
 312 newId :: Type -> SmplM Id
 313 newId ty us sc
 314   = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc)
 315   where
 316     uniq = getUnique us
 317
 318 newIds :: [Type] -> SmplM [Id]
 319 newIds tys us sc
 320   = (zipWithEqual "newIds" mk_id tys uniqs, sc)
 321   where
 322     uniqs  = getUniques (length tys) us
 323     mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
 324
 325 cloneTyVarSmpl :: TyVar -> SmplM TyVar
 326
 327 cloneTyVarSmpl tyvar us sc
 328   = (new_tyvar, sc)
 329   where
 330    uniq = getUnique us
 331    new_tyvar = cloneTyVar tyvar uniq
 332
 333 cloneId :: SimplEnv -> InBinder -> SmplM OutId
 334 cloneId env (id,_) us sc
 335   = (mkIdWithNewUniq id_with_new_ty uniq, sc)
 336   where
 337     id_with_new_ty = simplTyInId env id
 338     uniq = getUnique us
 339
 340 cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
 341 cloneIds env binders = mapSmpl (cloneId env) binders
 342 \end{code}