X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=519fb74366291b511c0d32fa72f86549f3daad67;hp=5a00869ddd7b641c4876276393102680861ed2f8;hb=a3bab0506498db41853543558c52a4fda0d183af;hpb=62f76a3cbced691b60f511fb83547a5d62653252

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 5a00869..519fb74 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -91,7 +91,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
 mkSimpleUnfolding :: CoreExpr -> Unfolding
 mkSimpleUnfolding = mkUnfolding InlineRhs False False
 
-mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
+mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
@@ -1270,9 +1270,11 @@ exprIsConApp_maybe id_unf expr
           in if sat then True else 
              pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
         , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
-	      subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
-        = Just (con, substTys subst dfun_res_tys, 
-                     [mkApps op args | op <- ops])
+              subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
+              mk_arg (DFunConstArg e) = e
+              mk_arg (DFunLamArg i)   = args !! i
+              mk_arg (DFunPolyArg e)  = mkApps e args
+        = Just (con, substTys subst dfun_res_tys, map mk_arg ops)
 
 	-- Look through unfoldings, but only cheap ones, because
 	-- we are effectively duplicating the unfolding