Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/806182bff2434807f0e38da0d682672ebd8706aa >--------------------------------------------------------------- commit 806182bff2434807f0e38da0d682672ebd8706aa Author: Dimitrios.Vytiniotis <[email protected]> Date: Thu Apr 5 20:34:51 2012 +0100 Implemeting a lookup modulo non-idempotent substitution. >--------------------------------------------------------------- compiler/coreSyn/TrieMap.lhs | 36 ++++++++++++++++++++---------------- 1 files changed, 20 insertions(+), 16 deletions(-) diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index df7cef7..e551d64 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -32,6 +32,8 @@ import UniqFM import Unique( Unique ) import FastString(FastString) +import Unify ( niFixTvSubst ) + import qualified Data.Map as Map import qualified Data.IntMap as IntMap import VarEnv @@ -529,36 +531,38 @@ lkT env ty m lkT_mod :: CmEnv - -> TyVarEnv a -- A substitution - -> (a -> Type) + -> TyVarEnv Type -- TvSubstEnv -> Type -> TypeMap b -> Maybe b -lkT_mod env s f ty m +lkT_mod env s ty m | EmptyTM <- m = Nothing | Just ty' <- coreView ty - = lkT_mod env s f ty' m - | isEmptyVarEnv candidates + = lkT_mod env s ty' m + | [] <- candidates = go env s ty m | otherwise - = Just $ head (varEnvElts candidates) -- Yikes! + = Just $ snd (head candidates) -- Yikes! where - candidates = filterVarEnv_Directly find_matching (vm_fvar $ tm_var m) - find_matching tv _b = case lookupVarEnv_Directly s tv of - Nothing -> False - Just a -> f a `eqType` ty + -- Hopefully intersects is much smaller than traversing the whole vm_fvar + intersects = eltsUFM $ + intersectUFM_C (,) s (vm_fvar $ tm_var m) + candidates = [ (u,ct) | (u,ct) <- intersects + , Type.substTy (niFixTvSubst s) u `eqType` ty ] + go env _s (TyVarTy v) = tm_var >.> lkVar env v - go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s f t1 >=> lkT_mod env s f t2 - go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s f t1 >=> lkT_mod env s f t2 - go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s f) tys - go _env _s (LitTy l) = tm_tylit >.> lkTyLit l - go _env _s (ForAllTy _tv _ty) = const Nothing + go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s t1 >=> lkT_mod env s t2 + go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s t1 >=> lkT_mod env s t2 + go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s) tys + go _env _s (LitTy l) = tm_tylit >.> lkTyLit l + go _env _s (ForAllTy _tv _ty) = const Nothing + {- DV TODO: Add proper lookup for ForAll -} lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map -> (a -> Type) -> Type -> TypeMap b -> Maybe b -lookupTypeMap_mod = lkT_mod emptyCME +lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s) ----------------- xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
