Commit 0007c0ec authored by dimitris's avatar dimitris

GHC gets a new constraint solver. More efficient and smaller in size.

parent 1bbb89f3
......@@ -858,16 +858,17 @@ dataConCannotMatch tys con
| all isTyVarTy tys = False -- Also common
| otherwise
= typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
| (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
| (ty1, ty2) <- concatMap predEqs theta ]
where
dc_tvs = dataConUnivTyVars con
theta = dataConTheta con
subst = zipTopTvSubst dc_tvs tys
-- TODO: could gather equalities from superclasses too
predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
predEqs (TuplePred ts) = concatMap predEqs ts
predEqs _ = []
predEqs pred = case classifyPredType pred of
EqPred ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
\end{code}
%************************************************************************
......
......@@ -48,7 +48,7 @@ import Type
import Coercion
import TcType
import MkCore
import CoreUtils ( exprType, mkCoerce )
import CoreUtils ( exprType, mkCast )
import CoreUnfold
import Literal
import TyCon
......@@ -683,7 +683,7 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon )
wrapFamInstBody tycon args $
mkCoerce (mkSymCo co) result_expr
mkCast result_expr (mkSymCo co)
where
co = mkAxInstCo (newTyConCo tycon) args
......@@ -695,7 +695,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon )
mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
......@@ -705,14 +705,14 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
= mkCast body (mkSymCo (mkAxInstCo co_con args))
| otherwise
= body
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCoerce (mkAxInstCo co_con args) scrut
= mkCast scrut (mkAxInstCo co_con args)
| otherwise
= scrut
\end{code}
......
......@@ -47,6 +47,7 @@ import Type
import TyCon
import Util
import Outputable
import FastString
import Control.Monad (when)
\end{code}
......@@ -127,6 +128,13 @@ allocating more heap than strictly necessary, but it will sometimes
eliminate a heap check altogether.
\begin{code}
cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr
(PrimAlt _) [(DEFAULT,bndrs,_,rhs)]
| isVoidArg (idCgRep bndr)
= ASSERT( null bndrs )
WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr)
cgExpr rhs
cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
alt_type@(PrimAlt _) alts
-- Note [ticket #3132]: we might be looking at a case of a lifted Id
......@@ -147,17 +155,18 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
-- the HValue really is a MutVar#. The types are compatible though,
-- so we can just generate an assignment.
|| reps_compatible
=
do { -- Careful! we can't just bind the default binder to the same thing
= do { when (not reps_compatible) $
panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
-- Careful! we can't just bind the default binder to the same thing
-- as the scrutinee, since it might be a stack location, and having
-- two bindings pointing at the same stack locn doesn't work (it
-- confuses nukeDeadBindings). Hence, use a new temp.
when (not reps_compatible) $
panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
; v_info <- getCgIdInfo v
; amode <- idInfoToAmode v_info
; tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
where
reps_compatible = idCgRep v == idCgRep bndr
......@@ -327,6 +336,7 @@ cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
= ASSERT( con == DEFAULT && isSingleton alts && null bs )
do { -- VOID RESULT; just sequencing,
-- so get in there and do it
-- The bndr should not occur, so no need to bind it
cgPrimOp [] primop args live_in_alts
; cgExpr rhs }
where
......
......@@ -297,6 +297,21 @@ lintCoreExpr (Let (Rec pairs) body)
(_, dups) = removeDups compare bndrs
lintCoreExpr e@(App _ _)
{- DV: This grievous hack (from ghc-constraint-solver should not be needed:
| Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
-- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
-- we should do this properly
, Just dc <- isDataConWorkId_maybe x
, dc == eqBoxDataCon
, [Type arg_ty1, Type arg_ty2, co_e] <- args
= do arg_ty1' <- lintInTy arg_ty1
arg_ty2' <- lintInTy arg_ty2
unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2')
(addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e
| otherwise
-}
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
where
......@@ -460,13 +475,10 @@ checkTyKind tyvar arg_ty
checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
checkTyCoKind tv co
= do { (t1,t2) <- lintCoercion co
; k1 <- lintType t1
; k2 <- lintType t2
; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
-- t1,t2 have the same kind
; unless (typeKind t1 `isSubKind` tyVarKind tv)
(addErrL (mkTyCoAppErrMsg tv co))
; return (t1,t2) }
where
tyvar_kind = tyVarKind tv
checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
checkTyCoKinds = zipWithM checkTyCoKind
......@@ -688,6 +700,29 @@ lintTyBndrKind tv =
else lintKind ki -- type forall
-------------------
{-
lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
lint_prim_eq_co tc co arg_cos = case arg_cos of
[co1,co2] -> do { (t1,s1) <- lintCoercion co1
; (t2,s2) <- lintCoercion co2
; checkL (typeKind t1 `eqKind` typeKind t2) $
ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
_ -> failWithL (ptext (sLit "Unsaturated or oversaturated ~# coercion") <+> ppr co)
lint_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
lint_eq_co tc co arg_cos = case arg_cos of
[co1,co2] -> do { (t1,s1) <- lintCoercion co1
; (t2,s2) <- lintCoercion co2
; checkL (typeKind t1 `eqKind` typeKind t2) $
ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
[co1] -> do { (t1,s1) <- lintCoercion co1
; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
[] -> return (mkTyConApp tc [], mkTyConApp tc [])
_ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co)
-}
lintKindCoercion :: OutCoercion -> LintM OutKind
-- Kind coercions are only reflexivity because they mean kind
-- instantiation. See Note [Kind coercions] in Coercion
......@@ -700,11 +735,28 @@ lintKindCoercion co
lintCoercion :: OutCoercion -> LintM (OutType, OutType)
-- Check the kind of a coercion term, returning the kind
-- Post-condition: the returned OutTypes are lint-free
-- and have the same kind as each other
lintCoercion (Refl ty)
= do { _k <- lintType ty
= do { _ <- lintType ty
; return (ty, ty) }
lintCoercion co@(TyConAppCo tc cos)
{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
| tc `hasKey` eqPrimTyConKey -- Just as in lintType, treat applications of (~) and (~#)
= lint_prim_eq_co tc co cos -- specially to allow for polymorphism. This hack will
-- hopefully go away when we merge in kind polymorphism.
| tc `hasKey` eqTyConKey
= lint_eq_co tc co cos
| otherwise
= do { (ss,ts) <- mapAndUnzipM lintCoercion cos
; let kind_to_check = if (tc `hasKey` funTyConKey) && (length cos == 2)
then mkArrowKinds [argTypeKind,openTypeKind] liftedTypeKind
else tyConKind tc -- TODO: Fix this when kind polymorphism is in!
; check_co_app co kind_to_check ss
; return (mkTyConApp tc ss, mkTyConApp tc ts) }
-}
= do -- We use the kind of the type constructor to know how many
-- kind coercions we have (one kind coercion for one kind
-- instantiation).
......@@ -721,6 +773,7 @@ lintCoercion co@(TyConAppCo tc cos)
; check_co_app co ki (kis ++ ss)
; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) }
lintCoercion co@(AppCo co1 co2)
= do { (s1,t1) <- lintCoercion co1
; (s2,t2) <- lintCoercion co2
......@@ -740,7 +793,8 @@ lintCoercion (CoVarCo cv)
2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
| otherwise
= do { checkTyCoVarInScope cv
; return (coVarKind cv) }
; cv' <- lookupIdInScope cv
; return (coVarKind cv') }
lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
, co_ax_lhs = lhs
......@@ -759,8 +813,8 @@ lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
(kcos, tcos) = splitAt (length kvs) cos
lintCoercion (UnsafeCo ty1 ty2)
= do { _k1 <- lintType ty1
; _k2 <- lintType ty2
= do { _ <- lintType ty1
; _ <- lintType ty2
; return (ty1, ty2) }
lintCoercion (SymCo co)
......@@ -794,7 +848,7 @@ lintCoercion (InstCo co arg_ty)
Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
----------
checkTcApp :: Coercion -> Int -> Type -> LintM Type
checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType
checkTcApp co n ty
| Just tys <- tyConAppArgs_maybe ty
, n < length tys
......@@ -988,10 +1042,10 @@ updateTvSubst subst' m =
getTvSubst :: LintM TvSubst
getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
applySubstTy :: Type -> LintM Type
applySubstTy :: InType -> LintM OutType
applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
applySubstCo :: Coercion -> LintM Coercion
applySubstCo :: InCoercion -> LintM OutCoercion
applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
extendSubstL :: TyVar -> Type -> LintM a -> LintM a
......
......@@ -949,7 +949,8 @@ simple_opt_expr' subst expr
= case altcon of
DEFAULT -> go rhs
_ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst (zipEqual "simpleOptExpr" bs es)
where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst
(zipEqual "simpleOptExpr" bs es)
| otherwise
= Case e' b' (substTy subst ty)
......@@ -1016,9 +1017,11 @@ simple_opt_bind' subst (NonRec b r)
----------------------
simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
simple_opt_out_bind subst (b, r') = case maybe_substitute subst b r' of
Just ext_subst -> (ext_subst, Nothing)
Nothing -> (subst', Just (NonRec b2 r'))
simple_opt_out_bind subst (b, r')
| Just ext_subst <- maybe_substitute subst b r'
= (ext_subst, Nothing)
| otherwise
= (subst', Just (NonRec b2 r'))
where
(subst', b') = subst_opt_bndr subst b
b2 = add_info subst' b b'
......@@ -1038,6 +1041,8 @@ maybe_substitute subst b r
Just (extendCvSubst subst b co)
| isId b -- let x = e in <body>
, not (isCoVar b) -- See Note [Do not inline CoVars unconditionally]
-- in SimplUtils
, safe_to_inline (idOccInfo b)
, isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
, not (isStableUnfolding (idUnfolding b))
......@@ -1257,7 +1262,7 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
-- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args
cast_arg arg_ty arg = mkCoerce (theta_subst arg_ty) arg
cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
......
......@@ -9,7 +9,8 @@ Utility functions on @Core@ syntax
-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
mkTick, mkTickNoHNF, mkCoerce,
mkCast,
mkTick, mkTickNoHNF,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
......@@ -190,15 +191,27 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
\begin{code}
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co e | isReflCo co = e
mkCoerce co (Cast expr co2)
mkCast :: CoreExpr -> Coercion -> CoreExpr
mkCast e co | isReflCo co = e
mkCast (Coercion e_co) co
= Coercion new_co
where
-- g :: (s1 ~# s2) ~# (t1 ~# t2)
-- g1 :: s1 ~# t1
-- g2 :: s2 ~# t2
new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2
[_reflk, g1, g2] = decomposeCo 3 co
-- Remember, (~#) :: forall k. k -> k -> *
-- so it takes *three* arguments, not two
mkCast (Cast expr co2) co
= ASSERT(let { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind co2} in
from_ty `eqType` to_ty2 )
mkCoerce (mkTransCo co2 co) expr
mkCast expr (mkTransCo co2 co)
mkCoerce co expr
mkCast expr co
= let Pair from_ty _to_ty = coercionKind co in
-- if to_ty `eqType` from_ty
-- then expr
......@@ -1504,7 +1517,7 @@ tryEtaReduce bndrs body
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
go [] fun co
| ok_fun fun = Just (mkCoerce co fun)
| ok_fun fun = Just (mkCast fun co)
go (b : bs) (App fun arg) co
| Just co' <- ok_arg b arg co
......
......@@ -153,16 +153,21 @@ deSugar hsc_env
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Lint result if necessary, and print
{-
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
(vcat [ pprCoreBindings final_pgm
, pprRules rules_for_imps ])
-}
#ifdef DEBUG
; endPass dflags CoreDesugar final_pgm rules_for_imps
#endif
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies tcg_env
......
......@@ -186,10 +186,14 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
--------------------------------------
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsTcEvBinds (EvBinds bs) = -- pprTrace "EvBinds bs = " (ppr bs) $
dsEvBinds bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = return (map dsEvGroup sccs)
dsEvBinds bs = do { let core_binds = map dsEvSCC sccs
-- ; pprTrace "dsEvBinds, result = " (vcat (map ppr core_binds)) $
; return core_binds }
-- ; return (map dsEvGroup sccs)
where
sccs :: [SCC EvBind]
sccs = stronglyConnCompFromEdgedVertices edges
......@@ -202,19 +206,19 @@ dsEvBinds bs = return (map dsEvGroup sccs)
free_vars_of :: EvTerm -> [EvVar]
free_vars_of (EvId v) = [v]
free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co)
free_vars_of (EvCoercionBox co) = varSetElems (tyCoVarsOfCo co)
free_vars_of (EvCast v co) = v : varSetElems (coVarsOfCo co)
free_vars_of (EvCoercionBox co) = varSetElems (coVarsOfCo co)
free_vars_of (EvDFunApp _ _ vs) = vs
free_vars_of (EvTupleSel v _) = [v]
free_vars_of (EvTupleMk vs) = vs
free_vars_of (EvSuperClass d _) = [d]
dsEvGroup :: SCC EvBind -> CoreBind
dsEvSCC :: SCC EvBind -> CoreBind
dsEvGroup (AcyclicSCC (EvBind v r))
dsEvSCC (AcyclicSCC (EvBind v r))
= NonRec v (dsEvTerm r)
dsEvGroup (CyclicSCC bs)
dsEvSCC (CyclicSCC bs)
= Rec (map ds_pair bs)
where
ds_pair (EvBind v r) = (v, dsEvTerm r)
......@@ -251,8 +255,12 @@ dsLCoercion co k
---------------------------------------
dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co) = dsLCoercion co $ Cast (Var v)
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co)
= dsLCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercionBox co) = dsLCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
......@@ -686,12 +694,13 @@ dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper WpHole = return (\e -> e)
dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
-- ; pprTrace "Desugared core bindings = " (vcat (map ppr ds_ev_binds)) $
; return (mkCoreLets ds_ev_binds) }
dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
; k2 <- dsHsWrapper c2
; return (k1 . k2) }
dsHsWrapper (WpCast co)
= return (\e -> dsLCoercion co (Cast e))
= return (\e -> dsLCoercion co (mkCast e))
dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
dsHsWrapper (WpEvApp evtrm)
......
......@@ -142,7 +142,7 @@ unboxArg arg
-- Recursive newtypes
| Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
= unboxArg (mkCoerce co arg)
= unboxArg (mkCast arg co)
-- Booleans
| Just tc <- tyConAppTyCon_maybe arg_ty,
......@@ -342,7 +342,7 @@ resultWrapper result_ty
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
......
......@@ -642,7 +642,7 @@ mkSelectorBinds ticks pat val_expr
(Var bndr_var) error_expr
return (bndr_var, mkOptTickBox tick rhs_expr)
where
error_expr = mkCoerce co (Var err_var)
error_expr = mkCast (Var err_var) co
co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
......
......@@ -486,19 +486,21 @@ data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
-- The Unique is only for debug printing
-----------------
type EvBindMap = VarEnv EvBind
newtype EvBindMap = EvBindMap { ev_bind_varenv :: VarEnv EvBind } -- Map from evidence variables to evidence terms
emptyEvBindMap :: EvBindMap
emptyEvBindMap = emptyVarEnv
emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
extendEvBinds bs v t
= EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
lookupEvBind = lookupVarEnv
lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
evBindMapBinds :: EvBindMap -> Bag EvBind
evBindMapBinds = foldVarEnv consBag emptyBag
evBindMapBinds bs
= foldVarEnv consBag emptyBag (ev_bind_varenv bs)
-----------------
instance Data TcEvBinds where
......@@ -551,6 +553,11 @@ Conclusion: a new wanted coercion variable should be made mutable.
\begin{code}
mkEvCast :: EvVar -> LCoercion -> EvTerm
mkEvCast ev lco
| isReflCo lco = EvId ev
| otherwise = EvCast ev lco
emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag
......
......@@ -242,7 +242,17 @@ funTyConName :: Name
funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
funTyCon = mkFunTyCon funTyConName $
mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
-- instance Control.Arrow (->)
-- becuase the expected kind is (*->*->*). The trouble is that the
-- expected/actual stuff in the unifier does not go contra-variant, whereas
-- the kind sub-typing does. Sigh. It really only matters if you use (->) in
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
-- because they are never in scope in the source
-- One step to remove subkinding.
-- (->) :: * -> * -> *
-- but we should have (and want) the following typing rule for fully applied arrows
......
......@@ -251,8 +251,9 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things
| CoreDesugar -- Not strictly a core-to-core pass, but produces
-- Core output, and hence useful to pass to endPass
| CoreDesugar -- Right after desugaring, no simple optimisation yet!
| CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
-- Core output, and hence useful to pass to endPass
| CoreTidy
| CorePrep
......@@ -274,6 +275,7 @@ coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
coreDumpFlag CorePrep = Just Opt_D_dump_prep
......@@ -295,7 +297,8 @@ instance Outputable CoreToDo where
ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
ppr CoreCSE = ptext (sLit "Common sub-expression")
ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
ppr CoreDesugar = ptext (sLit "Desugar")
ppr CoreDesugar = ptext (sLit "Desugar (before optimization)")
ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)")
ppr CoreTidy = ptext (sLit "Tidy Core")
ppr CorePrep = ptext (sLit "CorePrep")
ppr CoreDoPrintCore = ptext (sLit "Print core")
......
......@@ -28,7 +28,7 @@ module OccurAnal (
import CoreSyn
import CoreFVs
import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCast )
import Id
import Name( localiseName )
import BasicTypes
......@@ -1345,7 +1345,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
where
(body_usg', tagged_bndr) = tagBinder body_usg bndr
rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
rhs = mkCast (Var (zapIdOccInfo rhs_var)) co -- See Note [Zap case binders in proxy bindings]
\end{code}
......
......@@ -1062,7 +1062,7 @@ mkLam _env bndrs body
| not (any bad bndrs)
-- Note [Casts and lambdas]
= do { lam <- mkLam' dflags bndrs body
; return (mkCoerce (mkPiCos bndrs co) lam) }
; return (mkCast lam (mkPiCos bndrs co)) }
where
co_vars = tyCoVarsOfCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
......
......@@ -983,26 +983,12 @@ simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
-- = Coercion (syn (nth 0 g) ; co ; nth 1 g)
simplCoercionF env co cont
= do { co' <- simplCoercion env co
; simpl_co co' cont }
where
simpl_co co (CoerceIt g cont)
= simpl_co new_co cont
where
-- g :: (s1 ~# s2) ~# (t1 ~# t2)
-- g1 :: s1 ~# t1
-- g2 :: s2 ~# t2
new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
[_reflk, g1, g2] = decomposeCo 3 g
-- Remember, (~#) :: forall k. k -> k -> *
-- so it takes *three* arguments, not two
simpl_co co cont
= seqCo co `seq` rebuild env (Coercion co) cont
; rebuild env (Coercion co') cont }
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
= let opt_co = optCoercion (getCvSubst env) co
in opt_co `seq` return opt_co
in seqCo opt_co `seq` return opt_co
-----------------------------------
-- | Push a TickIt context outwards past applications and cases, as
......@@ -1162,7 +1148,8 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
rebuild env expr cont
= case cont of
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (Cast expr co) cont
CoerceIt co cont -> rebuild env (mkCast expr co) cont
-- NB: mkCast implements the (Coercion co |> g) optimisation
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
......@@ -1242,7 +1229,7 @@ simplCast env body co0 cont0
-- t2 ~ s2 with left and right on the curried form:
-- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
new_arg = mkCoerce (mkSymCo co1) arg'
new_arg = mkCast arg' (mkSymCo co1)
arg' = substExpr (text "move-cast") arg_se' arg
arg_se' = arg_se `setInScope` env
......@@ -1447,7 +1434,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
cont_ty = contResultType env res_ty cont
co = mkUnsafeCo res_ty cont_ty
mk_coerce expr | cont_ty `eqType` res_ty = expr
| otherwise = mkCoerce co expr
| otherwise = mkCast expr co
rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
= do { arg_ty' <- if isSimplified dup_flag then return arg_ty
......
......@@ -29,12 +29,13 @@ module Inst (
tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts,
tidyWantedEvVar, tidyWantedEvVars, tidyWC,
tidyEvVar, tidyImplication, tidyFlavoredEvVar,
tidyEvVar, tidyImplication, tidyCt,
substWantedEvVar, substWantedEvVars, substFlavoredEvVar,
substEvVar, substImplication
substWantedEvVar, substWantedEvVars,
substEvVar, substImplication, substCt
) where
#include "HsVersions.h"
......@@ -512,20 +513,39 @@ hasEqualities :: [EvVar] -> Bool
-- Has a bunch of canonical constraints (all givens) got any equalities in it?
hasEqualities givens = any (has_eq . evVarPred) givens
where
has_eq = has_eq' . predTypePredTree
has_eq = has_eq' . classifyPredType
has_eq' (EqPred {}) = True
has_eq' (IPPred {}) = False
has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
has_eq' (TuplePred ts) = any has_eq' ts
has_eq' (TuplePred ts) = any has_eq ts
has_eq' (IrredPred _) = True -- Might have equalities in it after reduction?
---------------- Getting free tyvars -------------------------
tyVarsOfCt :: Ct -> TcTyVarSet
tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_id = ev }) = tyVarsOfEvVar ev
tyVarsOfCDict :: Ct -> TcTyVarSet
tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCDict _ct = emptyVarSet
tyVarsOfCDicts :: Cts -> TcTyVarSet
tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
tyVarsOfCts :: Cts -> TcTyVarSet
tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfEvVarXs flat `unionVarSet`
= tyVarsOfCts flat `unionVarSet`
tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
tyVarsOfEvVarXs insol
tyVarsOfCts insol
tyVarsOfImplication :: Implication -> TyVarSet
tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
......@@ -547,11 +567,19 @@ tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
---------------- Tidying -------------------------
tidyCt :: TidyEnv -> Ct -> Ct
-- Also converts it to non-canonical
tidyCt env ct
= CNonCanonical { cc_id = tidyEvVar env (cc_id ct)
, cc_flavor = tidyFlavor env (cc_flavor ct)
, cc_depth = cc_depth ct }
tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints
tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = tidyWantedEvVars env flat
= WC { wc_flat = mapBag (tidyCt env) flat
, wc_impl = mapBag (tidyImplication env) implic
, wc_insol = mapBag (tidyFlavoredEvVar env) insol }
, wc_insol = mapBag (tidyCt env) insol }
tidyImplication :: TidyEnv -> Implication -> Implication
tidyImplication env implic@(Implic { ic_skols = tvs
......@@ -574,9 +602,6 @@ tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
......@@ -591,11 +616,24 @@ tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo _ info = info
---------------- Substitution -------------------------
substCt :: TvSubst -> Ct -> Ct
-- Conservatively converts it to non-canonical:
-- Postcondition: if the constraint does not get rewritten
substCt subst ct
| ev <- cc_id ct, pty <- evVarPred (cc_id ct)
, sty <- substTy subst pty
= if sty `eqType` pty then
ct { cc_flavor = substFlavor subst (cc_flavor ct) }
else
CNonCanonical { cc_id = setVarType ev sty
, cc_flavor = substFlavor subst (cc_flavor ct)
, cc_depth = cc_depth ct }
substWC :: TvSubst -> WantedConstraints -> WantedConstraints
substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = substWantedEvVars subst flat
, wc_impl = mapBag (substImplication subst) implic