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