Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/94c7d820f0fc6393fd83942f19d12a509d1abf0b >--------------------------------------------------------------- commit 94c7d820f0fc6393fd83942f19d12a509d1abf0b Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Fri May 11 08:39:34 2012 +0100 Use new insertVarRenaming when constructing renaming in MSG >--------------------------------------------------------------- .../supercompile/Supercompile/Core/Renaming.hs | 7 +++++++ compiler/supercompile/Supercompile/Drive/MSG.hs | 2 +- 2 files changed, 8 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs index 2a81d4b..21fe136 100644 --- a/compiler/supercompile/Supercompile/Core/Renaming.hs +++ b/compiler/supercompile/Supercompile/Core/Renaming.hs @@ -10,6 +10,7 @@ module Supercompile.Core.Renaming ( PreRenaming, invertRenaming, composeRenamings, -- | Extending the renaming + insertVarRenaming, insertIdRenaming, insertIdRenamings, insertTypeSubst, insertTypeSubsts, insertCoercionSubst, insertCoercionSubsts, @@ -200,6 +201,12 @@ getId_maybe _ = Nothing coreSynToVar :: CoreSyn.CoreExpr -> Var coreSynToVar = fromMaybe (panic "renameId" empty) . getId_maybe +insertVarRenaming :: Renaming -> Var -> Out Var -> Renaming +insertVarRenaming rn x y + | isTyVar x = insertTypeSubst rn x (mkTyVarTy x) + | isCoVar x = insertCoercionSubst rn x (mkCoVarCo x) + | otherwise = insertIdRenaming rn x y + insertIdRenaming :: Renaming -> Id -> Out Id -> Renaming insertIdRenaming (id_subst, tv_subst, co_subst) x x' = (extendVarEnv id_subst x (mkIdExpr x'), tv_subst, co_subst) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 7a0d7c3..87a55f6 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -1015,7 +1015,7 @@ msgPureHeap mm rn2 msg_e msg_s (Heap init_h_l init_ids_l) (Heap init_h_r init_id -- that binding refers to. If that is not possible, we have to fail. (used_l', h_l') <- mb_individual_l >>= suck init_h_l k_bvs_l h_l x_l (used_r', h_r') <- mb_individual_r >>= suck init_h_r k_bvs_r h_r x_r - return $ go (insertIdRenaming rn_l x_common x_l) (insertIdRenaming rn_r x_common x_r) used_l' used_r' init_h_l init_h_r + return $ go (insertVarRenaming rn_l x_common x_l) (insertVarRenaming rn_r x_common x_r) used_l' used_r' init_h_l init_h_r (Heap h_l' ids_l) (Heap h_r' ids_r) (M.insert x_common generalised h) msg_s) -- FIXME: only mark as generalised if *right hand side* was not e.g. a lambda bound where (mb_common_l, mb_individual_l) = find init_h_l k_bvs_l h_l used_l x_l _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
