Merge remote branch 'origin/master'

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

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7e9a010..7d5d764 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}
@@ -99,6 +99,7 @@ data SimplCont
 
   | CoerceIt           -- C `cast` co
        OutCoercion             -- The coercion simplified
+                               -- Invariant: never an identity coercion
        SimplCont
 
   | ApplyTo            -- C arg
@@ -208,6 +209,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 +218,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 +239,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
 
@@ -784,6 +789,11 @@ Don't inline top-level Ids that are bottoming, even if they are used just
 once, because FloatOut has gone to some trouble to extract them out.
 Inlining them won't make the program run faster!
 
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and have a separate
+substitution, so don't inline them via the IdSubst!
+
 \begin{code}
 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 preInlineUnconditionally env top_lvl bndr rhs
@@ -791,6 +801,7 @@ preInlineUnconditionally env top_lvl bndr rhs
   | isStableUnfolding (idUnfolding bndr)     = False    -- Note [InlineRule and preInlineUnconditionally]
   | isTopLevel top_lvl && isBottomingId bndr = False   -- Note [Top-level bottoming Ids]
   | opt_SimplNoPreInlining                   = False
+  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
   | otherwise = case idOccInfo bndr of
                  IAmDead                    -> True    -- Happens in ((\x.1) v)
                  OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
@@ -888,6 +899,7 @@ story for now.
 postInlineUnconditionally 
     :: SimplEnv -> TopLevelFlag
     -> OutId           -- The binder (an InId would be fine too)
+                               --            (*not* a CoVar)
     -> OccInfo                 -- From the InId
     -> OutExpr
     -> Unfolding
@@ -1032,9 +1044,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 +1060,7 @@ mkLam _env bndrs body
       = do { tick (EtaReduction (head bndrs))
           ; return etad_lam }
 
-      | otherwise 
+      | otherwise
       = return (mkLams bndrs body)
 \end{code}
 
@@ -1091,9 +1103,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 +1345,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 +1557,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)]