[commit: ghc] ghc-new-flavor: Mostly commentary to follow up after discussions with SPJ on several open tickets. (6785820)
dimitris at microsoft.com
dimitris at microsoft.com
Fri Mar 30 19:23:12 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-new-flavor
http://hackage.haskell.org/trac/ghc/changeset/6785820ea99626822a58561e6e157a4fb9aeb039
>---------------------------------------------------------------
commit 6785820ea99626822a58561e6e157a4fb9aeb039
Author: Dimitrios Vytiniotis <dimitris at microsoft.com>
Date: Fri Mar 30 19:22:36 2012 +0200
Mostly commentary to follow up after discussions with SPJ on several open tickets.
>---------------------------------------------------------------
compiler/typecheck/TcCanonical.lhs | 6 ++++++
compiler/typecheck/TcInteract.lhs | 24 ++++++++++++++++++++----
compiler/typecheck/TcSMonad.lhs | 22 +++++++++++++++++++---
compiler/typecheck/TcSimplify.lhs | 14 ++++++++++++++
4 files changed, 59 insertions(+), 7 deletions(-)
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 032666e..8302e35 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -736,6 +736,12 @@ flatten d ctxt ty@(ForAllTy {})
; (rho', co) <- flatten d ctxt rho
; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
+-- DV: Simon and I have a better plan here related to #T5934 and that plan is to
+-- first normalize completely the rho type with respect to the top-level instances,
+-- and then flatten out only the family equations that do not mention the quantified
+-- variable. Keep the rest as they are. There is no worry that we don't normalize with
+-- the givens because the givens can't possibly mention the quantified variable anyway!
+
where under_families tvs rho
= go (mkVarSet tvs) rho
where go _bound (TyVarTy _tv) = False
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 3e08a20..f2e193f 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -335,8 +335,23 @@ rewriteInertEqsFromInertEq (subst_tv, subst_co, subst_fl) ieqs
= if fl `canRewrite` subst_fl then
-- If also the inert can rewrite the subst it's totally safe
-- to rewrite on the spot
- do { ct' <- rewrite_on_the_spot ct
- ; return $ Just ct' }
+ do {
+
+{- DV: I thought this might work but not because you don't have the full knowledge of the
+ implications (just the worklist). And it's a bit tedious. SPJ and I discussed about breaking
+ the 'idempotent substitution' invariant to be a little more lazy. -}
+
+ -- DV: Very experimental!
+ -- If it's a given equality and its LHS does not appear in the worklist
+ -- there is no point in rewriting him. In fact there is not point in keeping him,
+ -- at all, is there?
+ worklist_tvs <- getTcSWorkListTvs
+ ; if isGiven (cc_flavor ct) && not (tyVarsOfCt ct `elemVarSet` worklist_tvs) then
+ return Nothing
+ else do {
+ ct' <- rewrite_on_the_spot ct
+ ; return $ Just ct' }
+ }
else -- We have to throw inert back to worklist for occurs checks
do { updWorkListTcS (extendWorkListEq ct)
; return Nothing }
@@ -388,10 +403,11 @@ kick_out_rewritable ct is@(IS { inert_cans =
, inert_frozen = frozen })
= ((kicked_out,eqmap), remaining)
where
+ rest_out = fro_out `andCts` dicts_out
+ `andCts` ips_out `andCts` irs_out
kicked_out = WorkList { wl_eqs = []
, wl_funeqs = bagToList feqs_out
- , wl_rest = bagToList (fro_out `andCts` dicts_out
- `andCts` ips_out `andCts` irs_out) }
+ , wl_rest = bagToList rest_out }
remaining = is { inert_cans = IC { inert_eqs = emptyVarEnv
, inert_eq_tvs = inscope
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 0053465..4291fd8 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -17,6 +17,7 @@ module TcSMonad (
appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
+ getTcSWorkListTvs,
Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts,
emitFrozenError,
@@ -196,7 +197,10 @@ better rewrite it as much as possible before reporting it as an error to the use
\begin{code}
-- See Note [WorkList]
-data WorkList = WorkList { wl_eqs :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] }
+data WorkList = WorkList { wl_eqs :: [Ct]
+ , wl_funeqs :: [Ct]
+ , wl_rest :: [Ct]
+ }
unionWorkList :: WorkList -> WorkList -> WorkList
@@ -205,6 +209,7 @@ unionWorkList new_wl orig_wl =
, wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl
, wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
+
extendWorkListEq :: Ct -> WorkList -> WorkList
-- Extension by equality
extendWorkListEq ct wl
@@ -215,7 +220,8 @@ extendWorkListEq ct wl
extendWorkListNonEq :: Ct -> WorkList -> WorkList
-- Extension by non equality
-extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
+extendWorkListNonEq ct wl
+ = wl { wl_rest = ct : wl_rest wl }
extendWorkListCt :: Ct -> WorkList -> WorkList
-- Agnostic
@@ -236,7 +242,7 @@ isEmptyWorkList wl
= null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl)
emptyWorkList :: WorkList
-emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = []}
+emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = [] }
workListFromEq :: Ct -> WorkList
workListFromEq ct = extendWorkListEq ct emptyWorkList
@@ -964,6 +970,16 @@ getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
getTcSWorkList :: TcS WorkList
getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef)
+
+getTcSWorkListTvs :: TcS TyVarSet
+-- Return the variables of the worklist
+getTcSWorkListTvs
+ = do { wl <- getTcSWorkList
+ ; return $
+ cts_tvs (wl_eqs wl) `unionVarSet` cts_tvs (wl_funeqs wl) `unionVarSet` cts_tvs (wl_rest wl) }
+ where cts_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet
+
+
updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
updWorkListTcS f
= updWorkListTcS_return (\w -> ((),f w))
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 96790c6..2043af2 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -597,6 +597,15 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- We allow ourselves to unify environment
-- variables; hence *no untouchables*
+-- DV: SPJ and I discussed a new plan here:
+-- Step 1: Simplify everything in the same bag
+-- Step 2: zonk away the lhs constraints and get only the non-trivial ones
+-- Step 3: do the implications with these constraints
+-- This will have the advantage that (i) we no longer need simplEqsOnly flag
+-- and (ii) will fix problems appearing from touchable unification variables
+-- in the givens, manifested by #5853
+-- TODO ...
+
; (lhs_results, lhs_binds)
<- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $
solveWanteds zonked_lhs
@@ -945,6 +954,9 @@ floatEqualities skols can_given wantders
-- Note [Float Equalities out of Implications]
| otherwise = partitionBag is_floatable wantders
+-- TODO: Maybe we should try out /not/ floating constraints that contain touchables only,
+-- since they are inert and not going to interact with anything more in a more global scope.
+
where skol_set = mkVarSet skols
is_floatable :: Ct -> Bool
is_floatable ct
@@ -1090,6 +1102,8 @@ Note [Float Equalities out of Implications]
We want to float equalities out of vanilla existentials, but *not* out
of GADT pattern matches.
+---> TODO Expand in accordance to our discussion
+
\begin{code}
More information about the Cvs-ghc
mailing list