Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/e8b2ca32d152fe4e8929dc70f6f35a9ed946a496 >--------------------------------------------------------------- commit e8b2ca32d152fe4e8929dc70f6f35a9ed946a496 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Apr 25 17:35:40 2012 +0100 Carefully do inverted-rename on types in invertRenaming >--------------------------------------------------------------- .../supercompile/Supercompile/Core/Renaming.hs | 36 +++++++++++--------- compiler/supercompile/Supercompile/Drive/MSG.hs | 2 +- 2 files changed, 21 insertions(+), 17 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs index 4212526..b5308ce 100644 --- a/compiler/supercompile/Supercompile/Core/Renaming.hs +++ b/compiler/supercompile/Supercompile/Core/Renaming.hs @@ -50,6 +50,8 @@ import FastString (FastString) import UniqFM (ufmToList) import VarEnv +import Control.Monad.Fix (mfix) + import qualified Data.Map as M @@ -148,22 +150,24 @@ mkRenaming rn = foldVarlikes (\f -> M.foldWithKey (\x x' -> f x (x, x'))) rn (\(q, q') -> third3 (\co_subst -> extendVarEnv co_subst q (mkCoVarCo q'))) (emptyVarEnv, emptyVarEnv, emptyVarEnv) -invertRenaming :: Renaming -> Maybe Renaming -invertRenaming (id_subst, tv_subst, co_subst) - = liftM3 (,,) (traverse coreSynToVar_maybe id_subst >>= invertVarEnv varToCoreSyn mkSysLocal) - (traverse getTyVar_maybe tv_subst >>= invertVarEnv mkTyVarTy (\fs uniq -> mkTyVar (mkSysTvName uniq fs))) - (traverse getCoVar_maybe co_subst >>= invertVarEnv mkCoVarCo mkSysLocal) - where - -- FIXME: this inversion relies on something of a hack because the domain of the mapping is not stored (only its Unique) - invertVarEnv :: (Var -> a) - -> (FastString -> Unique -> Type -> Var) - -> VarEnv Var -> Maybe (VarEnv a) - invertVarEnv promote mk env - | distinct (varEnvElts env) = Just (mkVarEnv [ (x, promote $ if isGlobalId x && u == varUnique x - then x -- So we don't replace global Ids with new local Ids! - else mk (occNameFS (getOccName x)) u (varType x)) - | (u, x) <- ufmToList env]) - | otherwise = Nothing +-- NB: the InScopeSet should be that of the *domain* of the renaming (I think!) +invertRenaming :: InScopeSet -> Renaming -> Maybe Renaming +invertRenaming ids (id_subst, tv_subst, co_subst) + = mfix $ \rn -> let -- FIXME: this inversion relies on something of a hack because the domain of the mapping is not stored (only its Unique) + -- Furthermore, we want to carefully rename the *types* (and extra info, if we actually preserved any) as well when doing + -- this inversion so that the renaming {a |-> b, y |-> x :: b} is inverted to {b |-> a, x |-> y :: a} + invertVarEnv :: (Var -> a) + -> (FastString -> Unique -> Type -> Var) + -> VarEnv Var -> Maybe (VarEnv a) + invertVarEnv promote mk env + | distinct (varEnvElts env) = Just (mkVarEnv [ (x, promote $ if isGlobalId x && u == varUnique x + then x -- So we don't replace global Ids with new local Ids! + else mk (occNameFS (getOccName x)) u (renameType ids rn (varType x))) + | (u, x) <- ufmToList env]) + | otherwise = Nothing + in liftM3 (,,) (traverse coreSynToVar_maybe id_subst >>= invertVarEnv varToCoreSyn mkSysLocal) + (traverse getTyVar_maybe tv_subst >>= invertVarEnv mkTyVarTy (\fs uniq -> mkTyVar (mkSysTvName uniq fs))) + (traverse getCoVar_maybe co_subst >>= invertVarEnv mkCoVarCo mkSysLocal) -- NB: we want the set of things in scope in the range of the first renaming / domain of the second renaming composeRenamings :: InScopeSet -> Renaming -> Renaming -> Renaming diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 81ece8c..167fc7b 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -413,7 +413,7 @@ msgMatch :: InstanceMatching -> MSGResult -> Maybe MSGMatchResult msgMatch inst_mtch ((_, Heap h_l _, rn_l, k_l), (heap@(Heap _ ids), k, qa), (deeds_r, heap_r@(Heap h_r _), rn_r, k_r)) -- Try to detect instantiation first -- 1) Is the left-hand renaming invertible? - | Just rn_l_inv <- invertRenaming rn_l + | Just rn_l_inv <- invertRenaming ids rn_l -- 2) Is the left-hand stack empty, and if has been instantiated on the right, was that valid? , Loco gen_k_l <- k_l , case k_r of Loco _ -> True _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
