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