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