[Git][ghc/ghc][wip/romes/splitting-id] Var like
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Sun May 28 10:39:37 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/splitting-id at Glasgow Haskell Compiler / GHC
Commits:
a0c117f6 by Rodrigo Mesquita at 2023-05-28T11:39:31+01:00
Var like
- - - - -
4 changed files:
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Types/Var/Set.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -283,6 +283,11 @@ runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet
{-# INLINE runTyCoVars #-}
runTyCoVars f = appEndo f emptyVarSet
+runCoVars :: Endo CoVarSet -> CoVarSet
+{-# INLINE runCoVars #-}
+runCoVars f = appEndo f emptyVarSet
+
+
{- *********************************************************************
* *
Deep free variables
@@ -430,10 +435,10 @@ coVarsOfTypes :: [Type] -> CoVarSet
coVarsOfCo :: Coercion -> CoVarSet
coVarsOfCos :: [Coercion] -> CoVarSet
-coVarsOfType ty = rightsVarSet $ runTyCoVars (mapVarSet Right <$> deep_cv_ty ty)
-coVarsOfTypes tys = rightsVarSet $ runTyCoVars (mapVarSet Right <$> deep_cv_tys tys)
-coVarsOfCo co = rightsVarSet $ runTyCoVars (mapVarSet Right <$> deep_cv_co co)
-coVarsOfCos cos = rightsVarSet $ runTyCoVars (mapVarSet Right <$> deep_cv_cos cos)
+coVarsOfType ty = runCoVars (deep_cv_ty ty)
+coVarsOfTypes tys = runCoVars (deep_cv_tys tys)
+coVarsOfCo co = runCoVars (deep_cv_co co)
+coVarsOfCos cos = runCoVars (deep_cv_cos cos)
deep_cv_ty :: Type -> Endo CoVarSet
deep_cv_tys :: [Type] -> Endo CoVarSet
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -6,7 +6,7 @@
-}
{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,
- PatternSynonyms, BangPatterns, RecordWildCards, LambdaCase, NamedFieldPuns #-}
+ PatternSynonyms, BangPatterns, LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-- |
@@ -153,10 +153,10 @@ type NcId = Id -- A term-level (value) variable that is
-- predicate: isNonCoVarId
-- | Type Variable
-type TypeVar = Var -- Definitely a type variable
+type TypeVar = TyVar -- Definitely a type variable
-- | Kind Variable
-type KindVar = Var -- Definitely a kind variable
+type KindVar = TyVar -- Definitely a kind variable
-- See Note [Kind and type variables]
-- See Note [Evidence: EvIds and CoVars]
@@ -277,6 +277,48 @@ data Id
id_details :: IdDetails, -- Stable, doesn't change
id_info :: IdInfo } -- Unstable, updated by simplifier
+class VarLike var where
+ varName :: var -> Name
+ realUnique :: var -> Int
+ varType :: var -> Type
+
+instance VarLike Var where
+ varName = \case
+ TV TyVar{varNameTyVar=name} -> name
+ TTV TcTyVar{varNameTcTyVar=name} -> name
+ I Id{varNameId=name} -> name
+ varType = \case
+ TV TyVar{varTypeTyVar=ty} -> ty
+ TTV TcTyVar{varTypeTcTyVar=ty} -> ty
+ I Id{varTypeId=ty} -> ty
+ realUnique = \case
+ TV TyVar{realUniqueTyVar=uq} -> uq
+ TTV TcTyVar{realUniqueTcTyVar=uq} -> uq
+ I Id{realUniqueId=uq} -> uq
+
+instance VarLike Id where
+ varName = varNameId
+ varType = varTypeId
+ realUnique = realUniqueId
+
+instance VarLike TyVar where
+ varName = varNameTyVar
+ varType = varTypeTyVar
+ realUnique = realUniqueTyVar
+
+instance VarLike TcTyVar where
+ varName = varNameTcTyVar
+ varType = varTypeTcTyVar
+ realUnique = realUniqueTcTyVar
+
+instance VarLike TyCoVar where
+ varName (Left v) = varNameTyVar v
+ varName (Right v) = varNameId v
+ varType (Left v) = varTypeTyVar v
+ varType (Right v) = varTypeId v
+ realUnique (Left v) = realUniqueTyVar v
+ realUnique (Right v) = realUniqueId v
+
varTypeTyCoVar :: TyCoVar -> Type
varTypeTyCoVar = \case
Left v -> varTypeTyVar v
@@ -287,21 +329,6 @@ tyCoVarToVar = \case
Left x -> TV x
Right x -> I x
-varName :: Var -> Name
-varName = \case
- TV TyVar{varNameTyVar} -> varNameTyVar
- TTV TcTyVar{varNameTcTyVar} -> varNameTcTyVar
- I Id{varNameId} -> varNameId
-varType :: Var -> Type
-varType = \case
- TV TyVar{varTypeTyVar} -> varTypeTyVar
- TTV TcTyVar{varTypeTcTyVar} -> varTypeTcTyVar
- I Id{varTypeId} -> varTypeId
-realUnique :: Var -> Int
-realUnique = \case
- TV TyVar{realUniqueTyVar} -> realUniqueTyVar
- TTV TcTyVar{realUniqueTcTyVar} -> realUniqueTcTyVar
- I Id{realUniqueId} -> realUniqueId
-- | Identifier Scope
data IdScope -- See Note [GlobalId/LocalId]
@@ -488,7 +515,7 @@ instance Data TyVar where
instance HasOccName Var where
occName = nameOccName . varName
-varUnique :: Var -> Unique
+varUnique :: VarLike var => var -> Unique
varUnique var = mkUniqueGrimily (realUnique var)
varMultMaybe :: Var -> Maybe Mult
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -506,7 +506,7 @@ mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a
zipVarEnv :: [Var] -> [a] -> VarEnv a
unitVarEnv :: Var -> a -> VarEnv a
alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a
-extendVarEnv :: UniqFM var a -> var -> a -> UniqFM var a
+extendVarEnv :: Uniquable var => UniqFM var a -> var -> a -> UniqFM var a
{-# SPECIALISE extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a #-}
extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
@@ -528,7 +528,7 @@ mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
isEmptyVarEnv :: VarEnv a -> Bool
-lookupVarEnv :: UniqFM var a -> var -> Maybe a
+lookupVarEnv :: Uniquable var => UniqFM var a -> var -> Maybe a
{-# SPECIALISE lookupVarEnv :: VarEnv a -> Var -> Maybe a #-}
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a
=====================================
compiler/GHC/Types/Var/Set.hs
=====================================
@@ -43,8 +43,7 @@ module GHC.Types.Var.Set (
transCloDVarSet,
sizeDVarSet, seqDVarSet,
partitionDVarSet,
- dVarSetToVarSet,
- leftsVarSet, rightsVarSet
+ dVarSetToVarSet
) where
import Data.Either
@@ -125,9 +124,8 @@ extendVarSet = addOneToUniqSet
extendVarSetList= addListToUniqSet
intersectVarSet = intersectUniqSets
-intersectsVarSet:: UniqSet a -> UniqSet a -> Bool -- True if non-empty intersection
-{-# SPECIALISE intersectsVarSet :: VarSet -> VarSet -> Bool #-}
-disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection
+intersectsVarSet:: UniqSet a -> UniqSet a -> Bool -- True if non-empty intersection
+disjointVarSet :: UniqSet a -> UniqSet a -> Bool -- True if empty intersection
subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second
-- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty;
-- ditto disjointVarSet, subVarSet
@@ -373,9 +371,3 @@ transCloDVarSet fn seeds
where
new_vs = fn candidates `minusDVarSet` acc
-leftsVarSet :: (Uniquable a, Uniquable b) => UniqSet (Either a b) -> UniqSet a
-leftsVarSet = mapVarSet (\case Left x -> x; Right _ -> panic "leftsVarSet") . filterVarSet isLeft
-
-rightsVarSet :: (Uniquable a, Uniquable b) => UniqSet (Either a b) -> UniqSet b
-rightsVarSet = mapVarSet (\case Right x -> x; Left _ -> panic "rightsVarSet") . filterVarSet isRight
-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0c117f6a0547cbe685ced99b26be2003e07070b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0c117f6a0547cbe685ced99b26be2003e07070b
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/20230528/dd6a6204/attachment-0001.html>
More information about the ghc-commits
mailing list