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,
  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 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 :: DmdType -> StrictSig
 147 mkStrictSig dmd_ty = StrictSig dmd_ty
 148
 149 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 150 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 151
 152 strictSigResInfo :: StrictSig -> DmdResult
 153 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
 154
 155 topSig = StrictSig topDmdType
 156 botSig = StrictSig botDmdType
 157
 158 -- appIsBottom returns true if an application to n args would diverge
 159 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
 160 appIsBottom _                                 _ = False
 161
 162 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 163 isBottomingSig _                                = False
 164
 165 pprIfaceStrictSig :: StrictSig -> SDoc
 166 -- Used for printing top-level strictness pragmas in interface files
 167 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 168   = hcat (map ppr dmds) <> ppr res
 169 \end{code}
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection{Demands}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 data Demand
 180   = Lazy                -- L; used for unlifted types too, so that
 181                         --      A `lub` L = L
 182   | Abs                 -- A
 183
 184   | Call Demand         -- C(d)
 185   | Eval                -- V
 186   | Seq Keepity         -- S/U/D(ds)
 187         [Demand]        --      S(ds) = L `both` U(ds)
 188                         --      D(ds) = A `lub`  U(ds)
 189                         -- *** Invariant: these demands are never Bot or Abs
 190                         -- *** Invariant: if all demands are Abs, get []
 191
 192   | Err                 -- X
 193   | Bot                 -- B
 194   deriving( Eq )
 195         -- Equality needed for fixpoints in DmdAnal
 196
 197 data Keepity = Keep | Drop | Defer
 198              deriving( Eq )
 199
 200 mkSeq :: Keepity -> [Demand] -> Demand
 201 mkSeq k ds | all is_absent ds = Seq k []
 202            | otherwise        = Seq k ds
 203            where
 204              is_absent Abs = True
 205              is_absent d   = False
 206
 207 defer :: Demand -> Demand
 208 -- Computes (Abs `lub` d)
 209 -- For the Bot case consider
 210 --      f x y = if ... then x else error x
 211 --   Then for y we get Abs `lub` Bot, and we really
 212 --   want Abs overall
 213 defer Bot           = Abs
 214 defer Abs           = Abs
 215 defer (Seq Keep ds) = Lazy
 216 defer (Seq _    ds) = Seq Defer ds
 217 defer d             = Lazy
 218
 219 topDmd, lazyDmd, seqDmd :: Demand
 220 topDmd  = Lazy          -- The most uninformative demand
 221 lazyDmd = Lazy
 222 seqDmd  = Seq Keep []   -- Polymorphic seq demand
 223 evalDmd = Eval
 224
 225 isStrictDmd :: Demand -> Bool
 226 isStrictDmd Bot          = True
 227 isStrictDmd Err          = True
 228 isStrictDmd (Seq Drop _) = True -- But not Defer!
 229 isStrictDmd (Seq Keep _) = True
 230 isStrictDmd Eval         = True
 231 isStrictDmd (Call _)     = True
 232 isStrictDmd other        = False
 233
 234 instance Outputable Demand where
 235     ppr Lazy       = char 'L'
 236     ppr Abs        = char 'A'
 237     ppr Eval       = char 'V'
 238     ppr Err        = char 'X'
 239     ppr Bot        = char 'B'
 240     ppr (Call d)   = char 'C' <> parens (ppr d)
 241     ppr (Seq k []) = ppr k
 242     ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
 243
 244 instance Outputable Keepity where
 245   ppr Keep  = char 'S'
 246   ppr Drop  = char 'U'
 247   ppr Defer = char 'D'
 248 \end{code}
 249