diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 56 |
1 files changed, 53 insertions, 3 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index e5c787a478..eedc318017 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -37,6 +37,7 @@ import CoreUnfold import CoreFVs import UniqSupply import Digraph +import Pair import PrelNames import TysPrim ( mkProxyPrimTy ) @@ -47,7 +48,8 @@ import Type import Kind (returnsConstraintKind) import Coercion hiding (substCo) import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy - , mkBoxedTupleTy, stringTy, typeNatKind, typeSymbolKind ) + , mkBoxedTupleTy, stringTy, typeNatKind, typeSymbolKind + , instanceOfNewtypeAxiom ) import Id import MkId(proxyHashId) import Class @@ -629,6 +631,9 @@ decomposeRuleLhs orig_bndrs orig_lhs split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) split_lets e + | Let (NonRec d (Var r)) _body <- e + , isDictId d, isDictId r + = ([], e) | Let (NonRec d r) body <- e , isDictId d , (bs, body') <- split_lets body @@ -801,7 +806,8 @@ dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational) dsTcCoercion co (mkCast e) dsHsWrapper (WpEvLam ev) e = return $ Lam ev e dsHsWrapper (WpTyLam tv) e = return $ Lam tv e -dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm) +dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm) +dsHsWrapper (WpEvInstOf v) e = return $ applyInstanceOf v e -------------------------------------- dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] @@ -820,7 +826,8 @@ dsEvBinds bs = mapM ds_scc (sccEvBinds bs) = liftM (NonRec v) (dsEvTerm r) ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs) - ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r) + ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) + = liftM ((,) v) (dsEvTerm r) sccEvBinds :: Bag EvBind -> [SCC EvBind] sccEvBinds bs = stronglyConnCompFromEdgedVertices edges @@ -866,6 +873,8 @@ dsEvTerm (EvCallStack cs) = dsEvCallStack cs dsEvTerm (EvTypeable ev) = dsEvTypeable ev +dsEvTerm (EvInstanceOf ty ev) = dsEvInstanceOfBndr ty ev + dsEvTypeable :: EvTypeable -> DsM CoreExpr dsEvTypeable ev = do tyCl <- dsLookupTyCon typeableClassName @@ -1158,3 +1167,44 @@ which simpleOpt (currently) doesn't remove. So the rule never matches. Maybe simpleOpt should be smarter. But it seems like a good plan to simply never generate the redundant box/unbox in the first place. -} + +-- In order to get a smaller term to simplify, +-- we apply a direct simplification at this point, +-- removing all identity coercions and instantiations. +dsEvInstanceOfBndr :: Type -> EvInstanceOf -> DsM CoreExpr +dsEvInstanceOfBndr ty ev + = do { bndr <- newSysLocalDs ty + ; expr <- dsEvInstanceOf ev (Var bndr) + ; let ty2 = exprType expr + inner = if ty == ty2 then Var bndr else expr + ; return $ Cast (mkCoreLams [bndr] inner) + (SymCo (coInstanceOfArrow ty (exprType expr))) } + +applyInstanceOf :: EvId -> CoreExpr -> CoreExpr +applyInstanceOf id e + | (_, [ty1, ty2]) <- splitTyConApp (idType id) + = if ty1 == ty2 + then e -- Shortcut: we have the reflexive instantiation + else mkCoreApp (Cast (Var id) (coInstanceOfArrow ty1 ty2)) e + | otherwise + = pprPanic "The impossible happened" (ppr id) + +dsEvInstanceOf :: EvInstanceOf -> CoreExpr -> DsM CoreExpr +dsEvInstanceOf (EvInstanceOfEq co) e + = do { dsTcCoercion co $ \c -> + case coercionKind c of + Pair ty1 ty2 | ty1 == ty2 -> e -- No conversion needed + _ -> mkCast e (mkSubCo c) } +dsEvInstanceOf (EvInstanceOfInst qvars co qs) e + = do { qs' <- mapM dsEvTerm qs + ; let exprTy = mkCoreApps e (map Type qvars) + exprEv = mkCoreApps exprTy qs' + ; return $ applyInstanceOf co exprEv } +dsEvInstanceOf (EvInstanceOfGen tyvars qvars qs rest) e + = do { q_binds <- dsTcEvBinds qs + ; return $ mkCoreLams (tyvars ++ qvars) + (mkCoreLets q_binds (applyInstanceOf rest e)) } + +coInstanceOfArrow :: Type -> Type -> Coercion +coInstanceOfArrow ty1 ty2 + = mkUnbranchedAxInstCo Representational instanceOfNewtypeAxiom [ty1, ty2] |