PageRenderTime 44ms CodeModel.GetById 17ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/basicTypes/VarEnv.lhs

https://bitbucket.org/khibino/ghc-hack
Haskell | 458 lines | 301 code | 64 blank | 93 comment | 5 complexity | bfaa555e2c5e64312197b6f3454ceff5 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0
  1. %
  2. % (c) The University of Glasgow 2006
  3. % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  4. %
  5. \begin{code}
  6. {-# OPTIONS -fno-warn-tabs #-}
  7. -- The above warning supression flag is a temporary kludge.
  8. -- While working on this module you are encouraged to remove it and
  9. -- detab the module (please do the detabbing in a separate patch). See
  10. -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  11. -- for details
  12. module VarEnv (
  13. -- * Var, Id and TyVar environments (maps)
  14. VarEnv, IdEnv, TyVarEnv, CoVarEnv,
  15. -- ** Manipulating these environments
  16. emptyVarEnv, unitVarEnv, mkVarEnv,
  17. elemVarEnv, varEnvElts, varEnvKeys,
  18. extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList,
  19. plusVarEnv, plusVarEnv_C, alterVarEnv,
  20. delVarEnvList, delVarEnv,
  21. minusVarEnv, intersectsVarEnv,
  22. lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
  23. mapVarEnv, zipVarEnv,
  24. modifyVarEnv, modifyVarEnv_Directly,
  25. isEmptyVarEnv, foldVarEnv,
  26. elemVarEnvByKey, lookupVarEnv_Directly,
  27. filterVarEnv_Directly, restrictVarEnv,
  28. -- * The InScopeSet type
  29. InScopeSet,
  30. -- ** Operations on InScopeSets
  31. emptyInScopeSet, mkInScopeSet, delInScopeSet,
  32. extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
  33. getInScopeVars, lookupInScope, lookupInScope_Directly,
  34. unionInScope, elemInScopeSet, uniqAway,
  35. -- * The RnEnv2 type
  36. RnEnv2,
  37. -- ** Operations on RnEnv2s
  38. mkRnEnv2, rnBndr2, rnBndrs2,
  39. rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,
  40. rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
  41. delBndrL, delBndrR, delBndrsL, delBndrsR,
  42. addRnInScopeSet,
  43. rnEtaL, rnEtaR,
  44. rnInScope, rnInScopeSet, lookupRnInScope,
  45. -- * TidyEnv and its operation
  46. TidyEnv,
  47. emptyTidyEnv
  48. ) where
  49. import OccName
  50. import Var
  51. import VarSet
  52. import UniqFM
  53. import Unique
  54. import Util
  55. import Maybes
  56. import Outputable
  57. import FastTypes
  58. import StaticFlags
  59. import FastString
  60. \end{code}
  61. %************************************************************************
  62. %* *
  63. In-scope sets
  64. %* *
  65. %************************************************************************
  66. \begin{code}
  67. -- | A set of variables that are in scope at some point
  68. data InScopeSet = InScope (VarEnv Var) FastInt
  69. -- The (VarEnv Var) is just a VarSet. But we write it like
  70. -- this to remind ourselves that you can look up a Var in
  71. -- the InScopeSet. Typically the InScopeSet contains the
  72. -- canonical version of the variable (e.g. with an informative
  73. -- unfolding), so this lookup is useful.
  74. --
  75. -- INVARIANT: the VarEnv maps (the Unique of) a variable to
  76. -- a variable with the same Uniqua. (This was not
  77. -- the case in the past, when we had a grevious hack
  78. -- mapping var1 to var2.
  79. --
  80. -- The FastInt is a kind of hash-value used by uniqAway
  81. -- For example, it might be the size of the set
  82. -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
  83. instance Outputable InScopeSet where
  84. ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s
  85. emptyInScopeSet :: InScopeSet
  86. emptyInScopeSet = InScope emptyVarSet (_ILIT(1))
  87. getInScopeVars :: InScopeSet -> VarEnv Var
  88. getInScopeVars (InScope vs _) = vs
  89. mkInScopeSet :: VarEnv Var -> InScopeSet
  90. mkInScopeSet in_scope = InScope in_scope (_ILIT(1))
  91. extendInScopeSet :: InScopeSet -> Var -> InScopeSet
  92. extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))
  93. extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
  94. extendInScopeSetList (InScope in_scope n) vs
  95. = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
  96. (n +# iUnbox (length vs))
  97. extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
  98. extendInScopeSetSet (InScope in_scope n) vs
  99. = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))
  100. delInScopeSet :: InScopeSet -> Var -> InScopeSet
  101. delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
  102. elemInScopeSet :: Var -> InScopeSet -> Bool
  103. elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
  104. -- | Look up a variable the 'InScopeSet'. This lets you map from
  105. -- the variable's identity (unique) to its full value.
  106. lookupInScope :: InScopeSet -> Var -> Maybe Var
  107. lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v
  108. lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
  109. lookupInScope_Directly (InScope in_scope _) uniq
  110. = lookupVarEnv_Directly in_scope uniq
  111. unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
  112. unionInScope (InScope s1 _) (InScope s2 n2)
  113. = InScope (s1 `plusVarEnv` s2) n2
  114. \end{code}
  115. \begin{code}
  116. -- | @uniqAway in_scope v@ finds a unique that is not used in the
  117. -- in-scope set, and gives that to v.
  118. uniqAway :: InScopeSet -> Var -> Var
  119. -- It starts with v's current unique, of course, in the hope that it won't
  120. -- have to change, and thereafter uses a combination of that and the hash-code
  121. -- found in the in-scope set
  122. uniqAway in_scope var
  123. | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one
  124. | otherwise = var -- Nothing to do
  125. uniqAway' :: InScopeSet -> Var -> Var
  126. -- This one *always* makes up a new variable
  127. uniqAway' (InScope set n) var
  128. = try (_ILIT(1))
  129. where
  130. orig_unique = getUnique var
  131. try k
  132. | debugIsOn && (k ># _ILIT(1000))
  133. = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
  134. | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
  135. | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3))
  136. = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
  137. setVarUnique var uniq
  138. | otherwise = setVarUnique var uniq
  139. where
  140. uniq = deriveUnique orig_unique (iBox (n *# k))
  141. \end{code}
  142. %************************************************************************
  143. %* *
  144. Dual renaming
  145. %* *
  146. %************************************************************************
  147. \begin{code}
  148. -- | When we are comparing (or matching) types or terms, we are faced with
  149. -- \"going under\" corresponding binders. E.g. when comparing:
  150. --
  151. -- > \x. e1 ~ \y. e2
  152. --
  153. -- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of
  154. -- things we must be careful of. In particular, @x@ might be free in @e2@, or
  155. -- y in @e1@. So the idea is that we come up with a fresh binder that is free
  156. -- in neither, and rename @x@ and @y@ respectively. That means we must maintain:
  157. --
  158. -- 1. A renaming for the left-hand expression
  159. --
  160. -- 2. A renaming for the right-hand expressions
  161. --
  162. -- 3. An in-scope set
  163. --
  164. -- Furthermore, when matching, we want to be able to have an 'occurs check',
  165. -- to prevent:
  166. --
  167. -- > \x. f ~ \y. y
  168. --
  169. -- matching with [@f@ -> @y@]. So for each expression we want to know that set of
  170. -- locally-bound variables. That is precisely the domain of the mappings 1.
  171. -- and 2., but we must ensure that we always extend the mappings as we go in.
  172. --
  173. -- All of this information is bundled up in the 'RnEnv2'
  174. data RnEnv2
  175. = RV2 { envL :: VarEnv Var -- Renaming for Left term
  176. , envR :: VarEnv Var -- Renaming for Right term
  177. , in_scope :: InScopeSet } -- In scope in left or right terms
  178. -- The renamings envL and envR are *guaranteed* to contain a binding
  179. -- for every variable bound as we go into the term, even if it is not
  180. -- renamed. That way we can ask what variables are locally bound
  181. -- (inRnEnvL, inRnEnvR)
  182. mkRnEnv2 :: InScopeSet -> RnEnv2
  183. mkRnEnv2 vars = RV2 { envL = emptyVarEnv
  184. , envR = emptyVarEnv
  185. , in_scope = vars }
  186. addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2
  187. addRnInScopeSet env vs
  188. | isEmptyVarEnv vs = env
  189. | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs }
  190. rnInScope :: Var -> RnEnv2 -> Bool
  191. rnInScope x env = x `elemInScopeSet` in_scope env
  192. rnInScopeSet :: RnEnv2 -> InScopeSet
  193. rnInScopeSet = in_scope
  194. rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
  195. -- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length
  196. rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR
  197. rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
  198. -- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,
  199. -- and binder @bR@ in the Right term.
  200. -- It finds a new binder, @new_b@,
  201. -- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@
  202. rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
  203. = RV2 { envL = extendVarEnv envL bL new_b -- See Note
  204. , envR = extendVarEnv envR bR new_b -- [Rebinding]
  205. , in_scope = extendInScopeSet in_scope new_b }
  206. where
  207. -- Find a new binder not in scope in either term
  208. new_b | not (bL `elemInScopeSet` in_scope) = bL
  209. | not (bR `elemInScopeSet` in_scope) = bR
  210. | otherwise = uniqAway' in_scope bL
  211. -- Note [Rebinding]
  212. -- If the new var is the same as the old one, note that
  213. -- the extendVarEnv *deletes* any current renaming
  214. -- E.g. (\x. \x. ...) ~ (\y. \z. ...)
  215. --
  216. -- Inside \x \y { [x->y], [y->y], {y} }
  217. -- \x \z { [x->x], [y->y, z->x], {y,x} }
  218. rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)
  219. -- ^ Similar to 'rnBndr2' but used when there's a binder on the left
  220. -- side only.
  221. rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
  222. = (RV2 { envL = extendVarEnv envL bL new_b
  223. , envR = envR
  224. , in_scope = extendInScopeSet in_scope new_b }, new_b)
  225. where
  226. new_b = uniqAway in_scope bL
  227. rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
  228. -- ^ Similar to 'rnBndr2' but used when there's a binder on the right
  229. -- side only.
  230. rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
  231. = (RV2 { envR = extendVarEnv envR bR new_b
  232. , envL = envL
  233. , in_scope = extendInScopeSet in_scope new_b }, new_b)
  234. where
  235. new_b = uniqAway in_scope bR
  236. rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)
  237. -- ^ Similar to 'rnBndrL' but used for eta expansion
  238. -- See Note [Eta expansion]
  239. rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
  240. = (RV2 { envL = extendVarEnv envL bL new_b
  241. , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion]
  242. , in_scope = extendInScopeSet in_scope new_b }, new_b)
  243. where
  244. new_b = uniqAway in_scope bL
  245. rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)
  246. -- ^ Similar to 'rnBndr2' but used for eta expansion
  247. -- See Note [Eta expansion]
  248. rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
  249. = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion]
  250. , envR = extendVarEnv envR bR new_b
  251. , in_scope = extendInScopeSet in_scope new_b }, new_b)
  252. where
  253. new_b = uniqAway in_scope bR
  254. delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2
  255. delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v
  256. = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
  257. delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v
  258. = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
  259. delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2
  260. delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v
  261. = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
  262. delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v
  263. = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
  264. rnOccL, rnOccR :: RnEnv2 -> Var -> Var
  265. -- ^ Look up the renaming of an occurrence in the left or right term
  266. rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
  267. rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
  268. rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var
  269. -- ^ Look up the renaming of an occurrence in the left or right term
  270. rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v
  271. rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v
  272. inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
  273. -- ^ Tells whether a variable is locally bound
  274. inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
  275. inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env
  276. lookupRnInScope :: RnEnv2 -> Var -> Var
  277. lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v
  278. nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
  279. -- ^ Wipe the left or right side renaming
  280. nukeRnEnvL env = env { envL = emptyVarEnv }
  281. nukeRnEnvR env = env { envR = emptyVarEnv }
  282. \end{code}
  283. Note [Eta expansion]
  284. ~~~~~~~~~~~~~~~~~~~~
  285. When matching
  286. (\x.M) ~ N
  287. we rename x to x' with, where x' is not in scope in
  288. either term. Then we want to behave as if we'd seen
  289. (\x'.M) ~ (\x'.N x')
  290. Since x' isn't in scope in N, the form (\x'. N x') doesn't
  291. capture any variables in N. But we must nevertheless extend
  292. the envR with a binding [x' -> x'], to support the occurs check.
  293. For example, if we don't do this, we can get silly matches like
  294. forall a. (\y.a) ~ v
  295. succeeding with [a -> v y], which is bogus of course.
  296. %************************************************************************
  297. %* *
  298. Tidying
  299. %* *
  300. %************************************************************************
  301. \begin{code}
  302. -- | When tidying up print names, we keep a mapping of in-scope occ-names
  303. -- (the 'TidyOccEnv') and a Var-to-Var of the current renamings
  304. type TidyEnv = (TidyOccEnv, VarEnv Var)
  305. emptyTidyEnv :: TidyEnv
  306. emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
  307. \end{code}
  308. %************************************************************************
  309. %* *
  310. \subsection{@VarEnv@s}
  311. %* *
  312. %************************************************************************
  313. \begin{code}
  314. type VarEnv elt = UniqFM elt
  315. type IdEnv elt = VarEnv elt
  316. type TyVarEnv elt = VarEnv elt
  317. type CoVarEnv elt = VarEnv elt
  318. emptyVarEnv :: VarEnv a
  319. mkVarEnv :: [(Var, a)] -> VarEnv a
  320. zipVarEnv :: [Var] -> [a] -> VarEnv a
  321. unitVarEnv :: Var -> a -> VarEnv a
  322. alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a
  323. extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a
  324. extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
  325. extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
  326. plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
  327. extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
  328. lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
  329. filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
  330. restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
  331. delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
  332. delVarEnv :: VarEnv a -> Var -> VarEnv a
  333. minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a
  334. intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool
  335. plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
  336. mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
  337. modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
  338. varEnvElts :: VarEnv a -> [a]
  339. varEnvKeys :: VarEnv a -> [Unique]
  340. isEmptyVarEnv :: VarEnv a -> Bool
  341. lookupVarEnv :: VarEnv a -> Var -> Maybe a
  342. lookupVarEnv_NF :: VarEnv a -> Var -> a
  343. lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
  344. elemVarEnv :: Var -> VarEnv a -> Bool
  345. elemVarEnvByKey :: Unique -> VarEnv a -> Bool
  346. foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
  347. \end{code}
  348. \begin{code}
  349. elemVarEnv = elemUFM
  350. elemVarEnvByKey = elemUFM_Directly
  351. alterVarEnv = alterUFM
  352. extendVarEnv = addToUFM
  353. extendVarEnv_C = addToUFM_C
  354. extendVarEnv_Acc = addToUFM_Acc
  355. extendVarEnvList = addListToUFM
  356. plusVarEnv_C = plusUFM_C
  357. delVarEnvList = delListFromUFM
  358. delVarEnv = delFromUFM
  359. minusVarEnv = minusUFM
  360. intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
  361. plusVarEnv = plusUFM
  362. lookupVarEnv = lookupUFM
  363. lookupWithDefaultVarEnv = lookupWithDefaultUFM
  364. mapVarEnv = mapUFM
  365. mkVarEnv = listToUFM
  366. emptyVarEnv = emptyUFM
  367. varEnvElts = eltsUFM
  368. varEnvKeys = keysUFM
  369. unitVarEnv = unitUFM
  370. isEmptyVarEnv = isNullUFM
  371. foldVarEnv = foldUFM
  372. lookupVarEnv_Directly = lookupUFM_Directly
  373. filterVarEnv_Directly = filterUFM_Directly
  374. restrictVarEnv env vs = filterVarEnv_Directly keep env
  375. where
  376. keep u _ = u `elemVarSetByKey` vs
  377. zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
  378. lookupVarEnv_NF env id = case lookupVarEnv env id of
  379. Just xx -> xx
  380. Nothing -> panic "lookupVarEnv_NF: Nothing"
  381. \end{code}
  382. @modifyVarEnv@: Look up a thing in the VarEnv,
  383. then mash it with the modify function, and put it back.
  384. \begin{code}
  385. modifyVarEnv mangle_fn env key
  386. = case (lookupVarEnv env key) of
  387. Nothing -> env
  388. Just xx -> extendVarEnv env key (mangle_fn xx)
  389. modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a
  390. modifyVarEnv_Directly mangle_fn env key
  391. = case (lookupUFM_Directly env key) of
  392. Nothing -> env
  393. Just xx -> addToUFM_Directly env key (mangle_fn xx)
  394. \end{code}