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