X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=b58825b38afb76fe80d1aad6a75478adc8b9633a;hp=2433eb8ba7cb1229208d0b68533ce0145dd719ac;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=b4ef814c34e7007180d0d38a13c19229391aac7f

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 2433eb8..b58825b 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -6,9 +6,16 @@
 Utility functions on @Core@ syntax
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module CoreUtils (
 	-- Construction
-	mkInlineMe, mkSCC, mkCoerce, 
+	mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
 	bindNonRec, needsCaseBinding,
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
@@ -194,6 +201,10 @@ mkInlineMe e	   = Note InlineMe e
 
 
 \begin{code}
+mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
+mkCoerceI IdCo e = e
+mkCoerceI (ACo co) e = mkCoerce co e
+
 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 mkCoerce co (Cast expr co2)
   = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
@@ -259,7 +270,8 @@ mkAltExpr (DataAlt con) args inst_tys
   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 mkAltExpr (LitAlt lit) [] []
   = Lit lit
-mkAltExpr DEFAULT = panic "mkAltExpr"
+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
@@ -659,7 +671,7 @@ dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
 dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat (FSLIT("ipv")))
   where 
-    dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
+    dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
 	-- Remember to include the existential dictionaries
 
 dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
@@ -675,9 +687,13 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --
 --   co_tvs are intended to be used as binders for coercion args and the kinds
 --     of these vars have been instantiated by the inst_tys and the ex_tys
+--     The co_tvs include both GADT equalities (dcEqSpec) and 
+--     programmer-specified equalities (dcEqTheta)
 --
---   arg_ids are indended to be used as binders for value arguments, including
---     dicts, and their types have been instantiated with inst_tys and ex_tys
+--   arg_ids are indended to be used as binders for value arguments, 
+--     and their types have been instantiated with inst_tys and ex_tys
+--     The arg_ids include both dicts (dcDictTheta) and
+--     programmer-specified arguments (after rep-ing) (deRepArgTys)
 --
 -- Example.
 --  The following constructor T1
@@ -697,16 +713,17 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
 dataConInstPat arg_fun fss uniqs con inst_tys 
-  = (ex_bndrs, co_bndrs, id_bndrs)
+  = (ex_bndrs, co_bndrs, arg_ids)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
     arg_tys  = arg_fun con
     eq_spec  = dataConEqSpec con
-    eq_preds = eqSpecPreds eq_spec
+    eq_theta = dataConEqTheta con
+    eq_preds = eqSpecPreds eq_spec ++ eq_theta
 
     n_ex = length ex_tvs
-    n_co = length eq_spec
+    n_co = length eq_preds
 
       -- split the Uniques and FastStrings
     (ex_uniqs, uniqs')   = splitAt n_ex uniqs
@@ -733,8 +750,8 @@ dataConInstPat arg_fun fss uniqs con inst_tys
          co_kind  = substTy subst (mkPredTy eq_pred)
 
       -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
-    id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+    arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 -- Returns (Just (dc, [x1..xn])) if the argument expression is 
@@ -1158,8 +1175,8 @@ eta_expand n us expr ty
 		--	coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 
     	case splitNewTypeRepCo_maybe ty of {
- 	  Just(ty1,co) -> 
-              mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
+ 	  Just(ty1,co) -> mkCoerce (mkSymCoercion co) 
+				   (eta_expand n us (mkCoerce co expr) ty1) ;
  	  Nothing  -> 
 
 	-- We have an expression of arity > 0, but its type isn't a function