X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FVarEnv.lhs;h=bfeecdc923d41925ff3e2d69d12a03f558339913;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=3c7f7f0c6b9b49961f2138a21c59251c82504696;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index 3c7f7f0..bfeecdc 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -7,7 +7,7 @@ module VarEnv ( VarEnv, IdEnv, TyVarEnv, emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, varEnvElts, + elemVarEnv, varEnvElts, varEnvKeys, extendVarEnv, extendVarEnv_C, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, @@ -15,13 +15,18 @@ module VarEnv ( mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, - lookupVarEnv_Directly, + elemVarEnvByKey, lookupVarEnv_Directly, filterVarEnv_Directly, -- InScopeSet InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, modifyInScopeSet, getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, + mapInScopeSet, + + -- RnEnv2 and its operations + RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, -- TidyEnvs TidyEnv, emptyTidyEnv @@ -34,8 +39,9 @@ import Var ( Var, setVarUnique ) import VarSet import UniqFM import Unique ( Unique, deriveUnique, getUnique ) -import Util ( zipEqual ) -import CmdLineOpts ( opt_PprStyle_Debug ) +import Util ( zipEqual, foldl2 ) +import Maybes ( orElse, isJust ) +import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastTypes \end{code} @@ -81,6 +87,9 @@ modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_sco delInScopeSet :: InScopeSet -> Var -> InScopeSet delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n +mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet +mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n + elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope @@ -105,9 +114,14 @@ uniqAway :: InScopeSet -> Var -> Var -- in-scope set, and gives that to v. It starts with v's current unique, of course, -- in the hope that it won't have to change it, and thereafter uses a combination -- of that and the hash-code found in the in-scope set -uniqAway (InScope set n) var - | not (var `elemVarSet` set) = var -- Nothing to do - | otherwise = try 1# +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' (InScope set n) var + = try 1# where orig_unique = getUnique var try k @@ -129,6 +143,110 @@ uniqAway (InScope set n) var %************************************************************************ %* * + Dual renaming +%* * +%************************************************************************ + +When we are comparing (or matching) types or terms, we are faced with +"going under" corresponding binders. E.g. when comparing + \x. e1 ~ \y. e2 + +Basically we want to rename [x->y] or [y->x], but there are lots of +things we must be careful of. In particular, x might be free in e2, or +y in e1. So the idea is that we come up with a fresh binder that is free +in neither, and rename x and y respectively. That means we must maintain + a) a renaming for the left-hand expression + b) a renaming for the right-hand expressions + c) an in-scope set + +Furthermore, when matching, we want to be able to have an 'occurs check', +to prevent + \x. f ~ \y. y +matching with f->y. So for each expression we want to know that set of +locally-bound variables. That is precisely the domain of the mappings (a) +and (b), but we must ensure that we always extend the mappings as we go in. + + +\begin{code} +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- Arg lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- (rnBndr2 env bL bR) go under a binder bL in the Left term 1, +-- and binder bR in the Right term +-- It finds a new binder, new_b, +-- and returns an environment mapping bL->new_b and bR->new_b resp. +rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b } + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- Used when there's a binder on one side or the other only +-- Useful when eta-expanding +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bL `elemInScopeSet` in_scope) = bL + | otherwise = uniqAway' in_scope bL + +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = envL + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bR + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v) +inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v) + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } +\end{code} + + +%************************************************************************ +%* * Tidying %* * %************************************************************************ @@ -172,17 +290,20 @@ plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a varEnvElts :: VarEnv a -> [a] +varEnvKeys :: VarEnv a -> [Unique] isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b \end{code} \begin{code} elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C extendVarEnvList = addListToUFM @@ -196,14 +317,15 @@ mapVarEnv = mapUFM mkVarEnv = listToUFM emptyVarEnv = emptyUFM varEnvElts = eltsUFM +varEnvKeys = keysUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } \end{code} @modifyVarEnv@: Look up a thing in the VarEnv,