This BIG PATCH contains most of the work for the New Coercion Representation

[ghc-hetmet.git] / compiler / simplCore / SimplUtils.lhs

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7e9a010..976bb87 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -36,6 +36,7 @@ import StaticFlags
 import CoreSyn
 import qualified CoreSubst
 import PprCore
+import DataCon ( dataConCannotMatch )
 import CoreFVs
 import CoreUtils
 import CoreArity
@@ -45,17 +46,16 @@ import Id
 import Var
 import Demand
 import SimplMonad
-import TcType  ( isDictLikeTy )
 import Type    hiding( substTy )
-import Coercion ( coercionKind )
+import Coercion hiding( substCo )
 import TyCon
-import Unify   ( dataConCannotMatch )
 import VarSet
 import BasicTypes
 import Util
 import MonadUtils
 import Outputable
 import FastString
+import Pair
 
 import Data.List
 \end{code}
@@ -208,6 +208,7 @@ contIsDupable _                          = False
 contIsTrivial :: SimplCont -> Bool
 contIsTrivial (Stop {})                   = True
 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
+contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont
 contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
 contIsTrivial _                           = False
 
@@ -216,17 +217,19 @@ contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
 contResultType env ty cont
   = go cont ty
   where
-    subst_ty se ty = substTy (se `setInScope` env) ty
+    subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
+    subst_co se co = SimplEnv.substCo (se `setInScope` env) co
 
     go (Stop {})                      ty = ty
-    go (CoerceIt co cont)             _  = go cont (snd (coercionKind co))
+    go (CoerceIt co cont)             _  = go cont (pSnd (coercionKind co))
     go (StrictBind _ bs body se cont) _  = go cont (subst_ty se (exprType (mkLams bs body)))
     go (StrictArg ai _ cont)          _  = go cont (funResultTy (argInfoResultTy ai))
     go (Select _ _ alts se cont)      _  = go cont (subst_ty se (coreAltsType alts))
     go (ApplyTo _ arg se cont)        ty = go cont (apply_to_arg ty arg se)
 
-    apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
-    apply_to_arg ty _             _  = funResultTy ty
+    apply_to_arg ty (Type ty_arg)     se = applyTy ty (subst_ty se ty_arg)
+    apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
+    apply_to_arg ty _                 _  = funResultTy ty
 
 argInfoResultTy :: ArgInfo -> OutType
 argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
@@ -235,6 +238,7 @@ argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
 -------------------
 countValArgs :: SimplCont -> Int
 countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
 countValArgs (ApplyTo _ _        _ cont) = 1 + countValArgs cont
 countValArgs _                           = 0
 
@@ -1032,9 +1036,9 @@ mkLam _env bndrs body
       | not (any bad bndrs)
        -- Note [Casts and lambdas]
       = do { lam <- mkLam' dflags bndrs body
-          ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+           ; return (mkCoerce (mkPiCos bndrs co) lam) }
       where
-       co_vars  = tyVarsOfType co
+        co_vars  = tyCoVarsOfCo co
        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      
 
     mkLam' dflags bndrs body@(Lam {})
@@ -1048,7 +1052,7 @@ mkLam _env bndrs body
       = do { tick (EtaReduction (head bndrs))
           ; return etad_lam }
 
-      | otherwise 
+      | otherwise
       = return (mkLams bndrs body)
 \end{code}
 
@@ -1091,9 +1095,6 @@ because the latter is not well-kinded.
 %*                                                                     *
 %************************************************************************
 
-When we meet a let-binding we try eta-expansion.  To find the 
-arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis]
-
 \begin{code}
 tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
 -- See Note [Eta-expanding at let bindings]
@@ -1336,9 +1337,7 @@ abstractFloats main_tvs body_env body
           ; return (subst', (NonRec poly_id poly_rhs)) }
       where
        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
-       tvs_here | any isCoVar main_tvs = main_tvs      -- Note [Abstract over coercions]
-                | otherwise 
-                = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
+       tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
        
                -- Abstract only over the type variables free in the rhs
                -- wrt which the new binding is abstracted.  But the naive
@@ -1550,9 +1549,8 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
        [con] ->        -- It matches exactly one constructor, so fill it in
                 do { tick (FillInCaseDefault case_bndr)
                     ; us <- getUniquesM
-                    ; let (ex_tvs, co_tvs, arg_ids) =
-                              dataConRepInstPat us con inst_tys
-                    ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
+                    ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+                    ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] }
 
        _ -> return [(DEFAULT, [], deflt_rhs)]