ghc/compiler/basicTypes/VarEnv.lhs

   1
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section{@VarEnvs@: Variable environments}
   5
   6 \begin{code}
   7 module VarEnv (
   8         VarEnv, IdEnv, TyVarEnv,
   9         emptyVarEnv, unitVarEnv, mkVarEnv,
  10         elemVarEnv, varEnvElts,
  11         extendVarEnv, extendVarEnv_C, extendVarEnvList,
  12         plusVarEnv, plusVarEnv_C,
  13         delVarEnvList, delVarEnv,
  14         lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
  15         mapVarEnv, zipVarEnv,
  16         modifyVarEnv, modifyVarEnv_Directly,
  17         isEmptyVarEnv, foldVarEnv,
  18         lookupVarEnv_Directly,
  19         filterVarEnv_Directly,
  20
  21         -- InScopeSet
  22         InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
  23         extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
  24         getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
  25
  26         -- RnEnv2 and its operations
  27         RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
  28                 rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
  29
  30         -- TidyEnvs
  31         TidyEnv, emptyTidyEnv
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import OccName    ( TidyOccEnv, emptyTidyOccEnv )
  37 import Var        ( Var, setVarUnique )
  38 import VarSet
  39 import UniqFM
  40 import Unique     ( Unique, deriveUnique, getUnique )
  41 import Util       ( zipEqual, foldl2 )
  42 import Maybes     ( orElse, isJust )
  43 import CmdLineOpts      ( opt_PprStyle_Debug )
  44 import Outputable
  45 import FastTypes
  46 \end{code}
  47
  48
  49 %************************************************************************
  50 %*                                                                      *
  51                 In-scope sets
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 \begin{code}
  56 data InScopeSet = InScope (VarEnv Var) FastInt
  57         -- The Int# is a kind of hash-value used by uniqAway
  58         -- For example, it might be the size of the set
  59         -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
  60
  61 instance Outputable InScopeSet where
  62   ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
  63
  64 emptyInScopeSet :: InScopeSet
  65 emptyInScopeSet = InScope emptyVarSet 1#
  66
  67 getInScopeVars ::  InScopeSet -> VarEnv Var
  68 getInScopeVars (InScope vs _) = vs
  69
  70 mkInScopeSet :: VarEnv Var -> InScopeSet
  71 mkInScopeSet in_scope = InScope in_scope 1#
  72
  73 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
  74 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
  75
  76 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
  77 extendInScopeSetList (InScope in_scope n) vs
  78    = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
  79                     (n +# iUnbox (length vs))
  80
  81 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
  82 -- Exploit the fact that the in-scope "set" is really a map
  83 --      Make old_v map to new_v
  84 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
  85
  86 delInScopeSet :: InScopeSet -> Var -> InScopeSet
  87 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
  88
  89 elemInScopeSet :: Var -> InScopeSet -> Bool
  90 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
  91
  92 lookupInScope :: InScopeSet -> Var -> Maybe Var
  93 -- It's important to look for a fixed point
  94 -- When we see (case x of y { I# v -> ... })
  95 -- we add  [x -> y] to the in-scope set (Simplify.simplCaseBinder).
  96 -- When we lookup up an occurrence of x, we map to y, but then
  97 -- we want to look up y in case it has acquired more evaluation information by now.
  98 lookupInScope (InScope in_scope n) v
  99   = go v
 100   where
 101     go v = case lookupVarEnv in_scope v of
 102                 Just v' | v == v'   -> Just v'  -- Reached a fixed point
 103                         | otherwise -> go v'
 104                 Nothing             -> Nothing
 105 \end{code}
 106
 107 \begin{code}
 108 uniqAway :: InScopeSet -> Var -> Var
 109 -- (uniqAway in_scope v) finds a unique that is not used in the
 110 -- in-scope set, and gives that to v.  It starts with v's current unique, of course,
 111 -- in the hope that it won't have to change it, and thereafter uses a combination
 112 -- of that and the hash-code found in the in-scope set
 113 uniqAway in_scope var
 114   | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one
 115   | otherwise                     = var                         -- Nothing to do
 116
 117 uniqAway' :: InScopeSet -> Var -> Var
 118 -- This one *always* makes up a new variable
 119 uniqAway' (InScope set n) var
 120   = try 1#
 121   where
 122     orig_unique = getUnique var
 123     try k
 124 #ifdef DEBUG
 125           | k ># 1000#
 126           = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
 127 #endif
 128           | uniq `elemVarSetByKey` set = try (k +# 1#)
 129 #ifdef DEBUG
 130           | opt_PprStyle_Debug && k ># 3#
 131           = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
 132             setVarUnique var uniq
 133 #endif
 134           | otherwise = setVarUnique var uniq
 135           where
 136             uniq = deriveUnique orig_unique (iBox (n *# k))
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142                 Dual renaming
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 When we are comparing (or matching) types or terms, we are faced with
 147 "going under" corresponding binders.  E.g. when comparing
 148         \x. e1  ~   \y. e2
 149
 150 Basically we want to rename [x->y] or [y->x], but there are lots of
 151 things we must be careful of.  In particular, x might be free in e2, or
 152 y in e1.  So the idea is that we come up with a fresh binder that is free
 153 in neither, and rename x and y respectively.  That means we must maintain
 154         a) a renaming for the left-hand expression
 155         b) a renaming for the right-hand expressions
 156         c) an in-scope set
 157
 158 Furthermore, when matching, we want to be able to have an 'occurs check',
 159 to prevent
 160         \x. f   ~   \y. y
 161 matching with f->y.  So for each expression we want to know that set of
 162 locally-bound variables. That is precisely the domain of the mappings (a)
 163 and (b), but we must ensure that we always extend the mappings as we go in.
 164
 165
 166 \begin{code}
 167 data RnEnv2
 168   = RV2 { envL     :: VarEnv Var        -- Renaming for Left term
 169         , envR     :: VarEnv Var        -- Renaming for Right term
 170         , in_scope :: InScopeSet }      -- In scope in left or right terms
 171
 172 -- The renamings envL and envR are *guaranteed* to contain a binding
 173 -- for every variable bound as we go into the term, even if it is not
 174 -- renamed.  That way we can ask what variables are locally bound
 175 -- (inRnEnvL, inRnEnvR)
 176
 177 mkRnEnv2 :: InScopeSet -> RnEnv2
 178 mkRnEnv2 vars = RV2     { envL     = emptyVarEnv
 179                         , envR     = emptyVarEnv
 180                         , in_scope = vars }
 181
 182 rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
 183 -- Arg lists must be of equal length
 184 rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR
 185
 186 rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
 187 -- (rnBndr2 env bL bR) go under a binder bL in the Left term 1,
 188 --                     and binder bR in the Right term
 189 -- It finds a new binder, new_b,
 190 -- and returns an environment mapping bL->new_b and bR->new_b resp.
 191 rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
 192   = RV2 { envL     = extendVarEnv envL bL new_b   -- See Note
 193         , envR     = extendVarEnv envR bR new_b   -- [Rebinding]
 194         , in_scope = extendInScopeSet in_scope new_b }
 195   where
 196         -- Find a new binder not in scope in either term
 197     new_b | not (bL `elemInScopeSet` in_scope) = bL
 198           | not (bR `elemInScopeSet` in_scope) = bR
 199           | otherwise                          = uniqAway' in_scope bL
 200
 201         -- Note [Rebinding]
 202         -- If the new var is the same as the old one, note that
 203         -- the extendVarEnv *deletes* any current renaming
 204         -- E.g.   (\x. \x. ...)  ~  (\y. \z. ...)
 205         --
 206         --   Inside \x  \y      { [x->y], [y->y],       {y} }
 207         --       \x  \z         { [x->x], [y->y, z->x], {y,x} }
 208
 209 rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
 210 -- Used when there's a binder on one side or the other only
 211 -- Useful when eta-expanding
 212 rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
 213   = (RV2 { envL     = extendVarEnv envL bL new_b
 214          , envR     = envR
 215          , in_scope = extendInScopeSet in_scope new_b }, new_b)
 216   where
 217     new_b | not (bL `elemInScopeSet` in_scope) = bL
 218           | otherwise                          = uniqAway' in_scope bL
 219
 220 rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
 221   = (RV2 { envL     = envL
 222          , envR     = extendVarEnv envR bR new_b
 223          , in_scope = extendInScopeSet in_scope new_b }, new_b)
 224   where
 225     new_b | not (bR `elemInScopeSet` in_scope) = bR
 226           | otherwise                          = uniqAway' in_scope bR
 227
 228 rnOccL, rnOccR :: RnEnv2 -> Var -> Var
 229 -- Look up the renaming of an occurrence in the left or right term
 230 rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
 231 rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
 232
 233 inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
 234 -- Tells whether a variable is locally bound
 235 inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v)
 236 inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v)
 237
 238 nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
 239 nukeRnEnvL env = env { envL = emptyVarEnv }
 240 nukeRnEnvR env = env { envR = emptyVarEnv }
 241 \end{code}
 242
 243
 244 %************************************************************************
 245 %*                                                                      *
 246                 Tidying
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 When tidying up print names, we keep a mapping of in-scope occ-names
 251 (the TidyOccEnv) and a Var-to-Var of the current renamings.
 252
 253 \begin{code}
 254 type TidyEnv = (TidyOccEnv, VarEnv Var)
 255
 256 emptyTidyEnv :: TidyEnv
 257 emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
 258 \end{code}
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection{@VarEnv@s}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 type VarEnv elt   = UniqFM elt
 269 type IdEnv elt    = VarEnv elt
 270 type TyVarEnv elt = VarEnv elt
 271
 272 emptyVarEnv       :: VarEnv a
 273 mkVarEnv          :: [(Var, a)] -> VarEnv a
 274 zipVarEnv         :: [Var] -> [a] -> VarEnv a
 275 unitVarEnv        :: Var -> a -> VarEnv a
 276 extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a
 277 extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
 278 plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a
 279 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
 280
 281 lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
 282 filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
 283 delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
 284 delVarEnv         :: VarEnv a -> Var -> VarEnv a
 285 plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
 286 mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b
 287 modifyVarEnv      :: (a -> a) -> VarEnv a -> Var -> VarEnv a
 288 varEnvElts        :: VarEnv a -> [a]
 289
 290 isEmptyVarEnv     :: VarEnv a -> Bool
 291 lookupVarEnv      :: VarEnv a -> Var -> Maybe a
 292 lookupVarEnv_NF   :: VarEnv a -> Var -> a
 293 lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
 294 elemVarEnv        :: Var -> VarEnv a -> Bool
 295 foldVarEnv        :: (a -> b -> b) -> b -> VarEnv a -> b
 296 \end{code}
 297
 298 \begin{code}
 299 elemVarEnv       = elemUFM
 300 extendVarEnv     = addToUFM
 301 extendVarEnv_C   = addToUFM_C
 302 extendVarEnvList = addListToUFM
 303 plusVarEnv_C     = plusUFM_C
 304 delVarEnvList    = delListFromUFM
 305 delVarEnv        = delFromUFM
 306 plusVarEnv       = plusUFM
 307 lookupVarEnv     = lookupUFM
 308 lookupWithDefaultVarEnv = lookupWithDefaultUFM
 309 mapVarEnv        = mapUFM
 310 mkVarEnv         = listToUFM
 311 emptyVarEnv      = emptyUFM
 312 varEnvElts       = eltsUFM
 313 unitVarEnv       = unitUFM
 314 isEmptyVarEnv    = isNullUFM
 315 foldVarEnv       = foldUFM
 316 lookupVarEnv_Directly = lookupUFM_Directly
 317 filterVarEnv_Directly = filterUFM_Directly
 318
 319 zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
 320 lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
 321 \end{code}
 322
 323 @modifyVarEnv@: Look up a thing in the VarEnv,
 324 then mash it with the modify function, and put it back.
 325
 326 \begin{code}
 327 modifyVarEnv mangle_fn env key
 328   = case (lookupVarEnv env key) of
 329       Nothing -> env
 330       Just xx -> extendVarEnv env key (mangle_fn xx)
 331
 332 modifyVarEnv_Directly mangle_fn env key
 333   = case (lookupUFM_Directly env key) of
 334       Nothing -> env
 335       Just xx -> addToUFM_Directly env key (mangle_fn xx)
 336 \end{code}