ghc/compiler/types/Variance.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
   3 %
   4 \section[Variance]{Variance in @Type@ and @TyCon@}
   5
   6 \begin{code}
   7 module Variance(
   8         calcTyConArgVrcs,
   9         tyVarVrc
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import TypeRep          ( Type(..), TyNote(..) )  -- friend
  15 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
  16                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
  17 import DataCon          ( dataConRepArgTys )
  18
  19 import FiniteMap
  20 import Var              ( TyVar )
  21 import VarSet
  22 import Maybes           ( expectJust )
  23 import Outputable
  24 \end{code}
  25
  26
  27 Computing the tyConArgVrcs info
  28 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  29
  30 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
  31 tyvar.  For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
  32 separately.  Note that this is information about occurrences of type
  33 variables, not usages of term variables.
  34
  35 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
  36 syntycons only* such that all tycons referred to (by mutual recursion)
  37 appear in the list.  The fixpointing will be done on this set of
  38 tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
  39 be (knot-tyingly?) stuck back into the appropriate fields.
  40
  41 \begin{code}
  42 calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs
  43
  44 calcTyConArgVrcs tycons
  45   = tcaoFix initial_oi
  46   where
  47
  48     initial_oi :: FiniteMap TyCon ArgVrcs
  49     initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
  50     initial tc   = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
  51                          -- make pessimistic assumption (and warn)
  52                          abstractVrcs tc
  53                        else
  54                          replicate (tyConArity tc) (False,False)
  55
  56     tcaoFix :: FiniteMap TyCon ArgVrcs   -- initial ArgVrcs per tycon
  57             -> FiniteMap TyCon ArgVrcs   -- fixpointed ArgVrcs per tycon
  58
  59     tcaoFix oi = let (changed,oi') = foldFM (\ tc pms
  60                                                (changed,oi')
  61                                                -> let pms' = tcaoIter oi' tc  -- seq not simult
  62                                                   in  (changed || (pms /= pms'),
  63                                                        addToFM oi' tc pms'))
  64                                             (False,oi)  -- seq not simult for faster fixpting
  65                                             oi
  66                  in  if changed
  67                      then tcaoFix oi'
  68                      else oi'
  69
  70     tcaoIter :: FiniteMap TyCon ArgVrcs  -- reference ArgVrcs (initial)
  71              -> TyCon                    -- tycon to update
  72              -> ArgVrcs                  -- new ArgVrcs for tycon
  73
  74     tcaoIter oi tc | isAlgTyCon tc
  75       = if null data_cons then
  76                 -- Abstract types get uninformative variances
  77             abstractVrcs tc
  78         else
  79             map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
  80                 vs
  81       where
  82         data_cons = tyConDataConsIfAvailable tc
  83         vs        = tyConTyVars tc
  84         argtys    = concatMap dataConRepArgTys data_cons
  85         myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
  86                                                    tyConArgVrcs_maybe tc)
  87                                            tc
  88                          -- we use the already-computed result for tycons not in this SCC
  89
  90     tcaoIter oi tc | isSynTyCon tc
  91       = let (tyvs,ty) = getSynTyConDefn tc
  92             myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $
  93                                                   tyConArgVrcs_maybe tc)
  94                                                tc
  95                         -- we use the already-computed result for tycons not in this SCC
  96         in  map (\v -> vrcInTy myfao v ty) tyvs
  97
  98
  99 abstractVrcs :: TyCon -> ArgVrcs
 100 abstractVrcs tc =
 101 #ifdef DEBUG
 102                   pprTrace "Vrc: abstract tycon:" (ppr tc) $
 103 #endif
 104                   warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True)
 105
 106 warn_abstract_vrcs
 107 -- we pull the message out as a CAF so the warning only appears *once*
 108   = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
 109         ++ "         Use -fno-prune-tydecls to fix.") $
 110                 ()
 111 \end{code}
 112
 113
 114 Variance of tyvars in a type
 115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 116
 117 A general variance-check function.  We pass a function for determining
 118 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
 119 value; otherwise this should be looked up from the tycon's own
 120 tyConArgVrcs.
 121
 122 \begin{code}
 123 vrcInTy :: (TyCon -> ArgVrcs)  -- function to get argVrcs of a tycon (break out of recursion)
 124         -> TyVar               -- tyvar to check Vrcs of
 125         -> Type                -- type to check for occ in
 126         -> (Bool,Bool)         -- (occurs positively, occurs negatively)
 127
 128 vrcInTy fao v (NoteTy (SynNote _)   ty) = vrcInTy fao v ty
 129                         -- SynTyCon doesn't neccessarily have vrcInfo at this point,
 130                         -- so don't try and use it
 131
 132 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
 133                                           then vrcInTy fao v ty
 134                                           else (False,False)
 135                         -- note that ftv cannot be calculated as occPos||occNeg,
 136                         -- since if a tyvar occurs only as unused tyconarg,
 137                         -- occPos==occNeg==False, but ftv=True
 138
 139 vrcInTy fao v (TyVarTy v')              = if v==v'
 140                                           then (True,False)
 141                                           else (False,False)
 142
 143 vrcInTy fao v (AppTy ty1 ty2)           = if vrcInTy fao v ty2 /= (False,False)
 144                                           then (True,True)
 145                                           else vrcInTy fao v ty1
 146                         -- ty1 is probably unknown (or it would have been beta-reduced);
 147                         -- hence if v occurs in ty2 at all then it could occur with
 148                         -- either variance.  Otherwise it occurs as it does in ty1.
 149
 150 vrcInTy fao v (FunTy ty1 ty2)           = negVrc (vrcInTy fao v ty1)
 151                                           `orVrc`
 152                                           vrcInTy fao v ty2
 153
 154 vrcInTy fao v (ForAllTy v' ty)          = if v==v'
 155                                           then (False,False)
 156                                           else vrcInTy fao v ty
 157
 158 vrcInTy fao v (TyConApp tc tys)         = let pms1 = map (vrcInTy fao v) tys
 159                                               pms2 = fao tc
 160                                           in  orVrcs (zipWith timesVrc pms1 pms2)
 161
 162 vrcInTy fao v (UsageTy u ty)            = vrcInTy fao v u `orVrc` vrcInTy fao v ty
 163 \end{code}
 164
 165
 166 External entry point: assumes tyconargvrcs already computed.
 167
 168 \begin{code}
 169 tyVarVrc :: TyVar               -- tyvar to check Vrc of
 170          -> Type                -- type to check for occ in
 171          -> (Bool,Bool)         -- (occurs positively, occurs negatively)
 172
 173 tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe)
 174 \end{code}
 175
 176
 177 Variance algebra
 178 ~~~~~~~~~~~~~~~~
 179
 180 \begin{code}
 181 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
 182 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
 183
 184 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
 185 orVrcs = foldl orVrc (False,False)
 186
 187 negVrc :: (Bool,Bool) -> (Bool,Bool)
 188 negVrc (p1,m1) = (m1,p1)
 189
 190 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
 191 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
 192                     (False,False) as
 193
 194 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
 195 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
 196                             p1 && m2 || m1 && p2)
 197 \end{code}