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,
  11
  12         DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
  13                 dmdTypeDepth, dmdTypeRes,
  14         DmdEnv, emptyDmdEnv,
  15         DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
  16
  17         Demands(..), mapDmds, zipWithDmds, allTop,
  18
  19         StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
  20         splitStrictSig, strictSigResInfo,
  21         pprIfaceStrictSig, appIsBottom, isBottomingSig
  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 instance Outputable Demand where
  97     ppr Top  = char 'T'
  98     ppr Abs  = char 'A'
  99     ppr Bot  = char 'B'
 100
 101     ppr (Defer ds)      = char 'D' <> ppr ds
 102     ppr (Eval ds)       = char 'U' <> ppr ds
 103
 104     ppr (Box (Eval ds)) = char 'S' <> ppr ds
 105     ppr (Box Abs)       = char 'L'
 106     ppr (Box Bot)       = char 'X'
 107
 108     ppr (Call d)        = char 'C' <> parens (ppr d)
 109
 110
 111 instance Outputable Demands where
 112     ppr (Poly Abs) = empty
 113     ppr (Poly d)   = parens (ppr d <> char '*')
 114     ppr (Prod ds) | all isAbsent ds = empty
 115                   | otherwise       = parens (hcat (map ppr ds))
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Demand types}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 data DmdType = DmdType
 127                     DmdEnv      -- Demand on explicitly-mentioned
 128                                 --      free variables
 129                     [Demand]    -- Demand on arguments
 130                     DmdResult   -- Nature of result
 131
 132         --              IMPORTANT INVARIANT
 133         -- The default demand on free variables not in the DmdEnv is:
 134         -- DmdResult = BotRes        <=>  Bot
 135         -- DmdResult = TopRes/ResCPR <=>  Abs
 136
 137         --              ANOTHER IMPORTANT INVARIANT
 138         -- The Demands in the argument list are never
 139         --      Bot, Defer d
 140         -- Handwavey reason: these don't correspond to calling conventions
 141         -- See DmdAnal.funArgDemand for details
 142
 143 type DmdEnv = VarEnv Demand
 144
 145 data DmdResult = TopRes -- Nothing known
 146                | RetCPR -- Returns a constructed product
 147                | BotRes -- Diverges or errors
 148                deriving( Eq, Show )
 149         -- Equality for fixpoints
 150         -- Show needed for Show in Lex.Token (sigh)
 151
 152 -- Equality needed for fixpoints in DmdAnal
 153 instance Eq DmdType where
 154   (==) (DmdType fv1 ds1 res1)
 155        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
 156                               && ds1 == ds2 && res1 == res2
 157
 158 instance Outputable DmdType where
 159   ppr (DmdType fv ds res)
 160     = hsep [text "DmdType",
 161             hcat (map ppr ds) <> ppr res,
 162             if null fv_elts then empty
 163             else braces (fsep (map pp_elt fv_elts))]
 164     where
 165       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
 166       fv_elts = ufmToList fv
 167
 168 instance Outputable DmdResult where
 169   ppr TopRes = empty      -- Keep these distinct from Demand letters
 170   ppr RetCPR = char 'm'   -- so that we can print strictness sigs as
 171   ppr BotRes = char 'b'   --    dddr
 172                           -- without ambiguity
 173
 174 emptyDmdEnv = emptyVarEnv
 175 topDmdType = DmdType emptyDmdEnv [] TopRes
 176 botDmdType = DmdType emptyDmdEnv [] BotRes
 177
 178 isTopDmdType :: DmdType -> Bool
 179 -- Only used on top-level types, hence the assert
 180 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
 181 isTopDmdType other                   = False
 182
 183 isBotRes :: DmdResult -> Bool
 184 isBotRes BotRes = True
 185 isBotRes other  = False
 186
 187 resTypeArgDmd :: DmdResult -> Demand
 188 -- TopRes and BotRes are polymorphic, so that
 189 --      BotRes = Bot -> BotRes
 190 --      TopRes = Top -> TopRes
 191 -- This function makes that concrete
 192 resTypeArgDmd TopRes = Top
 193 resTypeArgDmd BotRes = Bot
 194 resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
 195
 196 returnsCPR :: DmdResult -> Bool
 197 returnsCPR RetCPR = True
 198 returnsCPR other  = False
 199
 200 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 201 mkDmdType fv ds res = DmdType fv ds res
 202
 203 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
 204 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
 205
 206 dmdTypeDepth :: DmdType -> Arity
 207 dmdTypeDepth (DmdType _ ds _) = length ds
 208
 209 dmdTypeRes :: DmdType -> DmdResult
 210 dmdTypeRes (DmdType _ _ res_ty) = res_ty
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Strictness signature
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 In a let-bound Id we record its strictness info.
 221 In principle, this strictness info is a demand transformer, mapping
 222 a demand on the Id into a DmdType, which gives
 223         a) the free vars of the Id's value
 224         b) the Id's arguments
 225         c) an indication of the result of applying
 226            the Id to its arguments
 227
 228 However, in fact we store in the Id an extremely emascuated demand transfomer,
 229 namely
 230                 a single DmdType
 231 (Nevertheless we dignify StrictSig as a distinct type.)
 232
 233 This DmdType gives the demands unleashed by the Id when it is applied
 234 to as many arguments as are given in by the arg demands in the DmdType.
 235
 236 For example, the demand transformer described by the DmdType
 237                 DmdType {x -> U(LL)} [V,A] Top
 238 says that when the function is applied to two arguments, it
 239 unleashes demand U(LL) on the free var x, V on the first arg,
 240 and A on the second.
 241
 242 If this same function is applied to one arg, all we can say is
 243 that it uses x with U*(LL), and its arg with demand L.
 244
 245 \begin{code}
 246 newtype StrictSig = StrictSig DmdType
 247                   deriving( Eq )
 248
 249 instance Outputable StrictSig where
 250    ppr (StrictSig ty) = ppr ty
 251
 252 instance Show StrictSig where
 253    show (StrictSig ty) = showSDoc (ppr ty)
 254
 255 mkStrictSig :: DmdType -> StrictSig
 256 mkStrictSig dmd_ty = StrictSig dmd_ty
 257
 258 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 259 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 260
 261 strictSigResInfo :: StrictSig -> DmdResult
 262 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
 263
 264 isTopSig (StrictSig ty) = isTopDmdType ty
 265
 266 topSig = StrictSig topDmdType
 267 botSig = StrictSig botDmdType
 268
 269 -- appIsBottom returns true if an application to n args would diverge
 270 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 271 appIsBottom _                                 _ = False
 272
 273 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 274 isBottomingSig _                                = False
 275
 276 pprIfaceStrictSig :: StrictSig -> SDoc
 277 -- Used for printing top-level strictness pragmas in interface files
 278 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 279   = hcat (map ppr dmds) <> ppr res
 280 \end{code}
 281
 282