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