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