diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2019-02-15 09:56:06 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-02-17 19:58:29 -0500 |
commit | 1f1b9e356a873ec7da84cdac2a7850ecb2b32ea9 (patch) | |
tree | 44fea568c24fc4cc0a394111edbd7f8be62d1ee5 | |
parent | 0fff3ae6d2b821cacf33193b85307588402f1748 (diff) | |
download | haskell-1f1b9e356a873ec7da84cdac2a7850ecb2b32ea9.tar.gz |
Get rid of tcm_smart from TyCoMapper
Following a succession of refactorings of the type checker,
culminating in the patch
Make a smart mkAppTyM
we have got rid of mkNakedAppTy etc. And that in turn
meant that the tcm_smart field of the generic TyCoMapper
(in Type.hs) was entirely unused. It was always set to True.
So this patch just gets rid of it completely. Less code,
less complexity, and more efficient because fewer higher-order
function calls. Everyone wins.
No change in behaviour; this does not cure any bugs!
-rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.hs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcMType.hs | 18 | ||||
-rw-r--r-- | compiler/types/Type.hs | 64 |
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 ) - {- ************************************************************************ * * |