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, 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,
  22         pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
  23      ) where
  24
  25 #include "HsVersions.h"
  26
  27 import StaticFlags      ( 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 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection{Strictness signature
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 In a let-bound Id we record its strictness info.
 255 In principle, this strictness info is a demand transformer, mapping
 256 a demand on the Id into a DmdType, which gives
 257         a) the free vars of the Id's value
 258         b) the Id's arguments
 259         c) an indication of the result of applying
 260            the Id to its arguments
 261
 262 However, in fact we store in the Id an extremely emascuated demand transfomer,
 263 namely
 264                 a single DmdType
 265 (Nevertheless we dignify StrictSig as a distinct type.)
 266
 267 This DmdType gives the demands unleashed by the Id when it is applied
 268 to as many arguments as are given in by the arg demands in the DmdType.
 269
 270 For example, the demand transformer described by the DmdType
 271                 DmdType {x -> U(LL)} [V,A] Top
 272 says that when the function is applied to two arguments, it
 273 unleashes demand U(LL) on the free var x, V on the first arg,
 274 and A on the second.
 275
 276 If this same function is applied to one arg, all we can say is
 277 that it uses x with U*(LL), and its arg with demand L.
 278
 279 \begin{code}
 280 newtype StrictSig = StrictSig DmdType
 281                   deriving( Eq )
 282
 283 instance Outputable StrictSig where
 284    ppr (StrictSig ty) = ppr ty
 285
 286 instance Show StrictSig where
 287    show (StrictSig ty) = showSDoc (ppr ty)
 288
 289 mkStrictSig :: DmdType -> StrictSig
 290 mkStrictSig dmd_ty = StrictSig dmd_ty
 291
 292 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 293 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 294
 295 isTopSig (StrictSig ty) = isTopDmdType ty
 296
 297 topSig, botSig, cprSig :: StrictSig
 298 topSig = StrictSig topDmdType
 299 botSig = StrictSig botDmdType
 300 cprSig = StrictSig cprDmdType
 301
 302
 303 -- appIsBottom returns true if an application to n args would diverge
 304 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 305 appIsBottom _                                 _ = False
 306
 307 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 308 isBottomingSig _                                = False
 309
 310 seqStrictSig (StrictSig ty) = seqDmdType ty
 311
 312 pprIfaceStrictSig :: StrictSig -> SDoc
 313 -- Used for printing top-level strictness pragmas in interface files
 314 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 315   = hcat (map ppr dmds) <> ppr res
 316 \end{code}
 317
 318