X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=24d633085b926fe97f539c6ed9ad5183073eeeda;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hp=e645fab4bb49719c8101f2286359b06248190667;hpb=356e6869dec4b623a3aba239e72c682667a2b85e;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index e645fab..24d6330 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -40,6 +40,7 @@ import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore		()	-- Instances
+import TcType	 	( tcSplitSigmaTy, tcSplitDFunHead )
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
@@ -126,8 +127,16 @@ mkCoreUnfolding top_lvl src expr arity guidance
 		    uf_expandable = exprIsExpandable expr,
 		    uf_guidance   = guidance }
 
-mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
-mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
+mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
+mkDFunUnfolding dfun_ty ops 
+  = DFunUnfolding dfun_nargs data_con ops
+  where
+    (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
+    	  -- NB: tcSplitSigmaTy: do not look through a newtype
+	  --     when the dictionary type is a newtype
+    (cls, _)   = tcSplitDFunHead head_ty
+    dfun_nargs = length tvs + length theta
+    data_con   = classDataCon cls
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
 mkWwInlineRule id expr arity
@@ -1103,7 +1112,7 @@ interestingArg e = go e 0
     go (Note _ a) 	 n = go a n
     go (Cast e _) 	 n = go e n
     go (Lam v e)  	 n 
-       | isTyVar v	   = go e n
+       | isTyCoVar v	   = go e n
        | n>0	 	   = go e (n-1)
        | otherwise	   = ValueArg
     go (Let _ e)  	 n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
@@ -1223,13 +1232,15 @@ exprIsConApp_maybe id_unf expr
 
     analyse (Var fun) args
 	| Just con <- isDataConWorkId_maybe fun
-        , is_saturated
+        , count isValArg args == idArity fun
 	, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
 	= Just (con, stripTypeArgs univ_ty_args, rest_args)
 
 	-- Look through dictionary functions; see Note [Unfolding DFuns]
-        | DFunUnfolding con ops <- unfolding
-        , is_saturated
+        | DFunUnfolding dfun_nargs con ops <- unfolding
+        , let sat = length args == dfun_nargs    -- See Note [DFun arity check]
+          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, 
@@ -1241,7 +1252,6 @@ exprIsConApp_maybe id_unf expr
 	= -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
           analyse rhs args
         where
-	  is_saturated = count isValArg args == idArity fun
 	  unfolding = id_unf fun
 
     analyse _ _ = Nothing
@@ -1255,11 +1265,7 @@ exprIsConApp_maybe id_unf expr
 	= Nothing
 
     beta fun pairs args
-        = case analyse (substExpr (text "subst-expr-is-con-app") subst fun) args of
-	    Nothing  -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
-	    	        Nothing
-	    Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
-                        Just ans
+        = analyse (substExpr (text "subst-expr-is-con-app") subst fun) args
         where
           subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
 	  -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
@@ -1282,3 +1288,8 @@ So to split it up we just need to apply the ops $c1, $c2 etc
 to the very same args as the dfun.  It takes a little more work
 to compute the type arguments to the dictionary constructor.
 
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding 
+type args) matches what the dfun is expecting.  This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\ No newline at end of file