[commit: ghc] wip/gadtpm: let's move overloaded literals towards the oracle (7bddf4d)
git at git.haskell.org
git at git.haskell.org
Wed Oct 21 15:17:43 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/gadtpm
Link : http://ghc.haskell.org/trac/ghc/changeset/7bddf4db39764bffbc082b37c8eea47fe897ed49/ghc
>---------------------------------------------------------------
commit 7bddf4db39764bffbc082b37c8eea47fe897ed49
Author: George Karachalias <george.karachalias at gmail.com>
Date: Wed Oct 21 17:20:13 2015 +0200
let's move overloaded literals towards the oracle
>---------------------------------------------------------------
7bddf4db39764bffbc082b37c8eea47fe897ed49
compiler/deSugar/Check.hs | 21 ++++++++++++---------
compiler/deSugar/PmExpr.hs | 17 +++++++++++------
compiler/deSugar/TmOracle.hs | 26 +++++++++++++++++---------
3 files changed, 40 insertions(+), 24 deletions(-)
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index f678cc5..f4db974 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -1006,9 +1006,10 @@ cMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
(covered us gvsa (args1 ++ ps) (foldr mkCons vsa args2))
-- CLitLit
-cMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
- | eqPmLit l1 l2 = VA va `mkCons` covered us gvsa ps vsa
- | otherwise = Empty
+cMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
+ Just True -> VA va `mkCons` covered us gvsa ps vsa -- we know: match
+ Just False -> Empty -- we know: no match
+ Nothing -> VA va `mkCons` covered us gvsa ps vsa -- Don't even try putting a constraint in the bag, it won't reduce.
-- CConVar
cMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
@@ -1058,9 +1059,10 @@ uMatcher us gvsa ( p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
(uncovered us gvsa (args1 ++ ps) (foldr mkCons vsa args2))
-- ULitLit
-uMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
- | eqPmLit l1 l2 = VA va `mkCons` uncovered us gvsa ps vsa
- | otherwise = VA va `mkCons` vsa
+uMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
+ Just True -> VA va `mkCons` uncovered us gvsa ps vsa -- we know: match
+ Just False -> VA va `mkCons` vsa -- we know: no match
+ Nothing -> VA va `mkCons` vsa -- no clue: assume the worst?
-- UConVar
uMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
@@ -1122,9 +1124,10 @@ dMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
(divergent us gvsa (args1 ++ ps) (foldr mkCons vsa args2))
-- DLitLit
-dMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
- | eqPmLit l1 l2 = VA va `mkCons` divergent us gvsa ps vsa
- | otherwise = Empty
+dMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
+ Just True -> VA va `mkCons` divergent us gvsa ps vsa -- we know: match
+ Just False -> Empty -- we know: no match
+ Nothing -> VA va `mkCons` divergent us gvsa ps vsa -- Don't even try putting a constraint in the bag, it won't reduce.
-- DConVar
dMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index 8e38522..6adf08a 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -76,16 +76,21 @@ data PmExpr = PmExprVar Id
data PmLit = PmSLit HsLit -- simple
| PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
--- do not make it an instance of Eq, we just need it for printing
-eqPmLit :: PmLit -> PmLit -> Bool
-eqPmLit (PmSLit l1) (PmSLit l2 ) = l1 == l2 -- check the instances too for lits and olits
-eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2
-eqPmLit _ _ = False
+-- do not make it an instance of Eq
+eqPmLit :: PmLit -> PmLit -> Maybe Bool
+eqPmLit (PmSLit l1) (PmSLit l2 ) = Just (l1 == l2) -- check the instances too for lits and olits
+eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = if res then Just True else Nothing
+ where res = b1 == b2 && l1 == l2
+eqPmLit _ _ = Nothing
nubPmLit :: [PmLit] -> [PmLit]
nubPmLit [] = []
nubPmLit [x] = [x]
-nubPmLit (x:xs) = x : nubPmLit (filter (not . eqPmLit x) xs)
+nubPmLit (x:xs) = x : nubPmLit (filter (neqPmLit x) xs)
+ where neqPmLit l1 l2 = case eqPmLit l1 l2 of
+ Just True -> False
+ Just False -> True
+ Nothing -> True
-- ----------------------------------------------------------------------------
-- | Term equalities
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 9f18aa9..8c064c2 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -89,9 +89,13 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
-- Look at the catch-all.. (PmExprLit _, PmExprEq _ _) -> Just (standby, (eq:unhandled, env))
-- Look at the catch-all.. (PmExprEq _ _, PmExprLit _) -> Just (standby, (eq:unhandled, env))
- (PmExprLit l1, PmExprLit l2)
- | eqPmLit l1 l2 -> Just solver_state
- | otherwise -> Nothing -- THIS IS NOT EXACTLY TRUE. FOR OVERLOADED WE DO NOT KNOW MUCH
+ (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+ Just True -> Just solver_state -- we are sure: equal
+ Just False -> Nothing -- we are sure: not equal
+ -- Maybe just drop. We use this boolean to check also whether something is forced and I know
+ -- that nothing is if both are literals. Hence, just assume true and give (Just solver_state)?
+ Nothing -> Just (standby, (True, env)) -- no clue (and won't get one)!
+
(PmExprCon c1 ts1, PmExprCon c2 ts2)
| c1 == c2 -> foldlM solveComplexEq solver_state (zip ts1 ts2)
| otherwise -> Nothing
@@ -143,12 +147,16 @@ simplifyEqExpr e1 e2 = case (e1, e2) of
| x == y -> (truePmExpr, True)
-- Literals
- (PmExprLit l1@(PmSLit {}), PmExprLit l2@(PmSLit {}))
- | eqPmLit l1 l2 -> (truePmExpr, True)
- | otherwise -> (falsePmExpr, True)
- (PmExprLit l1@(PmOLit {}), PmExprLit l2@(PmOLit {}))
- | eqPmLit l1 l2 -> (truePmExpr, True)
- | otherwise -> (falsePmExpr, True)
+ (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+ Just True -> (truePmExpr, True)
+ Just False -> (falsePmExpr, True)
+ Nothing -> (original, False)
+ -- (PmExprLit l1@(PmSLit {}), PmExprLit l2@(PmSLit {}))
+ -- | eqPmLit l1 l2 -> (truePmExpr, True)
+ -- | otherwise -> (falsePmExpr, True)
+ -- (PmExprLit l1@(PmOLit {}), PmExprLit l2@(PmOLit {}))
+ -- | eqPmLit l1 l2 -> (truePmExpr, True)
+ -- | otherwise -> (falsePmExpr, True)
-- simplify bottom-up
(PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
More information about the ghc-commits
mailing list