compiler/basicTypes/NewDemand.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[Demand]{@Demand@: the amount of demand on a value}
   6
   7 \begin{code}
   8 {-# OPTIONS -w #-}
   9 -- The above warning supression flag is a temporary kludge.
  10 -- While working on this module you are encouraged to remove it and fix
  11 -- any warnings in the module. See
  12 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  13 -- for details
  14
  15 module NewDemand(
  16         Demand(..),
  17         topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
  18         isTop, isAbsent, seqDemand,
  19
  20         DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
  21                 dmdTypeDepth, seqDmdType,
  22         DmdEnv, emptyDmdEnv,
  23         DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
  24
  25         Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
  26
  27         StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
  28         isTopSig,
  29         splitStrictSig,
  30         pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
  31      ) where
  32
  33 #include "HsVersions.h"
  34
  35 import StaticFlags
  36 import BasicTypes
  37 import VarEnv
  38 import UniqFM
  39 import Util
  40 import Outputable
  41 \end{code}
  42
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection{Demands}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 \begin{code}
  51 data Demand
  52   = Top                 -- T; used for unlifted types too, so that
  53                         --      A `lub` T = T
  54   | Abs                 -- A
  55
  56   | Call Demand         -- C(d)
  57
  58   | Eval Demands        -- U(ds)
  59
  60   | Defer Demands       -- D(ds)
  61
  62   | Box Demand          -- B(d)
  63
  64   | Bot                 -- B
  65   deriving( Eq )
  66         -- Equality needed for fixpoints in DmdAnal
  67
  68 data Demands = Poly Demand      -- Polymorphic case
  69              | Prod [Demand]    -- Product case
  70              deriving( Eq )
  71
  72 allTop (Poly d)  = isTop d
  73 allTop (Prod ds) = all isTop ds
  74
  75 isTop Top = True
  76 isTop d   = False
  77
  78 isAbsent Abs = True
  79 isAbsent d   = False
  80
  81 mapDmds :: (Demand -> Demand) -> Demands -> Demands
  82 mapDmds f (Poly d)  = Poly (f d)
  83 mapDmds f (Prod ds) = Prod (map f ds)
  84
  85 zipWithDmds :: (Demand -> Demand -> Demand)
  86             -> Demands -> Demands -> Demands
  87 zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
  88 zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
  89 zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
  90 zipWithDmds f (Prod ds1) (Prod ds2)
  91   | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
  92   | otherwise                = Poly topDmd
  93         -- This really can happen with polymorphism
  94         -- \f. case f x of (a,b) -> ...
  95         --     case f y of (a,b,c) -> ...
  96         -- Here the two demands on f are C(LL) and C(LLL)!
  97
  98 topDmd, lazyDmd, seqDmd :: Demand
  99 topDmd  = Top                   -- The most uninformative demand
 100 lazyDmd = Box Abs
 101 seqDmd  = Eval (Poly Abs)       -- Polymorphic seq demand
 102 evalDmd = Box seqDmd            -- Evaluate and return
 103 errDmd  = Box Bot               -- This used to be called X
 104
 105 isStrictDmd :: Demand -> Bool
 106 isStrictDmd Bot      = True
 107 isStrictDmd (Eval _) = True
 108 isStrictDmd (Call _) = True
 109 isStrictDmd (Box d)  = isStrictDmd d
 110 isStrictDmd other    = False
 111
 112 seqDemand :: Demand -> ()
 113 seqDemand (Call d)   = seqDemand d
 114 seqDemand (Eval ds)  = seqDemands ds
 115 seqDemand (Defer ds) = seqDemands ds
 116 seqDemand (Box d)    = seqDemand d
 117 seqDemand _          = ()
 118
 119 seqDemands :: Demands -> ()
 120 seqDemands (Poly d)  = seqDemand d
 121 seqDemands (Prod ds) = seqDemandList ds
 122
 123 seqDemandList :: [Demand] -> ()
 124 seqDemandList [] = ()
 125 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
 126
 127 instance Outputable Demand where
 128     ppr Top  = char 'T'
 129     ppr Abs  = char 'A'
 130     ppr Bot  = char 'B'
 131
 132     ppr (Defer ds)      = char 'D' <> ppr ds
 133     ppr (Eval ds)       = char 'U' <> ppr ds
 134
 135     ppr (Box (Eval ds)) = char 'S' <> ppr ds
 136     ppr (Box Abs)       = char 'L'
 137     ppr (Box Bot)       = char 'X'
 138
 139     ppr (Call d)        = char 'C' <> parens (ppr d)
 140
 141
 142 instance Outputable Demands where
 143     ppr (Poly Abs) = empty
 144     ppr (Poly d)   = parens (ppr d <> char '*')
 145     ppr (Prod ds)  = parens (hcat (map ppr ds))
 146         -- At one time I printed U(AAA) as U, but that
 147         -- confuses (Poly Abs) with (Prod AAA), and the
 148         -- worker/wrapper generation differs slightly for these two
 149         -- [Reason: in the latter case we can avoid passing the arg;
 150         --  see notes with WwLib.mkWWstr_one.]
 151 \end{code}
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Demand types}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 data DmdType = DmdType
 162                     DmdEnv      -- Demand on explicitly-mentioned
 163                                 --      free variables
 164                     [Demand]    -- Demand on arguments
 165                     DmdResult   -- Nature of result
 166
 167         --              IMPORTANT INVARIANT
 168         -- The default demand on free variables not in the DmdEnv is:
 169         -- DmdResult = BotRes        <=>  Bot
 170         -- DmdResult = TopRes/ResCPR <=>  Abs
 171
 172         --              ANOTHER IMPORTANT INVARIANT
 173         -- The Demands in the argument list are never
 174         --      Bot, Defer d
 175         -- Handwavey reason: these don't correspond to calling conventions
 176         -- See DmdAnal.funArgDemand for details
 177
 178
 179 -- This guy lets us switch off CPR analysis
 180 -- by making sure that everything uses TopRes instead of RetCPR
 181 -- Assuming, of course, that they don't mention RetCPR by name.
 182 -- They should onlyu use retCPR
 183 retCPR | opt_CprOff = TopRes
 184        | otherwise  = RetCPR
 185
 186 seqDmdType (DmdType env ds res) =
 187   {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
 188
 189 type DmdEnv = VarEnv Demand
 190
 191 data DmdResult = TopRes -- Nothing known
 192                | RetCPR -- Returns a constructed product
 193                | BotRes -- Diverges or errors
 194                deriving( Eq, Show )
 195         -- Equality for fixpoints
 196         -- Show needed for Show in Lex.Token (sigh)
 197
 198 -- Equality needed for fixpoints in DmdAnal
 199 instance Eq DmdType where
 200   (==) (DmdType fv1 ds1 res1)
 201        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
 202                               && ds1 == ds2 && res1 == res2
 203
 204 instance Outputable DmdType where
 205   ppr (DmdType fv ds res)
 206     = hsep [text "DmdType",
 207             hcat (map ppr ds) <> ppr res,
 208             if null fv_elts then empty
 209             else braces (fsep (map pp_elt fv_elts))]
 210     where
 211       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
 212       fv_elts = ufmToList fv
 213
 214 instance Outputable DmdResult where
 215   ppr TopRes = empty      -- Keep these distinct from Demand letters
 216   ppr RetCPR = char 'm'   -- so that we can print strictness sigs as
 217   ppr BotRes = char 'b'   --    dddr
 218                           -- without ambiguity
 219
 220 emptyDmdEnv = emptyVarEnv
 221
 222 topDmdType = DmdType emptyDmdEnv [] TopRes
 223 botDmdType = DmdType emptyDmdEnv [] BotRes
 224 cprDmdType = DmdType emptyVarEnv [] retCPR
 225
 226 isTopDmdType :: DmdType -> Bool
 227 -- Only used on top-level types, hence the assert
 228 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
 229 isTopDmdType other                   = False
 230
 231 isBotRes :: DmdResult -> Bool
 232 isBotRes BotRes = True
 233 isBotRes other  = False
 234
 235 resTypeArgDmd :: DmdResult -> Demand
 236 -- TopRes and BotRes are polymorphic, so that
 237 --      BotRes = Bot -> BotRes
 238 --      TopRes = Top -> TopRes
 239 -- This function makes that concrete
 240 -- We can get a RetCPR, because of the way in which we are (now)
 241 -- giving CPR info to strict arguments.  On the first pass, when
 242 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
 243 resTypeArgDmd TopRes = Top
 244 resTypeArgDmd RetCPR = Top
 245 resTypeArgDmd BotRes = Bot
 246
 247 returnsCPR :: DmdResult -> Bool
 248 returnsCPR RetCPR = True
 249 returnsCPR other  = False
 250
 251 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 252 mkDmdType fv ds res = DmdType fv ds res
 253
 254 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
 255 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
 256
 257 dmdTypeDepth :: DmdType -> Arity
 258 dmdTypeDepth (DmdType _ ds _) = length ds
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{Strictness signature
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 In a let-bound Id we record its strictness info.
 269 In principle, this strictness info is a demand transformer, mapping
 270 a demand on the Id into a DmdType, which gives
 271         a) the free vars of the Id's value
 272         b) the Id's arguments
 273         c) an indication of the result of applying
 274            the Id to its arguments
 275
 276 However, in fact we store in the Id an extremely emascuated demand transfomer,
 277 namely
 278                 a single DmdType
 279 (Nevertheless we dignify StrictSig as a distinct type.)
 280
 281 This DmdType gives the demands unleashed by the Id when it is applied
 282 to as many arguments as are given in by the arg demands in the DmdType.
 283
 284 For example, the demand transformer described by the DmdType
 285                 DmdType {x -> U(LL)} [V,A] Top
 286 says that when the function is applied to two arguments, it
 287 unleashes demand U(LL) on the free var x, V on the first arg,
 288 and A on the second.
 289
 290 If this same function is applied to one arg, all we can say is
 291 that it uses x with U*(LL), and its arg with demand L.
 292
 293 \begin{code}
 294 newtype StrictSig = StrictSig DmdType
 295                   deriving( Eq )
 296
 297 instance Outputable StrictSig where
 298    ppr (StrictSig ty) = ppr ty
 299
 300 instance Show StrictSig where
 301    show (StrictSig ty) = showSDoc (ppr ty)
 302
 303 mkStrictSig :: DmdType -> StrictSig
 304 mkStrictSig dmd_ty = StrictSig dmd_ty
 305
 306 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 307 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 308
 309 isTopSig (StrictSig ty) = isTopDmdType ty
 310
 311 topSig, botSig, cprSig :: StrictSig
 312 topSig = StrictSig topDmdType
 313 botSig = StrictSig botDmdType
 314 cprSig = StrictSig cprDmdType
 315
 316
 317 -- appIsBottom returns true if an application to n args would diverge
 318 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 319 appIsBottom _                                 _ = False
 320
 321 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 322 isBottomingSig _                                = False
 323
 324 seqStrictSig (StrictSig ty) = seqDmdType ty
 325
 326 pprIfaceStrictSig :: StrictSig -> SDoc
 327 -- Used for printing top-level strictness pragmas in interface files
 328 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 329   = hcat (map ppr dmds) <> ppr res
 330 \end{code}
 331
 332