Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/15031a34ecf273fbfed2a505a8cb0cff96439610 >--------------------------------------------------------------- commit 15031a34ecf273fbfed2a505a8cb0cff96439610 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Tue Mar 20 17:40:29 2012 +0000 Fix shadowing bug in DFunUnfoldings that showed up as a lint failure >--------------------------------------------------------------- compiler/supercompile/Supercompile.hs | 19 ++++++++++++++----- compiler/supercompile/Supercompile/GHC.hs | 10 +++++----- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 7e65989..338c7e2 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -163,10 +163,10 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] | otherwise = case realIdUnfolding x of NoUnfolding -> Nothing OtherCon _ -> Nothing - DFunUnfolding _ dc es -> Just $ runParseM $ coreExprToTerm $ mkLams as $ mkLams xs $ Var (dataConWorkId dc) `mkTyApps` cls_tys `mkApps` [(e `mkTyApps` map mkTyVarTy as) `mkVarApps` xs | e <- es] + DFunUnfolding _ dc es -> Just $ runParseM us2 $ coreExprToTerm $ mkLams as $ mkLams xs $ Var (dataConWorkId dc) `mkTyApps` cls_tys `mkApps` [(e `mkTyApps` map mkTyVarTy as) `mkVarApps` xs | e <- es] where (as, theta, _cls, cls_tys) = tcSplitDFunTy (idType x) xs = zipWith (mkSysLocal (fsLit "x")) bv_uniques theta - CoreUnfolding { uf_tmpl = e } -> Just $ runParseM $ coreExprToTerm e + CoreUnfolding { uf_tmpl = e } -> Just $ runParseM us2 $ coreExprToTerm e -- NB: it's OK if the unfolding is a non-value, as the evaluator won't inline LetBound non-values -- We don't want to expose an unfolding if it would not be inlineable in the initial phase. @@ -193,15 +193,24 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] xs = zipWith (mkSysLocal (fsLit "x")) bv_uniques arg_tys (qs, ys) = span isCoVar xs - -- It doesn't matter if we reuse Uniques here because by construction they can't shadow other uses of the anfUniqSupply' - bv_uniques = uniqsFromSupply anfUniqSupply' + -- We need a UniqSupply so we can generate Uniques for datacon/primop/user unfoldings. It doesn't really matter + -- that the binders we generate here may shadow things above, but we have to be careful with our use of anfUniqSupply' + -- when we call runParseM to deal with user unfoldings. The reason is that coreExprToTerm assumes that no free variables + -- of the CoreExpr have Uniques generated by the unique supply it is passed. + -- + -- This meant that when runParseM used to unconditionally use anfUniqSupply' for Uniques we had a stupid bug, because + -- we were also using the uniques from anfUniqueSupply to generate lambda-binders in the DFunUnfolding case. + -- All we needed to do to fix this was to make sure we split off a seperate UniqSupply for generating the lambda-bindings + -- than we pass down to runParseM. + (us1, us2) = splitUniqSupply anfUniqSupply' + bv_uniques = uniqsFromSupply us1 supercompile :: CoreExpr -> IO CoreExpr supercompile e = -- liftM (termToCoreExpr . snd) $ return $ termToCoreExpr $ S.supercompile (M.fromList unfs) e' where unfs = termUnfoldings e' - e' = runParseM (coreExprToTerm e) + e' = runParseM anfUniqSupply' (coreExprToTerm e) supercompileProgram :: [CoreBind] -> IO [CoreBind] supercompileProgram binds = supercompileProgramSelective selector binds diff --git a/compiler/supercompile/Supercompile/GHC.hs b/compiler/supercompile/Supercompile/GHC.hs index d44496b..5e5ff06 100644 --- a/compiler/supercompile/Supercompile/GHC.hs +++ b/compiler/supercompile/Supercompile/GHC.hs @@ -79,12 +79,12 @@ instance Monad ParseM where instance MonadUnique ParseM where getUniqueSupplyM = ParseM $ \us -> case splitUniqSupply us of (us1, us2) -> (us1, [], us2) -runParseM' :: ParseM a -> ([(Var, S.Term)], a) -runParseM' act = (floats, x) - where (_s, floats, x) = unParseM act anfUniqSupply' +runParseM' :: UniqSupply -> ParseM a -> ([(Var, S.Term)], a) +runParseM' us act = (floats, x) + where (_s, floats, x) = unParseM act us -runParseM :: ParseM S.Term -> S.Term -runParseM = uncurry (S.bindManyMixedLiftedness S.termFreeVars) . runParseM' +runParseM :: UniqSupply -> ParseM S.Term -> S.Term +runParseM us = uncurry (S.bindManyMixedLiftedness S.termFreeVars) . runParseM' us freshFloatId :: String -> S.Term -> ParseM (Maybe (Var, S.Term), Var) freshFloatId _ (I (S.Var x)) = return (Nothing, x) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
