diff options
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 2 | ||||
| -rw-r--r-- | compiler/iface/TcIface.hs | 3 | ||||
| -rw-r--r-- | compiler/iface/ToIface.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/CoreEraseCoercionProofs.hs | 10 |
4 files changed, 12 insertions, 5 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 10cb022b18..b587196159 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1691,7 +1691,7 @@ lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, Linted -- See Note [GHC Formalism] lintCoercion (ErasedCoercion role lty rty) = do { kl <- lintType lty ; - kr <- lintType rty + kr <- lintType rty ; return (kl,kr,lty,rty,role) } lintCoercion (Refl ty) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 818745775a..18d62f5b88 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -1215,6 +1215,9 @@ tcIfaceCo = go go_mco IfaceMRefl = pure MRefl go_mco (IfaceMCo co) = MCo <$> (go co) + go (IfaceErased r ltyi rtyi) + = ErasedCoercion r <$>(tcIfaceType ltyi) + <*>(tcIfaceType rtyi) go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index 62b091c0af..c23985d89d 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -265,7 +265,7 @@ toIfaceCoercionX fr co go_mco MRefl = IfaceMRefl go_mco (MCo co) = IfaceMCo $ go co - go (ErasedCoercion r lty rty) = IfaceErased r lty rty + go (ErasedCoercion r lty rty) = IfaceErased r (toIfaceType lty) (toIfaceType rty) go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) go (CoVarCo cv) diff --git a/compiler/simplCore/CoreEraseCoercionProofs.hs b/compiler/simplCore/CoreEraseCoercionProofs.hs index cf498d5e8b..baa0695cb7 100644 --- a/compiler/simplCore/CoreEraseCoercionProofs.hs +++ b/compiler/simplCore/CoreEraseCoercionProofs.hs @@ -3,6 +3,7 @@ module CoreEraseCoercionProofs (eraseCoercionProgram,coreProgramEraseCoercionPro import GhcPrelude import CoreSyn +import Pair import HscTypes ( ModGuts(..) ) import Coercion import CoreMonad ( CoreM ) @@ -35,13 +36,16 @@ coreExprEraseProof (Lam v e) = Lam v $ coreExprEraseProof e coreExprEraseProof (Let binder bod) = Let (eraseBinders binder) (coreExprEraseProof bod) coreExprEraseProof (Case scrut v ty alts )= Case (coreExprEraseProof scrut) v ty (map eraseAltPfs alts) + --- TODO : add mrefl and refl cases, + --- that should suffice to prevent regresions vs current ghc coreExprEraseProof (Cast e co ) = Cast (coreExprEraseProof e) (ErasedCoercion role lty rty ) where - (Pair lty rty,role) = coercionKindRole + (Pair lty rty,role) = coercionKindRole co coreExprEraseProof (Tick tick e)= Tick tick (coreExprEraseProof e) coreExprEraseProof (Type t) = Type t -coreExprEraseProof (Coercion _)= Coercion ErasedCoercion - +coreExprEraseProof (Coercion co )= Coercion (ErasedCoercion role lty rty ) + where + (Pair lty rty,role) = coercionKindRole co eraseAltPfs :: CoreAlt -> CoreAlt eraseAltPfs (con, vars, body) = (con,vars,coreExprEraseProof body) |