projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
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 CoreSyn
import qualified CoreSubst
import PprCore
+import DataCon ( dataConCannotMatch )
import CoreFVs
import CoreUtils
import CoreArity
import CoreFVs
import CoreUtils
import CoreArity
@@
-45,17
+46,16
@@
import Id
import Var
import Demand
import SimplMonad
import Var
import Demand
import SimplMonad
-import TcType ( isDictLikeTy )
import Type hiding( substTy )
import Type hiding( substTy )
-import Coercion ( coercionKind )
+import Coercion hiding( substCo )
import TyCon
import TyCon
-import Unify ( dataConCannotMatch )
import VarSet
import BasicTypes
import Util
import MonadUtils
import Outputable
import FastString
import VarSet
import BasicTypes
import Util
import MonadUtils
import Outputable
import FastString
+import Pair
import Data.List
\end{code}
import Data.List
\end{code}
@@
-99,6
+99,7
@@
data SimplCont
| CoerceIt -- C `cast` co
OutCoercion -- The coercion simplified
| CoerceIt -- C `cast` co
OutCoercion -- The coercion simplified
+ -- Invariant: never an identity coercion
SimplCont
| ApplyTo -- C arg
SimplCont
| ApplyTo -- C arg
@@
-208,6
+209,7
@@
contIsDupable _ = False
contIsTrivial :: SimplCont -> Bool
contIsTrivial (Stop {}) = True
contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
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
contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
contIsTrivial _ = False
@@
-216,17
+218,19
@@
contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
contResultType env ty cont
= go cont ty
where
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 (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)
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 })
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 :: SimplCont -> Int
countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont
countValArgs _ = 0
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!
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
\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
| 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
| 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)
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId -- The binder (an InId would be fine too)
+ -- (*not* a CoVar)
-> OccInfo -- From the InId
-> OutExpr
-> Unfolding
-> 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
| 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
where
- co_vars = tyVarsOfType co
+ co_vars = tyCoVarsOfCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
mkLam' dflags bndrs body@(Lam {})
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 }
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | otherwise
+ | otherwise
= return (mkLams bndrs body)
\end{code}
= 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]
\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
; 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
-- 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
[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)]
_ -> return [(DEFAULT, [], deflt_rhs)]