[Git][ghc/ghc][master] Make `Functor` a superclass of `TrieMap`, which lets us derive the `map` functions.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 18 07:35:59 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
9ecd1ac0 by M Farkas-Dyck at 2022-10-18T03:35:38-04:00
Make `Functor` a superclass of `TrieMap`, which lets us derive the `map` functions.
- - - - -
5 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Stg/CSE.hs
Changes:
=====================================
compiler/GHC/Cmm/Dataflow/Label.hs
=====================================
@@ -140,7 +140,6 @@ instance TrieMap LabelMap where
lookupTM k m = mapLookup k m
alterTM k f m = mapAlter f k m
foldTM k m z = mapFoldr k z m
- mapTM f m = mapMap f m
filterTM f m = mapFilter f m
-----------------------------------------------------------------------------
=====================================
compiler/GHC/Core/Map/Expr.hs
=====================================
@@ -109,13 +109,17 @@ See also Note [Empty case alternatives] in GHC.Core.
-- is the type you want.
newtype CoreMap a = CoreMap (CoreMapG a)
+-- TODO(22292): derive
+instance Functor CoreMap where
+ fmap f = \ (CoreMap m) -> CoreMap (fmap f m)
+ {-# INLINE fmap #-}
+
instance TrieMap CoreMap where
type Key CoreMap = CoreExpr
emptyTM = CoreMap emptyTM
lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
foldTM k (CoreMap m) = foldTM k m
- mapTM f (CoreMap m) = CoreMap (mapTM f m)
filterTM f (CoreMap m) = CoreMap (filterTM f m)
-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a at . The extended
@@ -248,30 +252,27 @@ emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
, cm_letr = emptyTM, cm_case = emptyTM
, cm_ecase = emptyTM, cm_tick = emptyTM }
+-- TODO(22292): derive
+instance Functor CoreMapX where
+ fmap f CM
+ { cm_var = cvar, cm_lit = clit, cm_co = cco, cm_type = ctype, cm_cast = ccast
+ , cm_app = capp, cm_lam = clam, cm_letn = cletn, cm_letr = cletr, cm_case = ccase
+ , cm_ecase = cecase, cm_tick = ctick } = CM
+ { cm_var = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype
+ , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam
+ , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr
+ , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase
+ , cm_tick = fmap (fmap f) ctick }
+
instance TrieMap CoreMapX where
type Key CoreMapX = DeBruijn CoreExpr
emptyTM = emptyE
lookupTM = lkE
alterTM = xtE
foldTM = fdE
- mapTM = mapE
filterTM = ftE
--------------------------
-mapE :: (a->b) -> CoreMapX a -> CoreMapX b
-mapE f (CM { cm_var = cvar, cm_lit = clit
- , cm_co = cco, cm_type = ctype
- , cm_cast = ccast , cm_app = capp
- , cm_lam = clam, cm_letn = cletn
- , cm_letr = cletr, cm_case = ccase
- , cm_ecase = cecase, cm_tick = ctick })
- = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
- , cm_co = mapTM f cco, cm_type = mapTM f ctype
- , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
- , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
- , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
- , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
-
ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
ftE f (CM { cm_var = cvar, cm_lit = clit
, cm_co = cco, cm_type = ctype
@@ -281,10 +282,10 @@ ftE f (CM { cm_var = cvar, cm_lit = clit
, cm_ecase = cecase, cm_tick = ctick })
= CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
, cm_co = filterTM f cco, cm_type = filterTM f ctype
- , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
- , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
- , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
- , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
+ , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp
+ , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn
+ , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase
+ , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick }
--------------------------
lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
@@ -394,6 +395,11 @@ data AltMap a -- A single alternative
, am_data :: DNameEnv (CoreMapG a)
, am_lit :: LiteralMap (CoreMapG a) }
+-- TODO(22292): derive
+instance Functor AltMap where
+ fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM
+ { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit }
+
instance TrieMap AltMap where
type Key AltMap = CoreAlt
emptyTM = AM { am_deflt = emptyTM
@@ -402,7 +408,6 @@ instance TrieMap AltMap where
lookupTM = lkA emptyCME
alterTM = xtA emptyCME
foldTM = fdA
- mapTM = mapA
filterTM = ftA
instance Eq (DeBruijn CoreAlt) where
@@ -416,17 +421,11 @@ instance Eq (DeBruijn CoreAlt) where
D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
go _ _ = False
-mapA :: (a->b) -> AltMap a -> AltMap b
-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
- = AM { am_deflt = mapTM f adeflt
- , am_data = mapTM (mapTM f) adata
- , am_lit = mapTM (mapTM f) alit }
-
ftA :: (a->Bool) -> AltMap a -> AltMap a
ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
= AM { am_deflt = filterTM f adeflt
- , am_data = mapTM (filterTM f) adata
- , am_lit = mapTM (filterTM f) alit }
+ , am_data = fmap (filterTM f) adata
+ , am_lit = fmap (filterTM f) alit }
lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs)
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -83,25 +83,33 @@ import GHC.Data.Maybe
-- just look up the coercion's type.
newtype CoercionMap a = CoercionMap (CoercionMapG a)
+-- TODO(22292): derive
+instance Functor CoercionMap where
+ fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m)
+ {-# INLINE fmap #-}
+
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
emptyTM = CoercionMap emptyTM
lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m
alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)
foldTM k (CoercionMap m) = foldTM k m
- mapTM f (CoercionMap m) = CoercionMap (mapTM f m)
filterTM f (CoercionMap m) = CoercionMap (filterTM f m)
type CoercionMapG = GenMap CoercionMapX
newtype CoercionMapX a = CoercionMapX (TypeMapX a)
+-- TODO(22292): derive
+instance Functor CoercionMapX where
+ fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm)
+ {-# INLINE fmap #-}
+
instance TrieMap CoercionMapX where
type Key CoercionMapX = DeBruijn Coercion
emptyTM = CoercionMapX emptyTM
lookupTM = lkC
alterTM = xtC
foldTM f (CoercionMapX core_tm) = foldTM f core_tm
- mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm)
filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)
instance Eq (DeBruijn Coercion) where
@@ -172,13 +180,21 @@ trieMapView ty
| Just ty' <- tcView ty = Just ty'
trieMapView _ = Nothing
+-- TODO(22292): derive
+instance Functor TypeMapX where
+ fmap f TM
+ { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_funty = tfunty, tm_forall = tforall
+ , tm_tylit = tlit, tm_coerce = tcoerce } = TM
+ { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon
+ , tm_funty = fmap (fmap (fmap f)) tfunty, tm_forall = fmap (fmap f) tforall
+ , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce }
+
instance TrieMap TypeMapX where
type Key TypeMapX = DeBruijn Type
emptyTM = emptyT
lookupTM = lkT
alterTM = xtT
foldTM = fdT
- mapTM = mapT
filterTM = filterT
instance Eq (DeBruijn Type) where
@@ -313,18 +329,6 @@ emptyT = TM { tm_var = emptyTM
, tm_tylit = emptyTyLitMap
, tm_coerce = Nothing }
-mapT :: (a->b) -> TypeMapX a -> TypeMapX b
-mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
- , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
- , tm_coerce = tcoerce })
- = TM { tm_var = mapTM f tvar
- , tm_app = mapTM (mapTM f) tapp
- , tm_tycon = mapTM f ttycon
- , tm_funty = mapTM (mapTM (mapTM f)) tfunty
- , tm_forall = mapTM (mapTM f) tforall
- , tm_tylit = mapTM f tlit
- , tm_coerce = fmap f tcoerce }
-
-----------------
lkT :: DeBruijn Type -> TypeMapX a -> Maybe a
lkT (D env ty) m = go ty m
@@ -382,10 +386,10 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
, tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
, tm_coerce = tcoerce })
= TM { tm_var = filterTM f tvar
- , tm_app = mapTM (filterTM f) tapp
+ , tm_app = fmap (filterTM f) tapp
, tm_tycon = filterTM f ttycon
- , tm_funty = mapTM (mapTM (filterTM f)) tfunty
- , tm_forall = mapTM (filterTM f) tforall
+ , tm_funty = fmap (fmap (filterTM f)) tfunty
+ , tm_forall = fmap (filterTM f) tforall
, tm_tylit = filterTM f tlit
, tm_coerce = filterMaybe f tcoerce }
@@ -395,22 +399,22 @@ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_char :: Map.Map Char a
}
+-- TODO(22292): derive
+instance Functor TyLitMap where
+ fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM
+ { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
+
instance TrieMap TyLitMap where
type Key TyLitMap = TyLit
emptyTM = emptyTyLitMap
lookupTM = lkTyLit
alterTM = xtTyLit
foldTM = foldTyLit
- mapTM = mapTyLit
filterTM = filterTyLit
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }
-mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b
-mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
- = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
-
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
@@ -439,6 +443,11 @@ filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
-- is the type you want. The keys in this map may have different kinds.
newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))
+-- TODO(22292): derive
+instance Functor TypeMap where
+ fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m)
+ {-# INLINE fmap #-}
+
lkTT :: DeBruijn Type -> TypeMap a -> Maybe a
lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m
>>= lkG (D env ty)
@@ -456,8 +465,7 @@ instance TrieMap TypeMap where
lookupTM k m = lkTT (deBruijnize k) m
alterTM k f m = xtTT (deBruijnize k) f m
foldTM k (TypeMap m) = foldTM (foldTM k) m
- mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)
- filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)
+ filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m)
foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap k z m = foldTM k m z
@@ -488,8 +496,12 @@ mkDeBruijnContext = extendCMEs emptyCME
-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),
-- you'll find entries inserted under (t), even if (g) is non-reflexive.
-newtype LooseTypeMap a
- = LooseTypeMap (TypeMapG a)
+newtype LooseTypeMap a = LooseTypeMap (TypeMapG a)
+
+-- TODO(22292): derive
+instance Functor LooseTypeMap where
+ fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m)
+ {-# INLINE fmap #-}
instance TrieMap LooseTypeMap where
type Key LooseTypeMap = Type
@@ -497,7 +509,6 @@ instance TrieMap LooseTypeMap where
lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m
alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)
foldTM f (LooseTypeMap m) = foldTM f m
- mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)
filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)
{-
@@ -566,18 +577,19 @@ instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where
-- of pairs are composition.
data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))
+-- TODO(22292): derive
+instance Functor BndrMap where
+ fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm)
+ {-# INLINE fmap #-}
+
instance TrieMap BndrMap where
type Key BndrMap = Var
emptyTM = BndrMap emptyTM
lookupTM = lkBndr emptyCME
alterTM = xtBndr emptyCME
foldTM = fdBndrMap
- mapTM = mapBndrMap
filterTM = ftBndrMap
-mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b
-mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)
-
fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b
fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm
@@ -596,25 +608,24 @@ xtBndr env v xt (BndrMap tymap) =
BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))
ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a
-ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)
+ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm)
--------- Variable occurrence -------------
data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable
, vm_fvar :: DVarEnv a } -- Free variable
+-- TODO(22292): derive
+instance Functor VarMap where
+ fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv }
+
instance TrieMap VarMap where
type Key VarMap = Var
emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }
lookupTM = lkVar emptyCME
alterTM = xtVar emptyCME
foldTM = fdVar
- mapTM = mapVar
filterTM = ftVar
-mapVar :: (a->b) -> VarMap a -> VarMap b
-mapVar f (VM { vm_bvar = bv, vm_fvar = fv })
- = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }
-
lkVar :: CmEnv -> Var -> VarMap a -> Maybe a
lkVar env v
| Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv
=====================================
compiler/GHC/Data/TrieMap.hs
=====================================
@@ -66,12 +66,11 @@ Structures", Section 10.3.2
type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing)
-- or an existing elt (Just)
-class TrieMap m where
+class Functor m => TrieMap m where
type Key m :: Type
emptyTM :: m a
lookupTM :: forall b. Key m -> m b -> Maybe b
alterTM :: forall b. Key m -> XT b -> m b -> m b
- mapTM :: (a->b) -> m a -> m b
filterTM :: (a -> Bool) -> m a -> m a
foldTM :: (a -> b -> b) -> m a -> b -> b
@@ -116,6 +115,25 @@ deMaybe :: TrieMap m => Maybe (m a) -> m a
deMaybe Nothing = emptyTM
deMaybe (Just m) = m
+{-
+Note [Every TrieMap is a Functor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Every TrieMap T admits
+ fmap :: (a->b) -> T a -> T b
+where (fmap f t) applies `f` to every element of the range of `t`.
+Ergo, we make `Functor` a superclass of `TrieMap`.
+
+Moreover it is almost invariably possible to /derive/ Functor for each
+particular instance. E.g. in the list instance we have
+ data ListMap m a
+ = LM { lm_nil :: Maybe a
+ , lm_cons :: m (ListMap m a) }
+ deriving (Functor)
+ instance TrieMap m => TrieMap (ListMap m) where { .. }
+
+Alas, we not yet derive `Functor` for reasons of performance; see #22292.
+-}
+
{-
************************************************************************
* *
@@ -130,7 +148,6 @@ instance TrieMap IntMap.IntMap where
lookupTM k m = IntMap.lookup k m
alterTM = xtInt
foldTM k m z = IntMap.foldr k z m
- mapTM f m = IntMap.map f m
filterTM f m = IntMap.filter f m
xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
@@ -142,7 +159,6 @@ instance Ord k => TrieMap (Map.Map k) where
lookupTM = Map.lookup
alterTM k f m = Map.alter f k m
foldTM k m z = Map.foldr k z m
- mapTM f m = Map.map f m
filterTM f m = Map.filter f m
@@ -219,7 +235,6 @@ instance forall key. Uniquable key => TrieMap (UniqDFM key) where
lookupTM k m = lookupUDFM m k
alterTM k f m = alterUDFM f m k
foldTM k m z = foldUDFM k z m
- mapTM f m = mapUDFM f m
filterTM f m = filterUDFM f m
{-
@@ -235,22 +250,22 @@ then (MaybeMap m) is a map from (Maybe k) -> val
data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a }
+-- TODO(22292): derive
+instance Functor m => Functor (MaybeMap m) where
+ fmap f MM { mm_nothing = mn, mm_just = mj } = MM
+ { mm_nothing = fmap f mn, mm_just = fmap f mj }
+
instance TrieMap m => TrieMap (MaybeMap m) where
type Key (MaybeMap m) = Maybe (Key m)
emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM }
lookupTM = lkMaybe lookupTM
alterTM = xtMaybe alterTM
foldTM = fdMaybe
- mapTM = mapMb
filterTM = ftMaybe
instance TrieMap m => Foldable (MaybeMap m) where
foldMap = foldMapTM
-mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
-mapMb f (MM { mm_nothing = mn, mm_just = mj })
- = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
-
lkMaybe :: (forall b. k -> m b -> Maybe b)
-> Maybe k -> MaybeMap m a -> Maybe a
lkMaybe _ Nothing = mm_nothing
@@ -290,13 +305,17 @@ data ListMap m a
= LM { lm_nil :: Maybe a
, lm_cons :: m (ListMap m a) }
+-- TODO(22292): derive
+instance Functor m => Functor (ListMap m) where
+ fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM
+ { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons }
+
instance TrieMap m => TrieMap (ListMap m) where
type Key (ListMap m) = [Key m]
emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM }
lookupTM = lkList lookupTM
alterTM = xtList alterTM
foldTM = fdList
- mapTM = mapList
filterTM = ftList
instance TrieMap m => Foldable (ListMap m) where
@@ -305,10 +324,6 @@ instance TrieMap m => Foldable (ListMap m) where
instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where
ppr m = text "List elts" <+> ppr (foldTM (:) m [])
-mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
-mapList f (LM { lm_nil = mnil, lm_cons = mcons })
- = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
-
lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
-> [k] -> ListMap m a -> Maybe a
lkList _ [] = lm_nil
@@ -326,7 +341,7 @@ fdList k m = foldMaybe k (lm_nil m)
ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
ftList f (LM { lm_nil = mnil, lm_cons = mcons })
- = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }
+ = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }
{-
************************************************************************
@@ -380,6 +395,11 @@ instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where
ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v
ppr (MultiMap m) = ppr m
+-- TODO(22292): derive
+instance Functor m => Functor (GenMap m) where
+ fmap = mapG
+ {-# INLINE fmap #-}
+
-- TODO undecidable instance
instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
type Key (GenMap m) = Key m
@@ -387,7 +407,6 @@ instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
lookupTM = lkG
alterTM = xtG
foldTM = fdG
- mapTM = mapG
filterTM = ftG
instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where
@@ -431,10 +450,10 @@ xtG k f m@(SingletonMap k' v')
xtG k f (MultiMap m) = MultiMap (alterTM k f m)
{-# INLINEABLE mapG #-}
-mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b
+mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b
mapG _ EmptyMap = EmptyMap
mapG f (SingletonMap k v) = SingletonMap k (f v)
-mapG f (MultiMap m) = MultiMap (mapTM f m)
+mapG f (MultiMap m) = MultiMap (fmap f m)
{-# INLINEABLE fdG #-}
fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -117,6 +117,11 @@ data StgArgMap a = SAM
, sam_lit :: LiteralMap a
}
+-- TODO(22292): derive
+instance Functor StgArgMap where
+ fmap f SAM { sam_var = varm, sam_lit = litm } = SAM
+ { sam_var = fmap f varm, sam_lit = fmap f litm }
+
instance TrieMap StgArgMap where
type Key StgArgMap = StgArg
emptyTM = SAM { sam_var = emptyTM
@@ -126,13 +131,16 @@ instance TrieMap StgArgMap where
alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
- mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
- SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
filterTM f (SAM {sam_var = varm, sam_lit = litm}) =
SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }
newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
+-- TODO(22292): derive
+instance Functor ConAppMap where
+ fmap f = CAM . fmap (fmap f) . un_cam
+ {-# INLINE fmap #-}
+
instance TrieMap ConAppMap where
type Key ConAppMap = (DataCon, [StgArg])
emptyTM = CAM emptyTM
@@ -140,8 +148,7 @@ instance TrieMap ConAppMap where
alterTM (dataCon, args) f m =
m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
foldTM k = un_cam >.> foldTM (foldTM k)
- mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM
- filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM
+ filterTM f = un_cam >.> fmap (filterTM f) >.> CAM
-----------------
-- The CSE Env --
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ecd1ac03d9cd2eea8e2b50233a08fd3d9cca7c7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ecd1ac03d9cd2eea8e2b50233a08fd3d9cca7c7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221018/0680e9ac/attachment-0001.html>
More information about the ghc-commits
mailing list