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(..), Deferredness(..), topDmd,
   9         StrictSig(..), topSig, botSig, mkStrictSig,
  10         DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
  11         DmdEnv, emptyDmdEnv,
  12         DmdResult(..), isBotRes
  13      ) where
  14
  15 #include "HsVersions.h"
  16
  17 import BasicTypes       ( Arity )
  18 import Var              ( Id )
  19 import VarEnv           ( VarEnv, emptyVarEnv )
  20 import UniqFM           ( ufmToList )
  21 import qualified Demand
  22 import Outputable
  23 \end{code}
  24
  25
  26 %************************************************************************
  27 %*                                                                      *
  28 \subsection{Strictness signatures
  29 %*                                                                      *
  30 %************************************************************************
  31
  32 \begin{code}
  33 data StrictSig = StrictSig Arity DmdType
  34                deriving( Eq )
  35         -- Equality needed when comparing strictness
  36         -- signatures for fixpoint finding
  37
  38 topSig = StrictSig 0 topDmdType
  39 botSig = StrictSig 0 botDmdType
  40
  41 mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
  42 mkStrictSig id arity ty
  43   = WARN( arity /= dmdTypeDepth ty, ppr id <+> (ppr arity $$ ppr ty) )
  44     StrictSig arity ty
  45
  46 instance Outputable StrictSig where
  47   ppr (StrictSig arity ty) = ppr ty
  48 \end{code}
  49
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{Demand types}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 \begin{code}
  58 data DmdType = DmdType
  59                     DmdEnv      -- Demand on explicitly-mentioned
  60                                 --      free variables
  61                     [Demand]    -- Demand on arguments
  62                     DmdResult   -- Nature of result
  63
  64         --              IMPORTANT INVARIANT
  65         -- The default demand on free variables not in the DmdEnv is:
  66         -- DmdResult = BotRes        <=>  Bot
  67         -- DmdResult = TopRes/ResCPR <=>  Abs
  68
  69 type DmdEnv = VarEnv Demand
  70
  71 data DmdResult = TopRes -- Nothing known
  72                | RetCPR -- Returns a constructed product
  73                | BotRes -- Diverges or errors
  74                deriving( Eq )
  75
  76 -- Equality needed for fixpoints in DmdAnal
  77 instance Eq DmdType where
  78   (==) (DmdType fv1 ds1 res1)
  79        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
  80                               && ds1 == ds2 && res1 == res2
  81
  82 instance Outputable DmdType where
  83   ppr (DmdType fv ds res)
  84     = hsep [text "DmdType",
  85             hcat (map ppr ds) <> ppr res,
  86             braces (fsep (map pp_elt (ufmToList fv)))]
  87     where
  88       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
  89
  90 instance Outputable DmdResult where
  91   ppr TopRes = char 'T'
  92   ppr RetCPR = char 'M'
  93   ppr BotRes = char 'X'
  94
  95 emptyDmdEnv = emptyVarEnv
  96 topDmdType = DmdType emptyDmdEnv [] TopRes
  97 botDmdType = DmdType emptyDmdEnv [] BotRes
  98
  99 isBotRes :: DmdResult -> Bool
 100 isBotRes BotRes = True
 101 isBotRes other  = False
 102
 103 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 104 mkDmdType fv ds res = DmdType fv ds res
 105
 106 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
 107 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
 108
 109 dmdTypeDepth :: DmdType -> Arity
 110 dmdTypeDepth (DmdType _ ds _) = length ds
 111 \end{code}
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{Demands}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 data Demand
 122   = Lazy                -- L; used for unlifted types too, so that
 123                         --      A `lub` L = L
 124   | Abs                 -- A
 125   | Call Demand         -- C(d)
 126   | Eval                -- V
 127   | Seq Keepity         -- S/U(ds)
 128         Deferredness
 129         [Demand]
 130   | Err                 -- X
 131   | Bot                 -- B
 132   deriving( Eq )
 133         -- Equality needed for fixpoints in DmdAnal
 134
 135 data Deferredness = Now | Defer
 136                   deriving( Eq )
 137
 138 data Keepity = Keep | Drop
 139              deriving( Eq )
 140
 141 topDmd :: Demand        -- The most uninformative demand
 142 topDmd = Lazy
 143
 144 instance Outputable Demand where
 145     ppr Lazy         = char 'L'
 146     ppr Abs          = char 'A'
 147     ppr Eval         = char 'V'
 148     ppr Err          = char 'X'
 149     ppr Bot          = char 'B'
 150     ppr (Call d)     = char 'C' <> parens (ppr d)
 151     ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
 152
 153 instance Outputable Deferredness where
 154   ppr Now   = empty
 155   ppr Defer = char '*'
 156
 157 instance Outputable Keepity where
 158   ppr Keep = char 'S'
 159   ppr Drop = char 'U'
 160 \end{code}
 161