import Id
import TcType
import CoreSubst
-import CoreUnfold ( mkUnfolding, mkInlineRule )
+import CoreUnfold ( mkSimpleUnfolding, mkInlineUnfolding )
import VarSet
import VarEnv
import CoreSyn
import UniqSupply ( UniqSupply, UniqSM, initUs_, MonadUnique(..) )
import Name
import MkId ( voidArgId, realWorldPrimId )
-import FiniteMap
import Maybes ( catMaybes, isJust )
import BasicTypes ( isNeverActive, inlinePragmaActivation )
import Bag
import Outputable
import FastString
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
\end{code}
%************************************************************************
loc = getSrcSpan name
add_unf sc_flt sc_rhs -- Sole purpose: make sc_flt respond True to interestingDictId
- = setIdUnfolding sc_flt (mkUnfolding False False sc_rhs)
+ = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs)
arg_set = mkVarSet args'
is_flt_sc_arg var = isId var
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing
- fn_has_inline_rule = case isInlineRule_maybe fn_unf of
+ fn_has_inline_rule = case isStableUnfolding_maybe fn_unf of
Just (_,sat) -> Just sat
Nothing -> Nothing
= let
mb_spec_arity = if sat then Just spec_arity else Nothing
in
- spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+ spec_f_w_arity `setIdUnfolding` mkInlineUnfolding mb_spec_arity spec_rhs
| otherwise
= spec_f_w_arity
| otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs
where
- dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
+ dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx
subst_w_unf = extendIdSubst subst d (Var dx_id1)
-- Important! We're going to substitute dx_id1 for d
-- and we want it to look "interesting", else we won't gather *any*
type CallDetails = IdEnv CallInfoSet
newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument
--- CallInfo uses a FiniteMap, thereby ensuring that
+-- CallInfo uses a Map, thereby ensuring that
-- we record only one call instance for any key
--
-- The list of types and dictionaries is guaranteed to
-- match the type of f
-type CallInfoSet = FiniteMap CallKey ([DictExpr], VarSet)
+type CallInfoSet = Map CallKey ([DictExpr], VarSet)
-- Range is dict args and the vars of the whole
-- call (including tyvars)
-- [*not* include the main id itself, of course]
cmp (Just t1) (Just t2) = tcCmpType t1 t2
unionCalls :: CallDetails -> CallDetails -> CallDetails
-unionCalls c1 c2 = plusVarEnv_C plusFM c1 c2
+unionCalls c1 c2 = plusVarEnv_C Map.union c1 c2
-- plusCalls :: UsageDetails -> CallDetails -> UsageDetails
-- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds }
callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
callInfoFVs :: CallInfoSet -> VarSet
-callInfoFVs call_info = foldFM (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
+callInfoFVs call_info = Map.foldRightWithKey (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
------------------------------------------------------------
singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
singleCall id tys dicts
= MkUD {ud_binds = emptyBag,
- ud_calls = unitVarEnv id (unitFM (CallKey tys) (dicts, call_fvs)) }
+ ud_calls = unitVarEnv id (Map.singleton (CallKey tys) (dicts, call_fvs)) }
where
call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
tys_fvs = tyVarsOfTypes (catMaybes tys)
uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
calls_for_me = case lookupVarEnv orig_calls fn of
Nothing -> []
- Just cs -> filter_dfuns (fmToList cs)
+ Just cs -> filter_dfuns (Map.toList cs)
dep_set = foldlBag go (unitVarSet fn) orig_dbs
go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
= mapVarEnv filter_calls calls
where
filter_calls :: CallInfoSet -> CallInfoSet
- filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
+ filter_calls = Map.filterWithKey (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
-- Remove calls *for* bs