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