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(..),
   9         topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
  10         isTop, isAbsent, seqDemand,
  11
  12         DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
  13                 dmdTypeDepth, dmdTypeRes, seqDmdType,
  14         DmdEnv, emptyDmdEnv,
  15         DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
  16
  17         Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
  18
  19         StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
  20         splitStrictSig, strictSigResInfo,
  21         pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
  22      ) where
  23
  24 #include "HsVersions.h"
  25
  26 import BasicTypes       ( Arity )
  27 import VarEnv           ( VarEnv, emptyVarEnv, isEmptyVarEnv )
  28 import UniqFM           ( ufmToList )
  29 import Util             ( listLengthCmp, zipWithEqual )
  30 import Outputable
  31 \end{code}
  32
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection{Demands}
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 \begin{code}
  41 data Demand
  42   = Top                 -- T; used for unlifted types too, so that
  43                         --      A `lub` T = T
  44   | Abs                 -- A
  45
  46   | Call Demand         -- C(d)
  47
  48   | Eval Demands        -- U(ds)
  49
  50   | Defer Demands       -- D(ds)
  51
  52   | Box Demand          -- B(d)
  53
  54   | Bot                 -- B
  55   deriving( Eq )
  56         -- Equality needed for fixpoints in DmdAnal
  57
  58 data Demands = Poly Demand      -- Polymorphic case
  59              | Prod [Demand]    -- Product case
  60              deriving( Eq )
  61
  62 allTop (Poly d)  = isTop d
  63 allTop (Prod ds) = all isTop ds
  64
  65 isTop Top = True
  66 isTop d   = False
  67
  68 isAbsent Abs = True
  69 isAbsent d   = False
  70
  71 mapDmds :: (Demand -> Demand) -> Demands -> Demands
  72 mapDmds f (Poly d)  = Poly (f d)
  73 mapDmds f (Prod ds) = Prod (map f ds)
  74
  75 zipWithDmds :: (Demand -> Demand -> Demand)
  76             -> Demands -> Demands -> Demands
  77 zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
  78 zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
  79 zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
  80 zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
  81
  82 topDmd, lazyDmd, seqDmd :: Demand
  83 topDmd  = Top                   -- The most uninformative demand
  84 lazyDmd = Box Abs
  85 seqDmd  = Eval (Poly Abs)       -- Polymorphic seq demand
  86 evalDmd = Box seqDmd            -- Evaluate and return
  87 errDmd  = Box Bot               -- This used to be called X
  88
  89 isStrictDmd :: Demand -> Bool
  90 isStrictDmd Bot      = True
  91 isStrictDmd (Eval _) = True
  92 isStrictDmd (Call _) = True
  93 isStrictDmd (Box d)  = isStrictDmd d
  94 isStrictDmd other    = False
  95
  96 seqDemand :: Demand -> ()
  97 seqDemand (Call d)   = seqDemand d
  98 seqDemand (Eval ds)  = seqDemands ds
  99 seqDemand (Defer ds) = seqDemands ds
 100 seqDemand (Box d)    = seqDemand d
 101 seqDemand _          = ()
 102
 103 seqDemands :: Demands -> ()
 104 seqDemands (Poly d)  = seqDemand d
 105 seqDemands (Prod ds) = seqDemandList ds
 106
 107 seqDemandList :: [Demand] -> ()
 108 seqDemandList [] = ()
 109 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
 110
 111 instance Outputable Demand where
 112     ppr Top  = char 'T'
 113     ppr Abs  = char 'A'
 114     ppr Bot  = char 'B'
 115
 116     ppr (Defer ds)      = char 'D' <> ppr ds
 117     ppr (Eval ds)       = char 'U' <> ppr ds
 118
 119     ppr (Box (Eval ds)) = char 'S' <> ppr ds
 120     ppr (Box Abs)       = char 'L'
 121     ppr (Box Bot)       = char 'X'
 122
 123     ppr (Call d)        = char 'C' <> parens (ppr d)
 124
 125
 126 instance Outputable Demands where
 127     ppr (Poly Abs) = empty
 128     ppr (Poly d)   = parens (ppr d <> char '*')
 129     ppr (Prod ds)  = parens (hcat (map ppr ds))
 130         -- At one time I printed U(AAA) as U, but that
 131         -- confuses (Poly Abs) with (Prod AAA), and the
 132         -- worker/wrapper generation differs slightly for these two
 133         -- [Reason: in the latter case we can avoid passing the arg;
 134         --  see notes with WwLib.mkWWstr_one.]
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Demand types}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 data DmdType = DmdType
 146                     DmdEnv      -- Demand on explicitly-mentioned
 147                                 --      free variables
 148                     [Demand]    -- Demand on arguments
 149                     DmdResult   -- Nature of result
 150
 151         --              IMPORTANT INVARIANT
 152         -- The default demand on free variables not in the DmdEnv is:
 153         -- DmdResult = BotRes        <=>  Bot
 154         -- DmdResult = TopRes/ResCPR <=>  Abs
 155
 156         --              ANOTHER IMPORTANT INVARIANT
 157         -- The Demands in the argument list are never
 158         --      Bot, Defer d
 159         -- Handwavey reason: these don't correspond to calling conventions
 160         -- See DmdAnal.funArgDemand for details
 161
 162 seqDmdType (DmdType env ds res) =
 163   {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
 164
 165 type DmdEnv = VarEnv Demand
 166
 167 data DmdResult = TopRes -- Nothing known
 168                | RetCPR -- Returns a constructed product
 169                | BotRes -- Diverges or errors
 170                deriving( Eq, Show )
 171         -- Equality for fixpoints
 172         -- Show needed for Show in Lex.Token (sigh)
 173
 174 -- Equality needed for fixpoints in DmdAnal
 175 instance Eq DmdType where
 176   (==) (DmdType fv1 ds1 res1)
 177        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
 178                               && ds1 == ds2 && res1 == res2
 179
 180 instance Outputable DmdType where
 181   ppr (DmdType fv ds res)
 182     = hsep [text "DmdType",
 183             hcat (map ppr ds) <> ppr res,
 184             if null fv_elts then empty
 185             else braces (fsep (map pp_elt fv_elts))]
 186     where
 187       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
 188       fv_elts = ufmToList fv
 189
 190 instance Outputable DmdResult where
 191   ppr TopRes = empty      -- Keep these distinct from Demand letters
 192   ppr RetCPR = char 'm'   -- so that we can print strictness sigs as
 193   ppr BotRes = char 'b'   --    dddr
 194                           -- without ambiguity
 195
 196 emptyDmdEnv = emptyVarEnv
 197 topDmdType = DmdType emptyDmdEnv [] TopRes
 198 botDmdType = DmdType emptyDmdEnv [] BotRes
 199
 200 isTopDmdType :: DmdType -> Bool
 201 -- Only used on top-level types, hence the assert
 202 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
 203 isTopDmdType other                   = False
 204
 205 isBotRes :: DmdResult -> Bool
 206 isBotRes BotRes = True
 207 isBotRes other  = False
 208
 209 resTypeArgDmd :: DmdResult -> Demand
 210 -- TopRes and BotRes are polymorphic, so that
 211 --      BotRes = Bot -> BotRes
 212 --      TopRes = Top -> TopRes
 213 -- This function makes that concrete
 214 -- We can get a RetCPR, because of the way in which we are (now)
 215 -- giving CPR info to strict arguments.  On the first pass, when
 216 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
 217 resTypeArgDmd TopRes = Top
 218 resTypeArgDmd RetCPR = Top
 219 resTypeArgDmd BotRes = Bot
 220
 221 returnsCPR :: DmdResult -> Bool
 222 returnsCPR RetCPR = True
 223 returnsCPR other  = False
 224
 225 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 226 mkDmdType fv ds res = DmdType fv ds res
 227
 228 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
 229 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
 230
 231 dmdTypeDepth :: DmdType -> Arity
 232 dmdTypeDepth (DmdType _ ds _) = length ds
 233
 234 dmdTypeRes :: DmdType -> DmdResult
 235 dmdTypeRes (DmdType _ _ res_ty) = res_ty
 236 \end{code}
 237
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection{Strictness signature
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 In a let-bound Id we record its strictness info.
 246 In principle, this strictness info is a demand transformer, mapping
 247 a demand on the Id into a DmdType, which gives
 248         a) the free vars of the Id's value
 249         b) the Id's arguments
 250         c) an indication of the result of applying
 251            the Id to its arguments
 252
 253 However, in fact we store in the Id an extremely emascuated demand transfomer,
 254 namely
 255                 a single DmdType
 256 (Nevertheless we dignify StrictSig as a distinct type.)
 257
 258 This DmdType gives the demands unleashed by the Id when it is applied
 259 to as many arguments as are given in by the arg demands in the DmdType.
 260
 261 For example, the demand transformer described by the DmdType
 262                 DmdType {x -> U(LL)} [V,A] Top
 263 says that when the function is applied to two arguments, it
 264 unleashes demand U(LL) on the free var x, V on the first arg,
 265 and A on the second.
 266
 267 If this same function is applied to one arg, all we can say is
 268 that it uses x with U*(LL), and its arg with demand L.
 269
 270 \begin{code}
 271 newtype StrictSig = StrictSig DmdType
 272                   deriving( Eq )
 273
 274 instance Outputable StrictSig where
 275    ppr (StrictSig ty) = ppr ty
 276
 277 instance Show StrictSig where
 278    show (StrictSig ty) = showSDoc (ppr ty)
 279
 280 mkStrictSig :: DmdType -> StrictSig
 281 mkStrictSig dmd_ty = StrictSig dmd_ty
 282
 283 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 284 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 285
 286 strictSigResInfo :: StrictSig -> DmdResult
 287 strictSigResInfo (StrictSig (DmdType _ _ res)) = res
 288
 289 isTopSig (StrictSig ty) = isTopDmdType ty
 290
 291 topSig = StrictSig topDmdType
 292 botSig = StrictSig botDmdType
 293
 294 -- appIsBottom returns true if an application to n args would diverge
 295 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 296 appIsBottom _                                 _ = False
 297
 298 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 299 isBottomingSig _                                = False
 300
 301 seqStrictSig (StrictSig ty) = seqDmdType ty
 302
 303 pprIfaceStrictSig :: StrictSig -> SDoc
 304 -- Used for printing top-level strictness pragmas in interface files
 305 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 306   = hcat (map ppr dmds) <> ppr res
 307 \end{code}
 308
 309