summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/typecheck/TcHsSyn.hs9
-rw-r--r--compiler/typecheck/TcHsType.hs3
-rw-r--r--compiler/typecheck/TcMType.hs18
-rw-r--r--compiler/types/Type.hs64
4 files changed, 39 insertions, 55 deletions
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 3f7a32565d..8b815bb0e7 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1848,12 +1848,11 @@ zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
zonk_tycomapper :: TyCoMapper ZonkEnv TcM
zonk_tycomapper = TyCoMapper
- { tcm_smart = True -- Establish type invariants
- , tcm_tyvar = zonkTyVarOcc
- , tcm_covar = zonkCoVarOcc
- , tcm_hole = zonkCoHole
+ { tcm_tyvar = zonkTyVarOcc
+ , tcm_covar = zonkCoVarOcc
+ , tcm_hole = zonkCoHole
, tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
- , tcm_tycon = zonkTcTyConToTyCon }
+ , tcm_tycon = zonkTcTyConToTyCon }
-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index cae0b5bcf2..91b7aa279d 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -2809,8 +2809,7 @@ zonkPromoteType = mapType zonkPromoteMapper ()
-- cf. TcMType.zonkTcTypeMapper
zonkPromoteMapper :: TyCoMapper () TcM
-zonkPromoteMapper = TyCoMapper { tcm_smart = True
- , tcm_tyvar = const zonkPromoteTcTyVar
+zonkPromoteMapper = TyCoMapper { tcm_tyvar = const zonkPromoteTcTyVar
, tcm_covar = const covar
, tcm_hole = const hole
, tcm_tycobinder = const tybinder
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index c12c2f6e88..ded352c1f1 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -1939,12 +1939,11 @@ zonkCoVar = zonkId
-- before all metavars are filled in.
zonkTcTypeMapper :: TyCoMapper () TcM
zonkTcTypeMapper = TyCoMapper
- { tcm_smart = True
- , tcm_tyvar = const zonkTcTyVar
+ { tcm_tyvar = const zonkTcTyVar
, tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
, tcm_hole = hole
, tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
- , tcm_tycon = zonk_tc_tycon }
+ , tcm_tycon = zonkTcTyCon }
where
hole :: () -> CoercionHole -> TcM Coercion
hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
@@ -1955,11 +1954,14 @@ zonkTcTypeMapper = TyCoMapper
Nothing -> do { cv' <- zonkCoVar cv
; return $ HoleCo (hole { ch_co_var = cv' }) } }
- zonk_tc_tycon tc -- A non-poly TcTyCon may have unification
- -- variables that need zonking, but poly ones cannot
- | tcTyConIsPoly tc = return tc
- | otherwise = do { tck' <- zonkTcType (tyConKind tc)
- ; return (setTcTyConKind tc tck') }
+zonkTcTyCon :: TcTyCon -> TcM TcTyCon
+-- Only called on TcTyCons
+-- A non-poly TcTyCon may have unification
+-- variables that need zonking, but poly ones cannot
+zonkTcTyCon tc
+ | tcTyConIsPoly tc = return tc
+ | otherwise = do { tck' <- zonkTcType (tyConKind tc)
+ ; return (setTcTyConKind tc tck') }
-- For unbound, mutable tyvars, zonkType uses the function given to it
-- For tyvars bound at a for-all, zonkType zonks them to an immutable
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 6590489b01..945d7e1a8d 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -527,9 +527,7 @@ this one change made a 20% allocation difference in perf/compiler/T5030.
-- | This describes how a "map" operation over a type/coercion should behave
data TyCoMapper env m
= TyCoMapper
- { tcm_smart :: Bool -- ^ Should the new type be created with smart
- -- constructors?
- , tcm_tyvar :: env -> TyVar -> m Type
+ { tcm_tyvar :: env -> TyVar -> m Type
, tcm_covar :: env -> CoVar -> m Coercion
, tcm_hole :: env -> CoercionHole -> m Coercion
-- ^ What to do with coercion holes.
@@ -548,24 +546,25 @@ data TyCoMapper env m
{-# INLINABLE mapType #-} -- See Note [Specialising mappers]
mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type
-mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
- , tcm_tycobinder = tycobinder, tcm_tycon = tycon })
+mapType mapper@(TyCoMapper { tcm_tyvar = tyvar
+ , tcm_tycobinder = tycobinder
+ , tcm_tycon = tycon })
env ty
= go ty
where
go (TyVarTy tv) = tyvar env tv
- go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2
+ go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2
go ty@(TyConApp tc tys)
| isTcTyCon tc
= do { tc' <- tycon tc
- ; mktyconapp tc' <$> mapM go tys }
+ ; mkTyConApp tc' <$> mapM go tys }
-- Not a TcTyCon
| null tys -- Avoid allocation in this very
= return ty -- common case (E.g. Int, LiftedRep etc)
| otherwise
- = mktyconapp tc <$> mapM go tys
+ = mkTyConApp tc <$> mapM go tys
go (FunTy arg res) = FunTy <$> go arg <*> go res
go (ForAllTy (Bndr tv vis) inner)
@@ -573,18 +572,15 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
; inner' <- mapType mapper env' inner
; return $ ForAllTy (Bndr tv' vis) inner' }
go ty@(LitTy {}) = return ty
- go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co
+ go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co
go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co
- (mktyconapp, mkappty, mkcastty)
- | smart = (mkTyConApp, mkAppTy, mkCastTy)
- | otherwise = (TyConApp, AppTy, CastTy)
-
{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers]
mapCoercion :: Monad m
=> TyCoMapper env m -> env -> Coercion -> m Coercion
-mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
- , tcm_hole = cohole, tcm_tycobinder = tycobinder
+mapCoercion mapper@(TyCoMapper { tcm_covar = covar
+ , tcm_hole = cohole
+ , tcm_tycobinder = tycobinder
, tcm_tycon = tycon })
env co
= go co
@@ -593,53 +589,41 @@ mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
go_mco (MCo co) = MCo <$> (go co)
go (Refl ty) = Refl <$> mapType mapper env ty
- go (GRefl r ty mco) = mkgreflco r <$> mapType mapper env ty <*> (go_mco mco)
+ go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco)
go (TyConAppCo r tc args)
= do { tc' <- if isTcTyCon tc
then tycon tc
else return tc
- ; mktyconappco r tc' <$> mapM go args }
- go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2
+ ; mkTyConAppCo r tc' <$> mapM go args }
+ go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2
go (ForAllCo tv kind_co co)
= do { kind_co' <- go kind_co
; (env', tv') <- tycobinder env tv Inferred
; co' <- mapCoercion mapper env' co
- ; return $ mkforallco tv' kind_co' co' }
+ ; return $ mkForAllCo tv' kind_co' co' }
-- See Note [Efficiency for mapCoercion ForAllCo case]
go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
go (CoVarCo cv) = covar env cv
go (AxiomInstCo ax i args)
- = mkaxiominstco ax i <$> mapM go args
+ = mkAxiomInstCo ax i <$> mapM go args
go (HoleCo hole) = cohole env hole
go (UnivCo p r t1 t2)
- = mkunivco <$> go_prov p <*> pure r
+ = mkUnivCo <$> go_prov p <*> pure r
<*> mapType mapper env t1 <*> mapType mapper env t2
- go (SymCo co) = mksymco <$> go co
- go (TransCo c1 c2) = mktransco <$> go c1 <*> go c2
+ go (SymCo co) = mkSymCo <$> go co
+ go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2
go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos
- go (NthCo r i co) = mknthco r i <$> go co
- go (LRCo lr co) = mklrco lr <$> go co
- go (InstCo co arg) = mkinstco <$> go co <*> go arg
- go (KindCo co) = mkkindco <$> go co
- go (SubCo co) = mksubco <$> go co
+ go (NthCo r i co) = mkNthCo r i <$> go co
+ go (LRCo lr co) = mkLRCo lr <$> go co
+ go (InstCo co arg) = mkInstCo <$> go co <*> go arg
+ go (KindCo co) = mkKindCo <$> go co
+ go (SubCo co) = mkSubCo <$> go co
go_prov UnsafeCoerceProv = return UnsafeCoerceProv
go_prov (PhantomProv co) = PhantomProv <$> go co
go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co
go_prov p@(PluginProv _) = return p
- ( mktyconappco, mkappco, mkaxiominstco, mkunivco
- , mksymco, mktransco, mknthco, mklrco, mkinstco
- , mkkindco, mksubco, mkforallco, mkgreflco)
- | smart
- = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo
- , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo
- , mkKindCo, mkSubCo, mkForAllCo, mkGReflCo )
- | otherwise
- = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo
- , SymCo, TransCo, NthCo, LRCo, InstCo
- , KindCo, SubCo, ForAllCo, GRefl )
-
{-
************************************************************************
* *
View Lorry Controller Status