[commit: ghc] : Fix the DFunUnfolding elaboration so it isn't totally bogus (3d7a447)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/3d7a4476e7bc20ea19235fcca2baf690b56e632a

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

commit 3d7a4476e7bc20ea19235fcca2baf690b56e632a
Author: Max Bolingbroke <[email protected]>
Date:   Mon Feb 20 16:02:00 2012 +0000

    Fix the DFunUnfolding elaboration so it isn't totally bogus

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

 compiler/supercompile/Supercompile.hs |    7 +++++--
 1 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs
index 46dfeed..b975012 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -27,7 +27,7 @@ import CoreSyn
 import CoreFVs    (exprFreeVars)
 import CoreUtils  (exprType)
 import Coercion   (isCoVar, mkCoVarCo, mkAxInstCo)
-import DataCon    (dataConAllTyVars, dataConRepArgTys, dataConTyCon)
+import DataCon    (dataConAllTyVars, dataConRepArgTys, dataConInstOrigArgTys, dataConTyCon, dataConWorkId)
 import VarSet
 import VarEnv
 import Name       (localiseName, mkSystemName)
@@ -37,6 +37,7 @@ import Id
 import FastString (fsLit)
 import PrelNames  (undefinedName)
 import PrimOp     (primOpSig)
+import TcType     (tcSplitDFunTy)
 import Type       (mkTyVarTy, mkForAllTy, mkFunTys)
 import TysPrim    (alphaTyVar, argAlphaTyVar)
 import TyCon      (newTyConCo_maybe)
@@ -143,7 +144,9 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet []
       | otherwise                          = case realIdUnfolding x of
         NoUnfolding                   -> Nothing
         OtherCon _                    -> Nothing
-        DFunUnfolding _ dc es         -> Just $ runParseM $ conAppToTerm dc es
+        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]
+         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
          -- NB: it's OK if the unfolding is a non-value, as the evaluator won't inline LetBound non-values