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