Commit f3183d9a authored by dimitris's avatar dimitris
Browse files

This patch includes:

0) Typo in panic message.
1) prioritization of equalities over family equalities in the worklists.
2) rewriting of inert substitutions and solveds on-the-spot instead of
   kicking them out in the inerts. This required a monadic map over
   substitutions hence the modifications in UniqFM.
3) Just comments and removing stale commented code.

4) Useful SCC for simplifyInfer.

5) Making CoreStats outputable.
parent df43fcd5
......@@ -1282,6 +1282,13 @@ altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
\begin{code}
data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
instance Outputable CoreStats where
ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) =
text "size of" <+> vcat [ text "terms =" <+> int i1
, text "types =" <+> int i2
, text "coercions =" <+> int i3 ]
plusCS :: CoreStats -> CoreStats -> CoreStats
plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
(CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
......
......@@ -153,14 +153,8 @@ deSugar hsc_env
-- You might think it doesn't matter, but the simplifier brings all top-level
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Lint result if necessary, and print
{-
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
(vcat [ pprCoreBindings final_pgm
, pprRules rules_for_imps ])
-}
#ifdef DEBUG
-- Debug only as pre-simple-optimisation program may be really big
; endPass dflags CoreDesugar final_pgm rules_for_imps
#endif
; (ds_binds, ds_rules_for_imps, ds_vects)
......
......@@ -658,8 +658,9 @@ getCachedFlatEq tc xi_args fl feq_origin
; flat_cache <- getTcSEvVarFlatCache
; inerts <- getTcSInerts
; case lookupFunEq pty fl (inert_funeqs inerts) of
Nothing -> lookup_in_flat_cache pty flat_cache
res -> return res }
Nothing
-> lookup_in_flat_cache pty flat_cache
res -> return res }
where lookup_in_flat_cache pty flat_cache
= case lookupTM pty flat_cache of
Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi'
......@@ -667,6 +668,9 @@ getCachedFlatEq tc xi_args fl feq_origin
, feq_origin `origin_matches` when_generated
-> do { traceTcS "getCachedFlatEq" $ text "success!"
; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
-- The only purpose of this flattening is to apply the
-- inert substitution (since everything in the flat cache
-- by construction will have a family-free RHS.
; return $ Just (xi'', co' `mkTransCo` (mkSymCo co)) }
_ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache
; return Nothing }
......
......@@ -47,6 +47,9 @@ import Bag
import Control.Monad ( foldM )
import TrieMap
import VarEnv
import qualified Data.Traversable as Traversable
import Control.Monad( when )
import UniqFM
import FastString ( sLit )
......@@ -164,22 +167,14 @@ selectNextWorkItem max_depth
= updWorkListTcS_return pick_next
where
pick_next :: WorkList -> (SelectWorkItem, WorkList)
-- A simple priorititization of equalities (for now)
-- --------------------------------------------------------
pick_next wl@(WorkList { wl_eqs = eqs, wl_rest = rest })
= case (eqs,rest) of
([],[]) -- No more work
-> (NoWorkRemaining,wl)
((ct:cts),_)
| cc_depth ct > max_depth -- Depth exceeded
-> (MaxDepthExceeded ct,wl)
| otherwise -- Equality work
-> (NextWorkItem ct, wl { wl_eqs = cts })
([],(ct:cts))
| cc_depth ct > max_depth -- Depth exceeded
-> (MaxDepthExceeded ct,wl)
| otherwise -- Non-equality work
-> (NextWorkItem ct, wl {wl_rest = cts})
pick_next wl = case selectWorkItem wl of
(Nothing,_)
-> (NoWorkRemaining,wl) -- No more work
(Just ct, new_wl)
| cc_depth ct > max_depth -- Depth exceeded
-> (MaxDepthExceeded ct,new_wl)
(Just ct, new_wl)
-> (NextWorkItem ct, new_wl) -- New workitem and worklist
runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
-> WorkItem -- The work item
......@@ -315,24 +310,23 @@ kickOutRewritableInerts :: Ct -> TcS ()
-- Pre: ct is a CTyEqCan
-- Post: the TcS monad is left with the thinner non-rewritable inerts; the
-- rewritable end up in the worklist
kickOutRewritableInerts ct
= do { wl <- modifyInertTcS (kick_out_rewritable ct)
kickOutRewritableInerts ct
= do { (wl,ieqs,solved_out) <- modifyInertTcS (kick_out_rewritable ct)
-- Rewrite the rewritable solved on the spot and stick them back in the inerts
-- Rewrite the inert_eqs on the spot!
; let ct_subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
inscope = mkInScopeSet $ tyVarsOfCt ct
{- DV: I am commenting out the solved story altogether because I did not see any performance
improvement compared to just kicking out the solved ones any way. In fact there were
situations where performance got worse.
; new_ieqs <- rewriteInertEqsFromInertEq (ct_subst,inscope) ieqs
; modifyInertTcS (\is -> ((), is { inert_eqs = new_ieqs }))
-- Rewrite the rewritable solved on the spot and stick them back in the inerts
; _unused <- mapBagM (rewrite_solved (ct_subst,inscope)) solved_out
; let subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
inscope = mkInScopeSet $ tyVarsOfCt ct
; solved_rewritten <- mapBagM (rewrite_solved (subst,inscope)) solved_out
; _unused <- modifyInertTcS (add_new_solveds solved_rewritten)
-}
; traceTcS "Kick out" (ppr ct $$ ppr wl)
; updWorkListTcS (unionWorkList wl) }
{-
where rewrite_solved inert_eqs solved_ct
= do { (new_ev,_) <- rewriteFromInertEqs inert_eqs fl ev
; mk_canonical new_ev }
......@@ -344,19 +338,24 @@ kickOutRewritableInerts ct
= do { let new_pty = evVarPred new_ev
; r <- canEvVar new_ev (classifyPredType new_pty) d fl
; case r of
Stop -> pprPanic "kickOutRewritableInerts" $
vcat [ text "Should never Stop, solved constraint IS canonical!"
, text "Orig (solved) =" <+> ppr solved_ct
, text "Rewritten (solved)=" <+> ppr new_pty ]
ContinueWith ct -> return ct }
add_new_solveds cts is = ((), is { inert_solved = new_solved })
where orig_solveds = inert_solved is
do_one slvmap ct = let ct_key = mkPredKeyForTypeMap ct
in alterTM ct_key (\_ -> Just ct) slvmap
new_solved = foldlBag do_one orig_solveds cts
-}
kick_out_rewritable :: Ct -> InertSet -> (WorkList,InertSet)
Stop -> return ()
ContinueWith ct -> updInertSetTcS ct }
rewriteInertEqsFromInertEq :: (TyVarEnv (Ct,Coercion), InScopeSet) -- A new substitution
-> TyVarEnv (Ct,Coercion) -- The inert equalities
-> TcS (TyVarEnv (Ct,Coercion)) -- The new inert equalities
rewriteInertEqsFromInertEq the_subst ieqs = Traversable.mapM do_one ieqs
where do_one (ct,co)
| ev <- cc_id ct, fl <- cc_flavor ct
= do { (new_ev,not_rewritten) <- rewriteFromInertEqs the_subst fl ev
; let EqPred _ xi = classifyPredType (evVarPred new_ev)
; if not_rewritten then
return (ct,co) -- return the same
else
return (ct { cc_id = new_ev, cc_rhs = xi }, mkEqVarLCo new_ev) }
kick_out_rewritable :: Ct -> InertSet -> ((WorkList,TyVarEnv (Ct,Coercion),Cts), InertSet)
kick_out_rewritable ct (IS { inert_eqs = eqmap
, inert_eq_tvs = inscope
, inert_dicts = dictmap
......@@ -365,12 +364,13 @@ kick_out_rewritable ct (IS { inert_eqs = eqmap
, inert_irreds = irreds
, inert_frozen = frozen
} )
= (kicked_out, remaining)
= ((kicked_out, eqs_in, feqs_out_solved `andCts` dicts_out_solved), remaining)
where
kicked_out = WorkList { wl_eqs = eqs_out ++ bagToList feqs_out
, wl_rest = bagToList (fro_out `andCts` dicts_out
`andCts` ips_out `andCts` irs_out) }
kicked_out = WorkList { wl_eqs = eqs_out
, wl_funeqs = bagToList feqs_out
, wl_rest = bagToList (fro_out `andCts` dicts_out
`andCts` ips_out `andCts` irs_out) }
remaining = IS { inert_eqs = eqs_in
, inert_eq_tvs = inscope -- keep the same, safe and cheap
......@@ -383,18 +383,37 @@ kick_out_rewritable ct (IS { inert_eqs = eqmap
fl = cc_flavor ct
tv = cc_tyvar ct
(eqs_out, eqs_in) = partitionEqMap
(\inert_ct -> rewritable inert_ct &&
not (cc_flavor inert_ct `canRewrite` fl)) eqmap
-- Delicate:
-- We want to throw out only the rewritables which cannot
-- themselves rewrite the workitem. Because, what will remain
-- in eqs_in, even if rewritable, can be readily substituted
-- in-place from the new item, without dangers for occurs
-- loops or further need for canonicalization.
(ips_out, ips_in) = partitionCCanMap rewritable ipmap
(eqs_out, eqs_in) = partitionEqMap rewritable eqmap
(ips_out, ips_in) = partitionCCanMap rewritable ipmap
(feqs_out_all, feqs_in) = partitionCtTypeMap rewritable funeqmap
(feqs_out_solved, feqs_out) = partitionBag is_solved feqs_out_all
(feqs_out, feqs_in) = partitionCtTypeMap rewritable funeqmap
(dicts_out, dicts_in) = partitionCCanMap rewritable dictmap
(dicts_out_all, dicts_in) = partitionCCanMap rewritable dictmap
(dicts_out_solved, dicts_out) = partitionBag is_solved dicts_out_all
(irs_out, irs_in) = partitionBag rewritable irreds
(fro_out, fro_in) = partitionBag rewritable frozen
rewritable ct = (fl `canRewrite` cc_flavor ct) &&
rewritable ct = (fl `canRewrite` cc_flavor ct) &&
(tv `elemVarSet` tyVarsOfCt ct)
is_solved ct
| Just GivenSolved <- isGiven_maybe (cc_flavor ct)
= True
| otherwise = False
data SPSolveResult = SPCantSolve
......@@ -1387,8 +1406,8 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
; return $
SomeTopInt { tir_rule = "Fun/Top (solved, more work)"
, tir_new_item = ContinueWith solved } }
-- Cache in inerts the Solved item
, tir_new_item = ContinueWith solved } }
-- Cache in inerts the Solved item
Given {} -> do { eqv' <- newGivenEqVar fl xi rhs_ty $
mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe
......
......@@ -1435,6 +1435,7 @@ tcRnExpr hsc_env ictxt rdr_expr
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
{-# SCC "simplifyInfer" #-}
simplifyInfer True {- Free vars are closed -}
False {- No MR for now -}
[(fresh_it, res_ty)]
......
......@@ -1011,7 +1011,7 @@ emitWantedCts = mapBagM_ emit_wanted_ct
| v <- cc_id ct
, Wanted loc <- cc_flavor ct
= emitFlat (EvVarX v loc)
| otherwise = panic "emitWantecCts: can't emit non-wanted!"
| otherwise = panic "emitWantedCts: can't emit non-wanted!"
emitImplication :: Implication -> TcM ()
emitImplication ct
......
......@@ -14,7 +14,7 @@ module TcSMonad (
WorkList(..), isEmptyWorkList, emptyWorkList,
workListFromEq, workListFromNonEq, workListFromCt,
extendWorkListEq, extendWorkListNonEq, extendWorkListCt,
appendWorkListCt, appendWorkListEqs, unionWorkList,
appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
......@@ -207,17 +207,22 @@ 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_rest :: [Ct] }
data WorkList = WorkList { wl_eqs :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] }
unionWorkList :: WorkList -> WorkList -> WorkList
unionWorkList new_wl orig_wl =
WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
, wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs 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 = wl { wl_eqs = ct : wl_eqs wl }
extendWorkListEq ct wl
| Just {} <- isCFunEqCan_Maybe ct
= wl { wl_funeqs = ct : wl_funeqs wl }
| otherwise
= wl { wl_eqs = ct : wl_eqs wl }
extendWorkListNonEq :: Ct -> WorkList -> WorkList
-- Extension by non equality
......@@ -238,25 +243,36 @@ appendWorkListEqs :: [Ct] -> WorkList -> WorkList
appendWorkListEqs cts wl = foldr extendWorkListEq wl cts
isEmptyWorkList :: WorkList -> Bool
isEmptyWorkList wl = null (wl_eqs wl) && null (wl_rest wl)
isEmptyWorkList wl
= null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl)
emptyWorkList :: WorkList
emptyWorkList = WorkList { wl_eqs = [], wl_rest = [] }
emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = []}
workListFromEq :: Ct -> WorkList
workListFromEq ct = WorkList { wl_eqs = [ct], wl_rest = [] }
workListFromEq ct = extendWorkListEq ct emptyWorkList
workListFromNonEq :: Ct -> WorkList
workListFromNonEq ct = WorkList { wl_eqs = [], wl_rest = [ct] }
workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
workListFromCt :: Ct -> WorkList
-- Agnostic
workListFromCt ct | isLCoVar (cc_id ct) = workListFromEq ct
| otherwise = workListFromNonEq ct
selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
= case (eqs,feqs,rest) of
(ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts })
(_,(ct:cts),_) -> (Just ct, wl { wl_funeqs = cts })
(_,_,(ct:cts)) -> (Just ct, wl { wl_rest = cts })
(_,_,_) -> (Nothing,wl)
-- Pretty printing
instance Outputable WorkList where
ppr wl = vcat [ text "WorkList (eqs) = " <+> ppr (wl_eqs wl)
, text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
, text "WorkList (rest) = " <+> ppr (wl_rest wl)
]
......@@ -483,14 +499,6 @@ updInertSet is item
inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item)
in is { inert_eqs = eqs', inert_eq_tvs = inscope' }
{-
-- /Solved/ non-equalities go to the solved map
| Just GivenSolved <- isGiven_maybe (cc_flavor item)
= let pty = mkPredKeyForTypeMap item
solved_orig = inert_solved is
in is { inert_solved = alterTM pty (\_ -> Just item) solved_orig }
-}
| Just x <- isCIPCan_Maybe item -- IP
= is { inert_ips = updCCanMap (x,item) (inert_ips is) }
| isCIrredEvCan item -- Presently-irreducible evidence
......@@ -1267,7 +1275,15 @@ newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated
-- the call sites for this invariant to be quickly restored.
newEvVar fl pty
| isGivenOrSolved fl -- Create new variable and update the cache
= do { new <- forceNewEvVar fl pty
= do { eref <- getTcSEvVarCache
; ecache <- wrapTcS (TcM.readTcRef eref)
; case lookupTM pty (evc_cache ecache) of
Just (_,cached_fl)
| cached_fl `canSolve` fl
-> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $
return ()
_ -> return ()
; new <- forceNewEvVar fl pty
; return (EvVarCreated True new) }
| otherwise -- Otherwise lookup first
......@@ -1442,14 +1458,24 @@ rewriteFromInertEqs (subst,inscope) fl v
; if isReflCo co then return (v,True)
else do { traceTcS "rewriteFromInertEqs" $
text "Original item =" <+> ppr v <+> dcolon <+> ppr (evVarPred v)
; v' <- forceNewEvVar fl (pSnd (liftedCoercionKind co))
; case fl of
Wanted {} -> setEvBind v (EvCast v' (mkSymCo co))
Given {} -> setEvBind v' (EvCast v co)
Derived {} -> return ()
; traceTcS "rewriteFromInertEqs" $
text "Rewritten item =" <+> ppr v' <+> dcolon <+> ppr (evVarPred v')
; return (v',False) } }
; delCachedEvVar v
; evc <- newEvVar fl (pSnd (liftedCoercionKind co))
; let v' = evc_the_evvar evc
; if isNewEvVar evc then
do { case fl of
Wanted {} -> setEvBind v (EvCast v' (mkSymCo co))
Given {} -> setEvBind v' (EvCast v co)
Derived {} -> return ()
; traceTcS "rewriteFromInertEqs" $
text "Rewritten item =" <+> ppr v' <+>
dcolon <+> ppr (evVarPred v')
; return (v',False) }
else -- Maybe given, but when wanted set bind
do { case fl of
Wanted {} -> setEvBind v (EvCast v' (mkSymCo co))
_ -> return ()
; return (v',True) } -- As if rewriting never happened?
} }
-- See Note [LiftInertEqs]
......
......@@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
of arguments of combining function.
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
......@@ -74,6 +74,7 @@ import Compiler.Hoopl hiding (Unique)
import Data.Function (on)
import qualified Data.IntMap as M
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Typeable
import Data.Data
\end{code}
......@@ -179,11 +180,19 @@ ufmToList :: UniqFM elt -> [(Unique, elt)]
\begin{code}
newtype UniqFM ele = UFM { unUFM :: M.IntMap ele }
deriving (Typeable,Data)
deriving (Typeable,Data, Traversable.Traversable, Functor)
instance Eq ele => Eq (UniqFM ele) where
(==) = (==) `on` unUFM
{-
instance Functor UniqFM where
fmap f = fmap f . unUFM
instance Traversable.Traversable UniqFM where
traverse f = Traversable.traverse f . unUFM
-}
instance Foldable.Foldable UniqFM where
foldMap f = Foldable.foldMap f . unUFM
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment