[commit: ghc] wip/tc-plugins: Pass all potentially interesting constraints to plugin (changes API). (c55777e)
git at git.haskell.org
git at git.haskell.org
Sat Oct 18 21:51:25 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/tc-plugins
Link : http://ghc.haskell.org/trac/ghc/changeset/c55777ed8725e33041cbbabdcebc5227f19ac771/ghc
>---------------------------------------------------------------
commit c55777ed8725e33041cbbabdcebc5227f19ac771
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date: Sat Oct 18 14:35:16 2014 -0700
Pass all potentially interesting constraints to plugin (changes API).
We now pass 3 lists of constraints to the plugin: givens, derived,
and wanteds. Furthermore, the list of constraints will now contain
dictionaries, so one could write plugins for the class system.
In addition, we also change the return type for plugins: now plugins
don't need to return "all other constraints". In the case of contradiction,
plugins just return the conflicting constraints, and in the case when
things were OK, plugins return the solved constraints + new work.
This is not only simpler, but might makes things more efficient as we
don't rebuild the entire inerts set all the time, instead we just delete
the solved/contradicting constraints.
>---------------------------------------------------------------
c55777ed8725e33041cbbabdcebc5227f19ac771
compiler/typecheck/TcInteract.lhs | 59 +++++++++++++++++++++++----------------
compiler/typecheck/TcRnTypes.lhs | 22 ++++++++++-----
compiler/typecheck/TcSMonad.lhs | 12 ++++++++
3 files changed, 62 insertions(+), 31 deletions(-)
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 8974ac7..91a9fb0 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -40,7 +40,7 @@ import Bag
import Control.Monad ( foldM )
import Data.Maybe ( catMaybes )
-import Data.List( partition )
+import Data.List( partition, foldl' )
import VarEnv
@@ -143,38 +143,49 @@ runTcPlugin :: TcPluginSolver -> TcS ()
runTcPlugin solver =
do iSet <- getTcSInerts
let iCans = inert_cans iSet
- iEqs = concat (varEnvElts (inert_eqs iCans))
- iFunEqs = funEqsToList (inert_funeqs iCans)
- allCts = iEqs ++ iFunEqs
+ allCts = foldDicts (:) (inert_dicts iCans)
+ $ foldFunEqs (:) (inert_funeqs iCans)
+ $ concat (varEnvElts (inert_eqs iCans))
+
(derived,other) = partition isDerivedCt allCts
(wanted,given) = partition isWantedCt other
- -- We use this to remove some constraints.
- -- 'survived' should be the sub-set of constraints that
- -- remains inert.
- restoreICans survived =
- do let iCans1 = iCans { inert_eqs = emptyVarEnv
- , inert_funeqs = emptyFunEqs }
- iCans2 = foldl addInertCan iCans1 derived
- iCans3 = foldl addInertCan iCans2 survived
- setInertCans iCans3
-
- result <- runTcPluginTcS (solver given wanted)
+ result <- runTcPluginTcS (solver given derived wanted)
case result of
- TcPluginContradiction bad_cts ok_cts ->
- do restoreICans ok_cts
+ TcPluginContradiction bad_cts ->
+ do setInertCans (removeInertCts iCans bad_cts)
mapM_ emitInsoluble bad_cts
- -- other_cts should include both givens and wanteds.
- TcPluginOk solved_cts other_cts new_cts ->
- do case solved_cts of
- [] -> return () -- Fast common case
- _ -> do restoreICans other_cts
- let setEv (ev,ct) = setEvBind (ctev_evar (cc_ev ct)) ev
- mapM_ setEv solved_cts
+ TcPluginOk solved_cts new_cts ->
+ do setInertCans (removeInertCts iCans (map snd solved_cts))
+ let setEv (ev,ct) = setEvBind (ctev_evar (cc_ev ct)) ev
+ mapM_ setEv solved_cts
updWorkListTcS (extendWorkListCts new_cts)
+ where
+ removeInertCts :: InertCans -> [Ct] -> InertCans
+ removeInertCts = foldl' removeInertCt
+
+ -- Remove the constraint from the inert set. We use this either when:
+ -- * a wanted constraint was solved, or
+ -- * some constraint was marked as insoluable, and so it will be
+ -- put right back into InertSet, but in the insoluable section.
+ removeInertCt :: InertCans -> Ct -> InertCans
+ removeInertCt is ct =
+ case ct of
+
+ CDictCan { cc_class = cl, cc_tyargs = tys } ->
+ is { inert_dicts = delDict (inert_dicts is) cl tys }
+
+ CFunEqCan { cc_fun = tf, cc_tyargs = tys } ->
+ is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
+
+ CTyEqCan { cc_tyvar = x, cc_rhs = ty } ->
+ is { inert_eqs = delTyEq (inert_eqs is) x ty }
+ CIrredEvCan {} -> panic "runTcPlugin/removeInert: CIrredEvCan"
+ CNonCanonical {} -> panic "runTcPlugin/removeInert: CNonCanonical"
+ CHoleCan {} -> panic "runTcPlugin/removeInert: CHoleCan"
type WorkItem = Ct
type SimplifierStage = WorkItem -> TcS StopOrContinue
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index ed54559..9054f99 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1922,7 +1922,10 @@ Constraint Solver Plugins
\begin{code}
-type TcPluginSolver = [Ct] -> [Ct] -> TcPluginM TcPluginResult
+type TcPluginSolver = [Ct] -- given
+ -> [Ct] -- derived
+ -> [Ct] -- wanted
+ -> TcPluginM TcPluginResult
newtype TcPluginM a = TcPluginM (TcM a)
@@ -1963,12 +1966,17 @@ data TcPlugin = forall s. TcPlugin
}
data TcPluginResult
- = TcPluginContradiction {- inconsistent -} [Ct]
- {- all others -} [Ct]
-
- | TcPluginOk {- solved -} [(EvTerm,Ct)]
- {- all others -} [Ct]
- {- new work -} [Ct]
+ = TcPluginContradiction [Ct]
+ -- ^ The plugin found a contradiction.
+ -- The returned constraints are removed from the inert set,
+ -- and recorded as insoluable.
+
+ | TcPluginOk [(EvTerm,Ct)] [Ct]
+ -- ^ The first field is for constraints that were solved.
+ -- These are removed from the inert set,
+ -- and the evidence for them is recorded.
+ -- The second field contains new work, that should be processed by
+ -- the constraint solver.
\end{code}
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 3c339fb..5c3b32f 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -77,11 +77,15 @@ module TcSMonad (
lookupSolvedDict, extendFlatCache,
findDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
+ foldDicts,
emptyFunEqs, funEqsToList,
findFunEq, findTyEqs,
findFunEqsByTyCon, findFunEqs, partitionFunEqs,
sizeFunEqMap,
+ foldFunEqs,
+ delFunEq,
+ delTyEq,
instDFunType, -- Instantiation
newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
@@ -888,6 +892,11 @@ type TyEqMap a = TyVarEnv a
findTyEqs :: TyEqMap EqualCtList -> TyVar -> EqualCtList
findTyEqs m tv = lookupVarEnv m tv `orElse` []
+
+delTyEq :: TyEqMap EqualCtList -> TcTyVar -> TcType -> TyEqMap EqualCtList
+delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv
+ where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
+ isThisOne _ = False
\end{code}
@@ -1041,6 +1050,9 @@ partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs)
k ct (yeses, noes)
| f ct = (yeses `snocBag` ct, noes)
| otherwise = (yeses, insertFunEqCt noes ct)
+
+delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
+delFunEq m tc tys = delTcApp m (getUnique tc) tys
\end{code}
More information about the ghc-commits
mailing list