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(..), topDmd,
   9         StrictSig(..), topSig, botSig, mkStrictSig,
  10         DmdType(..), topDmdType, mkDmdFun,
  11         Result(..)
  12      ) where
  13
  14 #include "HsVersions.h"
  15
  16 import BasicTypes       ( Arity )
  17 import qualified Demand
  18 import Outputable
  19 \end{code}
  20
  21
  22 %************************************************************************
  23 %*                                                                      *
  24 \subsection{Strictness signatures
  25 %*                                                                      *
  26 %************************************************************************
  27
  28 \begin{code}
  29 data StrictSig = StrictSig Arity DmdType
  30                deriving( Eq )
  31         -- Equality needed when comparing strictness
  32         -- signatures for fixpoint finding
  33
  34 topSig = StrictSig 0 topDmdType
  35 botSig = StrictSig 0 botDmdType
  36
  37 mkStrictSig :: Arity -> DmdType -> StrictSig
  38 mkStrictSig arity ty
  39   = WARN( arity /= dmdTypeDepth ty, ppr arity $$ ppr ty )
  40     StrictSig arity ty
  41
  42 instance Outputable StrictSig where
  43   ppr (StrictSig arity ty) = ppr ty
  44 \end{code}
  45
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection{Demand types}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 \begin{code}
  54 data DmdType = DmdRes Result | DmdFun Demand DmdType
  55              deriving( Eq )
  56         -- Equality needed for fixpoints in DmdAnal
  57
  58 data Result = TopRes    -- Nothing known
  59             | RetCPR    -- Returns a constructed product
  60             | BotRes    -- Diverges or errors
  61             deriving( Eq )
  62         -- Equality needed for fixpoints in DmdAnal
  63
  64 instance Outputable DmdType where
  65   ppr (DmdRes TopRes) = char 'T'
  66   ppr (DmdRes RetCPR) = char 'M'
  67   ppr (DmdRes BotRes) = char 'X'
  68   ppr (DmdFun d r)    = ppr d <> ppr r
  69
  70 topDmdType = DmdRes TopRes
  71 botDmdType = DmdRes BotRes
  72
  73 mkDmdFun :: [Demand] -> Result -> DmdType
  74 mkDmdFun ds res = foldr DmdFun (DmdRes res) ds
  75
  76 dmdTypeDepth :: DmdType -> Arity
  77 dmdTypeDepth (DmdFun _ ty) = 1 + dmdTypeDepth ty
  78 dmdTypeDepth (DmdRes _)    = 0
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{Demands}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 data Demand
  90   = Lazy                -- L; used for unlifted types too, so that
  91                         --      A `lub` L = L
  92   | Abs                 -- A
  93   | Call Demand         -- C(d)
  94   | Eval                -- V
  95   | Seq Keepity         -- S/U(ds)
  96         [Demand]
  97   | Err                 -- X
  98   | Bot                 -- B
  99   deriving( Eq )
 100         -- Equality needed for fixpoints in DmdAnal
 101
 102 data Keepity = Keep | Drop
 103              deriving( Eq )
 104
 105 topDmd :: Demand        -- The most uninformative demand
 106 topDmd = Lazy
 107
 108 instance Outputable Demand where
 109     ppr Lazy       = char 'L'
 110     ppr Abs        = char 'A'
 111     ppr Eval       = char 'V'
 112     ppr Err        = char 'X'
 113     ppr Bot        = char 'B'
 114     ppr (Call d)   = char 'C' <> parens (ppr d)
 115     ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
 116
 117 instance Outputable Keepity where
 118   ppr Keep = char 'S'
 119   ppr Drop = char 'U'
 120 \end{code}
 121