Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ea232136c947a1d68da35809ea62a2d3074e48e4 >--------------------------------------------------------------- commit ea232136c947a1d68da35809ea62a2d3074e48e4 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Oct 4 16:30:16 2012 +0100 Fix MSG not preserving global-idness >--------------------------------------------------------------- compiler/supercompile/Supercompile.hs | 1 - compiler/supercompile/Supercompile/Drive/MSG.hs | 20 ++++++++++---------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 5f59e69..5e52e96 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -147,7 +147,6 @@ mkLiftedTupleSelector xs want_x tup_e termUnfoldings :: S.Term -> [(Var, S.Term)] termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] [] where - -- FIXME: varBndrFreeVars? go new_fvs all_fvs all_xwhy_nots all_xes | isEmptyVarSet added_fvs = pprTrace "termUnfoldings" (vcat [hang (text why_not <> text ":") 2 (vcat (map ppr xs)) | (why_not, xs) <- groups snd fst all_xwhy_nots]) $ all_xes diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 3736fc0..a702cc0 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -23,8 +23,8 @@ import Util import Coercion import CoreUtils (hashCoercion, hashType {- , hashExpr -}) import Name (mkSystemVarName) -import Var (TyVar, mkTyVar, isTyVar, isId, varType, setVarType, tyVarKind, setTyVarKind, varName, idDetails, setIdDetails, idInfo, lazySetIdInfo) -import Id (Id, idType, idName, realIdUnfolding, setIdUnfolding, idSpecialisation, setIdSpecialisation, mkSysLocal, mkLocalId) +import Var (TyVar, mkTyVar, isTyVar, isId, varType, setVarType, tyVarKind, setTyVarKind, varName, idDetails, setIdDetails, idInfo, lazySetIdInfo, varUnique) +import Id (Id, idType, idName, realIdUnfolding, setIdUnfolding, idSpecialisation, setIdSpecialisation, mkSysLocal, mkLocalId, isGlobalId) import IdInfo (SpecInfo(..)) import VarEnv import Pair @@ -235,14 +235,14 @@ msgPend rn2 x0 pending = MSG $ \e s0 -> case lookupUpdatePending s0 of Right x -> (s0, pure x) Left (mb_eq, binderise, mk_s) -> case res of (_, Left msg) -> (s0, Left msg) (s3, Right x) -> (s3, Right x) -- NB: must revert state or else x_looped will be in the msgKnownVars, and pulling on it will fail the irrefutible pattern match - where -- The use of s here is necessary to ensure we only allocate a given common var once - extra_iss | Just eq <- mb_eq - , eq `elemInScopeSet` msgCommonHeapVars (msgMode e) - = emptyInScopeSet - | otherwise - = msgInScopeSet s0 - -- This use of rn2 is 1/2 of the story necessary to ensure new common vars don't clash with rigid binders - x1 = uniqAway (rnInScopeSet rn2 `unionInScope` extra_iss) x0 + where x1 = case mb_eq of + Just eq | eq `elemInScopeSet` msgCommonHeapVars (msgMode e) || isGlobalId eq + -- The incoming x0 is always a local variable, but we better make a damn sure that we return a global variable if necessary + -- TODO: maybe all global ids should be in the initial InScopeSet? Would need to change prepareTerm. + -> eq + -- This use of rn2 is 1/2 of the story necessary to ensure new common vars don't clash with rigid binders + -- The use of s here is necessary to ensure we only allocate a given common var once + _ -> uniqAway (rnInScopeSet rn2 `unionInScope` msgInScopeSet s0) x0 -- We *don't* need to uniqAway with the set of common variables (in e) because the msgInScopeSet -- was initialized to contain them all. _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
