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