ghc/compiler/basicTypes/NewDemand.lhs

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