summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2019-02-15 09:56:06 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-02-17 19:58:29 -0500
commit1f1b9e356a873ec7da84cdac2a7850ecb2b32ea9 (patch)
tree44fea568c24fc4cc0a394111edbd7f8be62d1ee5
parent0fff3ae6d2b821cacf33193b85307588402f1748 (diff)
downloadhaskell-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.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 )
-
{-
************************************************************************
* *