Small refactoring

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

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 7344efd..0cc6003 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -44,9 +44,9 @@ import GLAEXTS                -- For `xori`
 import CoreSyn
 import CoreFVs         ( exprFreeVars )
 import PprCore         ( pprCoreExpr )
-import Var             ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
-                          mkCoVar, mkTyVar, mkCoVar )
-import OccName          ( OccName, occNameFS, mkVarOccFS )
+import Var             ( Var, TyVar, CoVar, isCoVar, tyVarKind, mkCoVar, mkTyVar )
+import OccName          ( mkVarOccFS )
+import SrcLoc          ( noSrcLoc )
 import VarSet          ( unionVarSet )
 import VarEnv
 import Name            ( hashName, mkSysTvName )
@@ -56,13 +56,14 @@ import Packages             ( isDllName )
 import Literal         ( hashLiteral, literalType, litIsDupable, 
                          litIsTrivial, isZeroLit, Literal( MachLabel ) )
 import DataCon         ( DataCon, dataConRepArity, eqSpecPreds, 
-                         isVanillaDataCon, dataConTyCon, dataConRepArgTys,
+                         dataConTyCon, dataConRepArgTys,
                           dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
-                          dataConOrigArgTys )
+                          dataConOrigArgTys, dataConTheta )
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo,
-                         isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
+                         isOneShotBndr, isStateHackType, 
+                         isDataConWorkId_maybe, mkSysLocal, mkUserLocal,
                          isDataConWorkId, isBottomingId, isDictId
                        )
 import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )
@@ -70,14 +71,14 @@ import NewDemand    ( appIsBottom )
 import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
                          splitFunTy, tcEqTypeX,
                          applyTys, isUnLiftedType, seqType, mkTyVarTy,
-                         splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, 
+                         splitForAllTy_maybe, isForAllTy, 
                          splitTyConApp_maybe, coreEqType, funResultTy, applyTy,
-                          substTyWith, mkPredTy
+                          substTyWith, mkPredTy, zipOpenTvSubst, substTy
                        )
 import Coercion         ( Coercion, mkTransCoercion, coercionKind,
-                          splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion,
-                          mkRightCoercion, decomposeCo, coercionKindPredTy,
-                          splitCoercionKind, mkEqPred )
+                          splitNewTypeRepCo_maybe, mkSymCoercion,
+                          decomposeCo, coercionKindPredTy,
+                          splitCoercionKind )
 import TyCon           ( tyConArity )
 import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
 import CostCentre      ( CostCentre )
@@ -211,8 +212,8 @@ mkInlineMe e           = Note InlineMe e
 \begin{code}
 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 mkCoerce co (Cast expr co2)
-  = ASSERT(let { (from_ty, to_ty) = coercionKind co; 
-                 (from_ty2, to_ty2) = coercionKind co2} in
+  = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
+                 (_from_ty2, to_ty2) = coercionKind co2} in
            from_ty `coreEqType` to_ty2 )
     mkCoerce (mkTransCoercion co2 co) expr
 
@@ -681,9 +682,12 @@ deepCast ty tyVars co
     coArgs = decomposeCo (length tyVars) co
 
 -- These InstPat functions go here to avoid circularity between DataCon and Id
-dataConOrigInstPat  = dataConInstPat dataConOrigArgTys (repeat (FSLIT("ipv")))
 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
+       -- Remember to include the existential dictionaries
 
 dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
                   -> [FastString]          -- A long enough list of FSs to use for names
@@ -730,7 +734,6 @@ dataConInstPat arg_fun fss uniqs con inst_tys
 
     n_ex = length ex_tvs
     n_co = length eq_spec
-    n_id = length arg_tys
 
       -- split the Uniques and FastStrings
     (ex_uniqs, uniqs')   = splitAt n_ex uniqs
@@ -739,27 +742,25 @@ dataConInstPat arg_fun fss uniqs con inst_tys
     (ex_fss, fss')     = splitAt n_ex fss
     (co_fss, id_fss)   = splitAt n_co fss'
 
-      -- make existential type variables
+      -- Make existential type variables
+    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
     mk_ex_var uniq fs var = mkTyVar new_name kind
       where
         new_name = mkSysTvName uniq fs
         kind     = tyVarKind var
 
-    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
-
-      -- make the instantiation substitution
-    inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+      -- Make the instantiating substitution
+    subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 
-      -- make new coercion vars, instantiating kind
+      -- Make new coercion vars, instantiating kind
+    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
     mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
        where
          new_name = mkSysTvName uniq fs
-         co_kind  = inst_subst (mkPredTy eq_pred)
-
-    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
+         co_kind  = substTy subst (mkPredTy eq_pred)
 
       -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (inst_subst ty) noSrcLoc
+    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
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
@@ -799,7 +800,7 @@ exprIsConApp_maybe (Cast expr co)
        arity               = tyConArity tc
         n_ex_tvs            = length dc_ex_tyvars
 
-        (univ_args, rest)   = splitAt arity args
+        (_univ_args, rest)  = splitAt arity args
         (ex_args, val_args) = splitAt n_ex_tvs rest
 
         arg_tys            = dataConRepArgTys dc
@@ -809,7 +810,6 @@ exprIsConApp_maybe (Cast expr co)
         deep arg_ty         = deepCast arg_ty dc_tyvars co
 
           -- first we appropriately cast the value arguments
-        arg_cos             = map deep arg_tys 
        new_val_args        = zipWith mkCoerce (map deep arg_tys) val_args
 
           -- then we cast the existential coercion arguments