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