Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / coreSyn / CoreUnfold.lhs

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index e645fab..24d6330 100644 (file)
--- 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