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,
  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             braces (fsep (map pp_elt (ufmToList fv)))]
  70     where
  71       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
  72
  73 instance Outputable DmdResult where
  74   ppr TopRes = empty
  75   ppr RetCPR = char 'M'
  76   ppr BotRes = char 'X'
  77
  78 emptyDmdEnv = emptyVarEnv
  79 topDmdType = DmdType emptyDmdEnv [] TopRes
  80 botDmdType = DmdType emptyDmdEnv [] BotRes
  81
  82 isBotRes :: DmdResult -> Bool
  83 isBotRes BotRes = True
  84 isBotRes other  = False
  85
  86 returnsCPR :: DmdResult -> Bool
  87 returnsCPR RetCPR = True
  88 returnsCPR other  = False
  89
  90 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
  91 mkDmdType fv ds res = DmdType fv ds res
  92
  93 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
  94 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
  95
  96 dmdTypeDepth :: DmdType -> Arity
  97 dmdTypeDepth (DmdType _ ds _) = length ds
  98
  99 dmdTypeRes :: DmdType -> DmdResult
 100 dmdTypeRes (DmdType _ _ res_ty) = res_ty
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{Strictness signature
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 In a let-bound Id we record its strictness info.
 111 In principle, this strictness info is a demand transformer, mapping
 112 a demand on the Id into a DmdType, which gives
 113         a) the free vars of the Id's value
 114         b) the Id's arguments
 115         c) an indication of the result of applying
 116            the Id to its arguments
 117
 118 However, in fact we store in the Id an extremely emascuated demand transfomer,
 119 namely
 120                 a single DmdType
 121 (Nevertheless we dignify StrictSig as a distinct type.)
 122
 123 This DmdType gives the demands unleashed by the Id when it is applied
 124 to as many arguments as are given in by the arg demands in the DmdType.
 125
 126 For example, the demand transformer described by the DmdType
 127                 DmdType {x -> U(LL)} [V,A] Top
 128 says that when the function is applied to two arguments, it
 129 unleashes demand U(LL) on the free var x, V on the first arg,
 130 and A on the second.
 131
 132 If this same function is applied to one arg, all we can say is
 133 that it uses x with U*(LL), and its arg with demand L.
 134
 135 \begin{code}
 136 newtype StrictSig = StrictSig DmdType
 137                   deriving( Eq )
 138
 139 instance Outputable StrictSig where
 140    ppr (StrictSig ty) = ppr ty
 141
 142 instance Show StrictSig where
 143    show (StrictSig ty) = showSDoc (ppr ty)
 144
 145 mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
 146 mkStrictSig id arity dmd_ty
 147   = WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
 148     StrictSig dmd_ty
 149
 150 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 151 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 152
 153 strictSigResInfo :: StrictSig -> DmdResult
 154 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
 155
 156 topSig = StrictSig topDmdType
 157 botSig = StrictSig botDmdType
 158
 159 -- appIsBottom returns true if an application to n args would diverge
 160 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
 161 appIsBottom _                                 _ = False
 162
 163 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 164 isBottomingSig _                                = False
 165
 166 pprIfaceStrictSig :: StrictSig -> SDoc
 167 -- Used for printing top-level strictness pragmas in interface files
 168 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 169   = hcat (map ppr dmds) <> ppr res
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection{Demands}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 \begin{code}
 180 data Demand
 181   = Lazy                -- L; used for unlifted types too, so that
 182                         --      A `lub` L = L
 183   | Abs                 -- A
 184   | Call Demand         -- C(d)
 185   | Eval                -- V
 186   | Seq Keepity         -- S/U(ds)
 187         Deferredness
 188         [Demand]
 189   | Err                 -- X
 190   | Bot                 -- B
 191   deriving( Eq )
 192         -- Equality needed for fixpoints in DmdAnal
 193
 194 data Deferredness = Now | Defer
 195                   deriving( Eq )
 196
 197 data Keepity = Keep | Drop
 198              deriving( Eq )
 199
 200 topDmd, lazyDmd, seqDmd :: Demand
 201 topDmd  = Lazy                  -- The most uninformative demand
 202 lazyDmd = Lazy
 203 seqDmd  = Seq Keep Now []       -- Polymorphic seq demand
 204 evalDmd = Eval
 205
 206 isStrictDmd :: Demand -> Bool
 207 isStrictDmd Bot           = True
 208 isStrictDmd Err           = True
 209 isStrictDmd (Seq _ Now _) = True
 210 isStrictDmd Eval          = True
 211 isStrictDmd (Call _)      = True
 212 isStrictDmd other         = False
 213
 214 instance Outputable Demand where
 215     ppr Lazy         = char 'L'
 216     ppr Abs          = char 'A'
 217     ppr Eval         = char 'V'
 218     ppr Err          = char 'X'
 219     ppr Bot          = char 'B'
 220     ppr (Call d)     = char 'C' <> parens (ppr d)
 221     ppr (Seq k l []) = ppr k <> ppr l
 222     ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
 223
 224 instance Outputable Deferredness where
 225   ppr Now   = empty
 226   ppr Defer = char '*'
 227
 228 instance Outputable Keepity where
 229   ppr Keep = char 'S'
 230   ppr Drop = char 'U'
 231 \end{code}
 232