[commit: ghc] master: Make CallInfo into a data type with fields (cb5ca5f)
git at git.haskell.org
git at git.haskell.org
Tue May 9 09:44:34 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/cb5ca5f39c2ad26608516ee4248b9ddea31a1d5a/ghc
>---------------------------------------------------------------
commit cb5ca5f39c2ad26608516ee4248b9ddea31a1d5a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon May 8 16:50:37 2017 +0100
Make CallInfo into a data type with fields
Simple refactor, no change in behaviour
>---------------------------------------------------------------
cb5ca5f39c2ad26608516ee4248b9ddea31a1d5a
compiler/specialise/Specialise.hs | 57 ++++++++++++++++++++++++---------------
1 file changed, 36 insertions(+), 21 deletions(-)
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index 37afca5..66301a5 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -1224,7 +1224,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
-> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition
UsageDetails, -- Usage details from specialised body
CoreRule)) -- Info for the Id's SpecEnv
- spec_call _call_info@(CallKey call_ts, (call_ds, _))
+ spec_call (CI { ci_key = CallKey call_ts, ci_args = call_ds })
= ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
-- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs
@@ -1768,8 +1768,6 @@ instance Outputable UsageDetails where
-- variables (both type variables and dictionaries)
type DictBind = (CoreBind, VarSet)
-type DictExpr = CoreExpr
-
emptyUDs :: UsageDetails
emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }
@@ -1778,13 +1776,25 @@ type CallDetails = DIdEnv CallInfoSet
-- The order of specialized binds and rules depends on how we linearize
-- CallDetails, so to get determinism we must use a deterministic set here.
-- See Note [Deterministic UniqFM] in UniqDFM
-newtype CallKey = CallKey [Maybe Type]
- -- Nothing => unconstrained type argument
data CallInfoSet = CIS Id (Bag CallInfo)
-- The list of types and dictionaries is guaranteed to
-- match the type of f
+data CallInfo
+ = CI { ci_key :: CallKey -- Type arguments
+ , ci_args :: [DictExpr] -- Dictionary arguments
+ , ci_fvs :: VarSet -- Free vars of the ci_key and ci_args
+ -- call (including tyvars)
+ -- [*not* include the main id itself, of course]
+ }
+
+newtype CallKey = CallKey [Maybe Type]
+ -- Nothing => unconstrained type argument
+
+type DictExpr = CoreExpr
+
+
{-
Note [CallInfoSet determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1829,7 +1839,7 @@ ciSetToList (CIS _ b) = snd $ foldrBag combine (emptyTM, []) b
-- This is where we eliminate duplicates, recording the CallKeys we've
-- already seen in the TrieMap. See Note [CallInfoSet determinism].
combine :: CallInfo -> (CallKeySet, [CallInfo]) -> (CallKeySet, [CallInfo])
- combine ci@(CallKey key, _) (set, acc)
+ combine ci@(CI { ci_key = CallKey key }) (set, acc)
| Just _ <- lookupTM key set = (set, acc)
| otherwise = (insertTM key () set, ci:acc)
@@ -1839,26 +1849,24 @@ type CallKeySet = ListMap (MaybeMap TypeMap) ()
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter p (CIS id a) = CIS id (filterBag p a)
-type CallInfo = (CallKey, ([DictExpr], VarSet))
- -- Range is dict args and the vars of the whole
- -- call (including tyvars)
- -- [*not* include the main id itself, of course]
-
instance Outputable CallInfoSet where
ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)
2 (ppr map)
pprCallInfo :: Id -> CallInfo -> SDoc
-pprCallInfo fn (CallKey mb_tys, (_dxs, _))
- = hang (ppr fn)
- 2 (fsep (map ppr_call_key_ty mb_tys {- ++ map pprParendExpr _dxs -}))
+pprCallInfo fn (CI { ci_key = key })
+ = ppr fn <+> ppr key
ppr_call_key_ty :: Maybe Type -> SDoc
ppr_call_key_ty Nothing = char '_'
ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
instance Outputable CallKey where
- ppr (CallKey ts) = ppr ts
+ ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))
+
+instance Outputable CallInfo where
+ ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })
+ = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
@@ -1875,14 +1883,16 @@ callDetailsFVs calls =
callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS _ call_info) =
- foldrBag (\(_, (_,fv)) vs -> unionVarSet fv vs) emptyVarSet call_info
+ foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
------------------------------------------------------------
singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
singleCall id tys dicts
= MkUD {ud_binds = emptyBag,
ud_calls = unitDVarEnv id $ CIS id $
- unitBag (CallKey tys, (dicts, call_fvs)) }
+ unitBag (CI { ci_key = CallKey tys
+ , ci_args = dicts
+ , ci_fvs = call_fvs }) }
where
call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
tys_fvs = tyCoVarsOfTypes (catMaybes tys)
@@ -2146,11 +2156,16 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
filter_dfuns | isDFunId fn = filter ok_call
| otherwise = \cs -> cs
- ok_call (_, (_,fvs)) = not (fvs `intersectsVarSet` dep_set)
+ ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dep_set)
----------------------
splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
--- Returns (free_dbs, dump_dbs, dump_set)
+-- splitDictBinds dbs bndrs returns
+-- (free_dbs, dump_dbs, dump_set)
+-- where
+-- * dump_dbs depends, transitively on bndrs
+-- * free_dbs does not depend on bndrs
+-- * dump_set = bndrs `union` bndrs(dump_dbs)
splitDictBinds dbs bndr_set
= foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl not foldr;
@@ -2167,11 +2182,11 @@ splitDictBinds dbs bndr_set
----------------------
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
--- Remove calls *mentioning* bs
+-- Remove calls *mentioning* bs in any way
deleteCallsMentioning bs calls
= mapDVarEnv (ciSetFilter keep_call) calls
where
- keep_call (_, (_, fvs)) = not (fvs `intersectsVarSet` bs)
+ keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
-- Remove calls *for* bs
More information about the ghc-commits
mailing list