[Git][ghc/ghc][wip/romes/eqsat-pmc] WIP
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Jun 15 08:46:49 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/eqsat-pmc at Glasgow Haskell Compiler / GHC
Commits:
55c41884 by Rodrigo Mesquita at 2023-06-15T09:46:42+01:00
WIP
- - - - -
3 changed files:
- compiler/GHC/Core/Functor.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Map/Type.hs
Changes:
=====================================
compiler/GHC/Core/Functor.hs
=====================================
@@ -1,19 +1,11 @@
{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
module GHC.Core.Functor where
-import GHC.Generics
import GHC.Prelude
-import Data.Bool
-import Data.Eq
-import Data.Ord
-import Data.Functor
-import Data.Functor.Classes
-import Data.Foldable
-import Data.Traversable
-
import GHC.Core
import GHC.Core.TyCo.Rep
import GHC.Core.Map.Type
@@ -25,6 +17,9 @@ import Unsafe.Coerce (unsafeCoerce)
import Data.Equality.Utils (Fix(..))
+import GHC.Utils.Misc (all2, equalLength)
+import Data.Functor.Identity (Identity(..))
+
-- Important to note the binders are also represented by $a$
-- This is because in the e-graph we will represent binders with the
-- equivalence class id of things equivalent to it.
@@ -36,12 +31,12 @@ import Data.Equality.Utils (Fix(..))
data AltF b a
= AltF AltCon [b] a
- deriving (Functor, Foldable, Traversable)
+ deriving (Functor, Foldable, Traversable, Eq, Ord)
data BindF b a
= NonRecF b a
| RecF [(b, a)]
- deriving (Functor, Foldable, Traversable)
+ deriving (Functor, Foldable, Traversable, Eq, Ord)
data ExprF b a
= VarF Id
@@ -60,51 +55,66 @@ data ExprF b a
type CoreExprF
= ExprF CoreBndr
--- instance (Eq a, Eq b) => Eq (AltF b a) where
--- (==) (AltF c as a) (AltF c' as' a') = c == c' && as == as' && a == a'
-
--- instance Eq b => Eq1 (AltF b) where
--- liftEq eq (AltF c as a) (AltF c' as' a') = c == c' && as == as' && eq a a'
-
--- instance (Eq a, Eq b) => Eq (BindF b a) where
--- (==) (RecF as) (RecF as') = as == as'
--- (==) (NonRecF a b) (NonRecF a' b') = a == a' && b == b'
--- (==) _ _ = False
-
--- instance Eq b => Eq1 (BindF b) where
--- liftEq eq (RecF as) (RecF as') = liftEq (\(x,y) (x',y') -> x == x' && eq y y') as as'
--- liftEq eq (NonRecF a b) (NonRecF a' b') = a == a' && eq b b'
--- liftEq _ _ _ = False
-
--- instance (Eq a, Eq b) => Eq (ExprF b a) where
--- (==) (VarF a) (VarF b) = a == b
--- (==) (LitF a) (LitF b) = a == b
--- (==) (AppF a a') (AppF b b') = a == b && a' == b'
--- (==) (LamF a a') (LamF b b') = a == b && a' == b'
--- (==) (LetF a a') (LetF b b') = a == b && a' == b'
- -- (==) (CaseF a a' t as) (CaseF b b' v bs) = a == b && a' == b'
- -- && eqDeBruijnType t v
- -- && as == bs
- -- (==) (CastF a c) (CastF b c') = a == b && eqDeBruijnType (coercionType c) (coercionType c')
- -- ROMES:TODO: THE REST OF IT!!
- -- (==) _ _ = False
-
instance Eq a => Eq (DeBruijnF CoreExprF a) where
- (==) _ _ = error "TODO"
-
-instance Eq1 (DeBruijnF CoreExprF) where
- liftEq eq = error "TODO"
+ (==) = eqDeBruijnExprF
+
+-- ROMES:TODO: This instance is plain wrong. This DeBruijn scheme won't
+-- particularly work for our situation, we'll likely have to have ints instead
+-- of Id binders. Now, ignoring DeBruijn indices, we'll simply get this compile
+-- to get a rougher estimate of performance?
+eqDeBruijnExprF :: forall a. Eq a => DeBruijnF CoreExprF a -> DeBruijnF CoreExprF a -> Bool
+eqDeBruijnExprF (DeBruijnF (D env1 e1)) (DeBruijnF (D env2 e2)) = go e1 e2 where
+ go :: CoreExprF a -> CoreExprF a -> Bool
+ go (VarF v1) (VarF v2) = eqDeBruijnVar (D env1 v1) (D env2 v2)
+ go (LitF lit1) (LitF lit2) = lit1 == lit2
+ go (TypeF t1) (TypeF t2) = eqDeBruijnType (D env1 t1) (D env2 t2)
+ -- See Note [Alpha-equality for Coercion arguments]
+ go (CoercionF {}) (CoercionF {}) = True
+ go (CastF e1 co1) (CastF e2 co2) = D env1 co1 == D env2 co2 && e1 == e2
+ go (AppF f1 a1) (AppF f2 a2) = f1 == f2 && a1 == a2
+ go (TickF n1 e1) (TickF n2 e2)
+ = eqDeBruijnTickish (D env1 n1) (D env2 n2)
+ && e1 == e2
+
+ go (LamF b1 e1) (LamF b2 e2)
+ = eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))
+ && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)
+ && e1 == e2
+
+ go (LetF (NonRecF v1 r1) e1) (LetF (NonRecF v2 r2) e2)
+ = r1 == r2 -- See Note [Alpha-equality for let-bindings]
+ && e1 == e2
+
+ go (LetF (RecF ps1) e1) (LetF (RecF ps2) e2)
+ = equalLength ps1 ps2
+ -- See Note [Alpha-equality for let-bindings]
+ && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1))
+ (D env2 (varType b2)))
+ bs1 bs2
+ && rs1 == rs2
+ && e1 == e2
+ where
+ (bs1,rs1) = unzip ps1
+ (bs2,rs2) = unzip ps2
+ env1' = extendCMEs env1 bs1
+ env2' = extendCMEs env2 bs2
+
+ go (CaseF e1 b1 t1 a1) (CaseF e2 b2 t2 a2)
+ | null a1 -- See Note [Empty case alternatives]
+ = null a2 && e1 == e2 && D env1 t1 == D env2 t2
+ | otherwise
+ = e1 == e2 && a1 == a2
+
+ go _ _ = False
+
+-- With Ints as binders we can have almost trivial eq instances
instance Ord a => Ord (DeBruijnF CoreExprF a) where
- compare _ _ = error "TODO"
-
-instance Ord1 (DeBruijnF CoreExprF) where
- liftCompare cmp _ _ = error "TODO"
-
-instance Functor (DeBruijnF CoreExprF)
-instance Foldable (DeBruijnF CoreExprF)
-instance Traversable (DeBruijnF CoreExprF)
+ compare a b = if a == b then EQ else LT
+deriving instance Functor (DeBruijnF CoreExprF)
+deriving instance Foldable (DeBruijnF CoreExprF)
+deriving instance Traversable (DeBruijnF CoreExprF)
-- | 'unsafeCoerce' mostly because I'm too lazy to write the boilerplate.
fromCoreExpr :: CoreExpr -> Fix CoreExprF
=====================================
compiler/GHC/Core/Map/Expr.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Core.Map.Expr (
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
-- * Alpha equality
eqDeBruijnExpr, eqCoreExpr,
+ -- ** Exports for CoreExprF instances
+ eqDeBruijnTickish, eqDeBruijnVar,
-- * 'TrieMap' class reexports
TrieMap(..), insertTM, deleteTM,
lkDFreeVar, xtDFreeVar,
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -35,7 +35,6 @@ module GHC.Core.Map.Type (
-- between GHC.Core.Unify (which depends on this module) and GHC.Core
import GHC.Prelude
-import Data.Functor.Classes
import GHC.Core.Type
import GHC.Core.Coercion
@@ -514,6 +513,7 @@ lookupCME (CME { cme_env = env }) v = lookupVarEnv env v
-- export the constructor. Make a helper function if you find yourself
-- needing it.
data DeBruijn a = D CmEnv a
+ deriving (Functor,Foldable,Traversable) -- romes:TODO: For internal use only!
newtype DeBruijnF f a = DeBruijnF (DeBruijn (f a))
@@ -524,7 +524,7 @@ deBruijnize :: a -> DeBruijn a
deBruijnize = D emptyCME
-- | Like 'deBruijnize' but synthesizes a @DeBruijnF f a@ from an @f a@
-deBruijnizeF :: f a -> DeBruijnF f a
+deBruijnizeF :: Functor f => f a -> DeBruijnF f a
deBruijnizeF = DeBruijnF . deBruijnize
instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55c41884c1701b787b8d77a84812388259f1e604
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/55c41884c1701b787b8d77a84812388259f1e604
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/20230615/85811f61/attachment-0001.html>
More information about the ghc-commits
mailing list