[commit: ghc] : Fix shadowing bug in DFunUnfoldings that showed up as a lint failure (15031a3)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/15031a34ecf273fbfed2a505a8cb0cff96439610

>---------------------------------------------------------------

commit 15031a34ecf273fbfed2a505a8cb0cff96439610
Author: Max Bolingbroke <[email protected]>
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)