\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
import PprCore ( pprRules )
import UniqSupply ( UniqSupply,
- UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
- getUs, mapUs
+ UniqSM, initUs_,
+ MonadUnique(..)
)
import Name
import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
import Maybes ( catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet_dyn )
-import BasicTypes ( Activation( AlwaysActive ) )
import Bag
-import List ( partition )
-import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
- equalLength, lengthAtLeast, notNull )
+import Util
import Outputable
import FastString
-infixr 9 `thenSM`
\end{code}
%************************************************************************
\begin{code}
specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram dflags us binds
- = do
+specProgram dflags us binds = do
+
showPass dflags "Specialise"
- let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
- returnSM (dumpAllDictBinds uds' binds'))
+ let binds' = initSM us (do (binds', uds') <- go binds
+ return (dumpAllDictBinds uds' binds'))
endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
+ (withPprStyle defaultUserStyle $
+ pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
return binds'
where
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
+ top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
- go [] = returnSM ([], emptyUDs)
- go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
- specBind top_subst bind uds `thenSM` \ (bind', uds') ->
- returnSM (bind' ++ binds', uds')
+ go [] = return ([], emptyUDs)
+ go (bind:binds) = do (binds', uds) <- go binds
+ (bind', uds') <- specBind top_subst bind uds
+ return (bind' ++ binds', uds')
\end{code}
%************************************************************************
-- the RHS of specialised bindings (no type-let!)
---------------- First the easy cases --------------------
-specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
-specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs)
-specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs)
-specExpr subst (Cast e co) =
- specExpr subst e `thenSM` \ (e', uds) ->
- returnSM ((Cast e' (substTy subst co)), uds)
-specExpr subst (Note note body)
- = specExpr subst body `thenSM` \ (body', uds) ->
- returnSM (Note (specNote subst note) body', uds)
+specExpr subst (Type ty) = return (Type (substTy subst ty), emptyUDs)
+specExpr subst (Var v) = return (specVar subst v, emptyUDs)
+specExpr _ (Lit lit) = return (Lit lit, emptyUDs)
+specExpr subst (Cast e co) = do
+ (e', uds) <- specExpr subst e
+ return ((Cast e' (substTy subst co)), uds)
+specExpr subst (Note note body) = do
+ (body', uds) <- specExpr subst body
+ return (Note (specNote subst note) body', uds)
---------------- Applications might generate a call instance --------------------
-specExpr subst expr@(App fun arg)
+specExpr subst expr@(App {})
= go expr []
where
- go (App fun arg) args = specExpr subst arg `thenSM` \ (arg', uds_arg) ->
- go fun (arg':args) `thenSM` \ (fun', uds_app) ->
- returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
+ go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg
+ (fun', uds_app) <- go fun (arg':args)
+ return (App fun' arg', uds_arg `plusUDs` uds_app)
go (Var f) args = case specVar subst f of
- Var f' -> returnSM (Var f', mkCallUDs subst f' args)
- e' -> returnSM (e', emptyUDs) -- I don't expect this!
- go other args = specExpr subst other
+ Var f' -> return (Var f', mkCallUDs subst f' args)
+ e' -> return (e', emptyUDs) -- I don't expect this!
+ go other _ = specExpr subst other
---------------- Lambda/case require dumping of usage details --------------------
-specExpr subst e@(Lam _ _)
- = specExpr subst' body `thenSM` \ (body', uds) ->
- let
- (filtered_uds, body'') = dumpUDs bndrs' uds body'
- in
- returnSM (mkLams bndrs' body'', filtered_uds)
+specExpr subst e@(Lam _ _) = do
+ (body', uds) <- specExpr subst' body
+ let (filtered_uds, body'') = dumpUDs bndrs' uds body'
+ return (mkLams bndrs' body'', filtered_uds)
where
(bndrs, body) = collectBinders e
(subst', bndrs') = substBndrs subst bndrs
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
-specExpr subst (Case scrut case_bndr ty alts)
- = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
- mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
+specExpr subst (Case scrut case_bndr ty alts) = do
+ (scrut', uds_scrut) <- specExpr subst scrut
+ (alts', uds_alts) <- mapAndCombineSM spec_alt alts
+ return (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
where
(subst_alt, case_bndr') = substBndr subst case_bndr
-- No need to clone case binder; it can't float like a let(rec)
- spec_alt (con, args, rhs)
- = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
- let
- (uds', rhs'') = dumpUDs args uds rhs'
- in
- returnSM ((con, args', rhs''), uds')
- where
- (subst_rhs, args') = substBndrs subst_alt args
+ spec_alt (con, args, rhs) = do
+ (rhs', uds) <- specExpr subst_rhs rhs
+ let (uds', rhs'') = dumpUDs args uds rhs'
+ return ((con, args', rhs''), uds')
+ where
+ (subst_rhs, args') = substBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
-specExpr subst (Let bind body)
- = -- Clone binders
- cloneBindSM subst bind `thenSM` \ (rhs_subst, body_subst, bind') ->
-
- -- Deal with the body
- specExpr body_subst body `thenSM` \ (body', body_uds) ->
+specExpr subst (Let bind body) = do
+ -- Clone binders
+ (rhs_subst, body_subst, bind') <- cloneBindSM subst bind
+
+ -- Deal with the body
+ (body', body_uds) <- specExpr body_subst body
- -- Deal with the bindings
- specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) ->
+ -- Deal with the bindings
+ (binds', uds) <- specBind rhs_subst bind' body_uds
- -- All done
- returnSM (foldr Let body' binds', uds)
+ -- All done
+ return (foldr Let body' binds', uds)
-- Must apply the type substitution to coerceions
-specNote subst note = note
+specNote :: Subst -> Note -> Note
+specNote _ note = note
\end{code}
%************************************************************************
UsageDetails) -- And info to pass upstream
specBind rhs_subst bind body_uds
- = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
- let
- bndrs = bindersOf bind
- all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
- -- It's important that the `plusUDs` is this way round,
+ = do { (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_uds)
+ ; return (finishSpecBind bind' bind_uds body_uds) }
+
+finishSpecBind :: CoreBind -> UsageDetails -> UsageDetails -> ([CoreBind], UsageDetails)
+finishSpecBind bind
+ (MkUD { dict_binds = rhs_dbs, calls = rhs_calls, ud_fvs = rhs_fvs })
+ (MkUD { dict_binds = body_dbs, calls = body_calls, ud_fvs = body_fvs })
+ | not (mkVarSet bndrs `intersectsVarSet` all_fvs)
+ -- Common case 1: the bound variables are not
+ -- mentioned in the dictionary bindings
+ = ([bind], MkUD { dict_binds = body_dbs `unionBags` rhs_dbs
+ -- It's important that the `unionBags` is this way round,
-- because body_uds may bind dictionaries that are
-- used in the calls passed to specDefn. So the
- -- dictionary bindings in bind_uds may mention
+ -- dictionary bindings in rhs_uds may mention
-- dictionaries bound in body_uds.
- in
- case splitUDs bndrs all_uds of
-
- (_, ([],[])) -- This binding doesn't bind anything needed
- -- in the UDs, so put the binding here
- -- This is the case for most non-dict bindings, except
- -- for the few that are mentioned in a dict binding
- -- that is floating upwards in body_uds
- -> returnSM ([bind'], all_uds)
-
- (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out
- -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
-
-
--- A truly gruesome function
-mkBigUD bind@(NonRec _ _) dbs calls
- = -- Common case: non-recursive and no specialisations
- -- (if there were any specialistions it would have been made recursive)
- MkUD { dict_binds = listToBag (mkDB bind : dbs),
- calls = listToCallDetails calls }
-
-mkBigUD bind dbs calls
- = -- General case
- MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
- -- Make a huge Rec
- calls = listToCallDetails calls }
+ , calls = all_calls
+ , ud_fvs = all_fvs })
+
+ | case bind of { NonRec {} -> True; Rec {} -> False }
+ -- Common case 2: no specialisation happened, and binding
+ -- is non-recursive. But the binding may be
+ -- mentioned in body_dbs, so we should put it first
+ = ([], MkUD { dict_binds = rhs_dbs `unionBags` ((bind, b_fvs) `consBag` body_dbs)
+ , calls = all_calls
+ , ud_fvs = all_fvs `unionVarSet` b_fvs })
+
+ | otherwise -- General case: make a huge Rec (sigh)
+ = ([], MkUD { dict_binds = unitBag (Rec all_db_prs, all_db_fvs)
+ , calls = all_calls
+ , ud_fvs = all_fvs `unionVarSet` b_fvs })
where
- bind_prs (NonRec b r) = [(b,r)]
- bind_prs (Rec prs) = prs
+ all_fvs = rhs_fvs `unionVarSet` body_fvs
+ all_calls = zapCalls bndrs (rhs_calls `unionCalls` body_calls)
+
+ bndrs = bindersOf bind
+ b_fvs = bind_fvs bind
- dbsToPairs [] = []
- dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
+ (all_db_prs, all_db_fvs) = add (bind, b_fvs) $
+ foldrBag add ([], emptyVarSet) $
+ rhs_dbs `unionBags` body_dbs
+ add (NonRec b r, b_fvs) (prs, fvs) = ((b,r) : prs, b_fvs `unionVarSet` fvs)
+ add (Rec b_prs, b_fvs) (prs, fvs) = (b_prs ++ prs, b_fvs `unionVarSet` fvs)
+
+specBindItself :: Subst -> CoreBind -> CallDetails -> SpecM (CoreBind, UsageDetails)
-- specBindItself deals with the RHS, specialising it according
-- to the calls found in the body (if any)
-specBindItself rhs_subst (NonRec bndr rhs) call_info
- = specDefn rhs_subst call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+specBindItself rhs_subst (NonRec bndr rhs) call_info = do
+ ((bndr',rhs'), spec_defns, spec_uds) <- specDefn rhs_subst call_info (bndr,rhs)
let
new_bind | null spec_defns = NonRec bndr' rhs'
| otherwise = Rec ((bndr',rhs'):spec_defns)
-- bndr' mentions the spec_defns in its SpecEnv
-- Not sure why we couln't just put the spec_defns first
- in
- returnSM (new_bind, spec_uds)
+ return (new_bind, spec_uds)
-specBindItself rhs_subst (Rec pairs) call_info
- = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff ->
+specBindItself rhs_subst (Rec pairs) call_info = do
+ stuff <- mapM (specDefn rhs_subst call_info) pairs
let
(pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
spec_defns = concat spec_defns_s
spec_uds = plusUDList spec_uds_s
new_bind = Rec (spec_defns ++ pairs')
- in
- returnSM (new_bind, spec_uds)
-
+ return (new_bind, spec_uds)
+
specDefn :: Subst -- Subst to use for RHS
-> CallDetails -- Info on how it is used in its scope
-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small
-- See Note [Inline specialisation] for why we do not
--- switch off specialisation for inline functions
-
- = -- Specialise the body of the function
- specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
+-- switch off specialisation for inline functions = do
+ = do
+ -- Specialise the body of the function
+ (rhs', rhs_uds) <- specExpr subst rhs
-- Make a specialised version for each call in calls_for_me
- mapSM spec_call calls_for_me `thenSM` \ stuff ->
+ stuff <- mapM spec_call calls_for_me
let
- (spec_defns, spec_uds, spec_rules) = unzip3 stuff
+ (spec_defns, spec_uds, spec_rules) = unzip3 stuff
+
+ fn' = addIdSpecialisations fn spec_rules
- fn' = addIdSpecialisations fn spec_rules
- in
- returnSM ((fn',rhs'),
- spec_defns,
- rhs_uds `plusUDs` plusUDList spec_uds)
+ return ((fn',rhs'),
+ spec_defns,
+ rhs_uds `plusUDs` plusUDList spec_uds)
| otherwise -- No calls or RHS doesn't fit our preconceptions
- = WARN( notNull calls_for_me, ptext SLIT("Missed specialisation opportunity for") <+> ppr fn )
+ = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
-- Note [Specialisation shape]
- specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ((fn, rhs'), [], rhs_uds)
+ (do { (rhs', rhs_uds) <- specExpr subst rhs
+ ; return ((fn, rhs'), [], rhs_uds) })
where
fn_type = idType fn
(rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
rhs_dicts = take n_dicts rhs_ids
- rhs_bndrs = rhs_tyvars ++ rhs_dicts
body = mkLams (drop n_dicts rhs_ids) rhs_body
-- Glue back on the non-dict lambdas
-> SpecM ((Id,CoreExpr), -- Specialised definition
UsageDetails, -- Usage details from specialised body
CoreRule) -- Info for the Id's SpecEnv
- spec_call (CallKey call_ts, (call_ds, call_fvs))
- = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
+ spec_call (CallKey call_ts, (call_ds, _))
+ = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) do
-- Calls are only recorded for properly-saturated applications
-- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
ty_args = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
where
mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
- mk_ty_arg rhs_tyvar (Just ty) = Type ty
+ mk_ty_arg _ (Just ty) = Type ty
rhs_subst = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
- in
- cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
+
+ (rhs_subst', rhs_dicts') <- cloneBinders rhs_subst rhs_dicts
let
inst_args = ty_args ++ map Var rhs_dicts'
= (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
| otherwise = (poly_tyvars, poly_tyvars)
spec_id_ty = mkPiTypes lam_args body_ty
- in
- newIdSM fn spec_id_ty `thenSM` \ spec_f ->
- specExpr rhs_subst' (mkLams lam_args body) `thenSM` \ (spec_rhs, rhs_uds) ->
+
+ spec_f <- newIdSM fn spec_id_ty
+ (spec_rhs, rhs_uds) <- specExpr rhs_subst' (mkLams lam_args body)
let
-- The rule to put in the function's specialisation is:
-- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
| otherwise = (spec_f, spec_rhs)
- in
- returnSM (spec_pr, final_uds, spec_env_rule)
+
+ return (spec_pr, final_uds, spec_env_rule)
where
my_zipEqual doc xs ys
-#ifdef DEBUG
- | not (equalLength xs ys) = pprPanic "my_zipEqual" (vcat
+ | debugIsOn && not (equalLength xs ys)
+ = pprPanic "my_zipEqual" (vcat
[ ppr xs, ppr ys
, ppr fn <+> ppr call_ts
, ppr (idType fn), ppr theta
, ppr n_dicts, ppr rhs_dicts
, ppr rhs])
-#endif
| otherwise = zipEqual doc xs ys
\end{code}
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
-- (Remember, Bags preserve order in GHC.)
- calls :: !CallDetails
+ calls :: !CallDetails,
+
+ ud_fvs :: !VarSet -- A superset of the variables mentioned in
+ -- either dict_binds or calls
}
+instance Outputable UsageDetails where
+ ppr (MkUD { dict_binds = dbs, calls = calls, ud_fvs = fvs })
+ = ptext (sLit "MkUD") <+> braces (sep (punctuate comma
+ [ptext (sLit "binds") <+> equals <+> ppr dbs,
+ ptext (sLit "calls") <+> equals <+> ppr calls,
+ ptext (sLit "fvs") <+> equals <+> ppr fvs]))
+
type DictBind = (CoreBind, VarSet)
-- The set is the free vars of the binding
-- both tyvars and dicts
type DictExpr = CoreExpr
-emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
-
-type ProtoUsageDetails = ([DictBind],
- [(Id, CallKey, ([DictExpr], VarSet))]
- )
+emptyUDs :: UsageDetails
+emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM, ud_fvs = emptyVarSet }
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-- The list of types and dictionaries is guaranteed to
-- match the type of f
+instance Outputable CallKey where
+ ppr (CallKey ts) = ppr ts
+
-- Type isn't an instance of Ord, so that we can control which
-- instance we use. That's tiresome here. Oh well
instance Eq CallKey where
- k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False }
+ k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
instance Ord CallKey where
compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
where
- cmp Nothing Nothing = EQ
- cmp Nothing (Just t2) = LT
- cmp (Just t1) Nothing = GT
+ cmp Nothing Nothing = EQ
+ cmp Nothing (Just _) = LT
+ cmp (Just _) Nothing = GT
cmp (Just t1) (Just t2) = tcCmpType t1 t2
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusFM_C plusFM c1 c2
-singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
singleCall id tys dicts
- = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
+ = MkUD {dict_binds = emptyBag,
+ calls = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)),
+ ud_fvs = call_fvs }
where
call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
tys_fvs = tyVarsOfTypes (catMaybes tys)
--
-- We don't include the 'id' itself.
-listToCallDetails calls
- = foldr (unionCalls . mk_call) emptyFM calls
- where
- mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
- -- NB: the free vars of the call are provided
-
-callDetailsToList calls = [ (id,tys,dicts)
- | (id,fm) <- fmToList calls,
- (tys, dicts) <- fmToList fm
- ]
-
+mkCallUDs :: Subst -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs subst f args
| null theta
|| not (all isClassPred theta)
-- *don't* say what the value of the implicit param is!
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
- || maybeToBool (lookupRule (\act -> True) (substInScope subst) emptyRuleBase f args)
+ || maybeToBool (lookupRule (\_act -> True) (substInScope subst) emptyRuleBase f args)
-- There's already a rule covering this call. A typical case
-- is where there's an explicit user-provided rule. Then
-- we don't want to create a specialised version
= emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
- = MkUD {dict_binds = emptyBag,
- calls = singleCall f spec_tys dicts
- }
+ = singleCall f spec_tys dicts
where
(tyvars, theta, _) = tcSplitSigmaTy (idType f)
constrained_tyvars = tyVarsOfTheta theta
------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
-plusUDs (MkUD {dict_binds = db1, calls = calls1})
- (MkUD {dict_binds = db2, calls = calls2})
- = MkUD {dict_binds = d, calls = c}
+plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
+ (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})
+ = MkUD {dict_binds = d, calls = c, ud_fvs = fvs1 `unionVarSet` fvs2}
where
d = db1 `unionBags` db2
c = calls1 `unionCalls` calls2
+plusUDList :: [UsageDetails] -> UsageDetails
plusUDList = foldr plusUDs emptyUDs
-- zapCalls deletes calls to ids from uds
-zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
+zapCalls :: [Id] -> CallDetails -> CallDetails
+zapCalls ids calls = delListFromFM calls ids
+mkDB :: CoreBind -> DictBind
mkDB bind = (bind, bind_fvs bind)
+bind_fvs :: CoreBind -> VarSet
bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
where
bndrs = map fst prs
rhs_fvs = unionVarSets (map pair_fvs prs)
+pair_fvs :: (Id, CoreExpr) -> VarSet
pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
-- Don't forget variables mentioned in the
-- rules of the bndr. C.f. OccAnal.addRuleUsage
-- type T a = Int
-- x :: T a = 3
-addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
+addDictBind :: (Id,CoreExpr) -> UsageDetails -> UsageDetails
+addDictBind (dict,rhs) uds
+ = uds { dict_binds = db `consBag` dict_binds uds
+ , ud_fvs = ud_fvs uds `unionVarSet` fvs }
+ where
+ db@(_, fvs) = mkDB (NonRec dict rhs)
+dumpAllDictBinds :: UsageDetails -> [CoreBind] -> [CoreBind]
dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
= foldrBag add binds dbs
where
dumpUDs :: [CoreBndr]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
-dumpUDs bndrs uds body
- = (free_uds, foldr add_let body dict_binds)
+dumpUDs bndrs (MkUD { dict_binds = orig_dbs
+ , calls = orig_calls
+ , ud_fvs = fvs}) body
+ = (new_uds, foldrBag add_let body dump_dbs)
+ -- This may delete fewer variables
+ -- than in priciple possible
where
- (free_uds, (dict_binds, _)) = splitUDs bndrs uds
- add_let (bind,_) body = Let bind body
-
-splitUDs :: [CoreBndr]
- -> UsageDetails
- -> (UsageDetails, -- These don't mention the binders
- ProtoUsageDetails) -- These do
-
-splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
- calls = orig_calls})
-
- = if isEmptyBag dump_dbs && null dump_calls then
- -- Common case: binder doesn't affect floats
- (uds, ([],[]))
-
- else
- -- Binders bind some of the fvs of the floats
- (MkUD {dict_binds = free_dbs,
- calls = listToCallDetails free_calls},
- (bagToList dump_dbs, dump_calls)
- )
+ new_uds =
+ MkUD { dict_binds = free_dbs
+ , calls = free_calls
+ , ud_fvs = fvs `minusVarSet` bndr_set}
- where
bndr_set = mkVarSet bndrs
+ add_let (bind,_) body = Let bind body
- (free_dbs, dump_dbs, dump_idset)
- = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
+ (free_dbs, dump_dbs, dump_set)
+ = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
-- Important that it's foldl not foldr;
-- we're accumulating the set of dumped ids in dump_set
- -- Filter out any calls that mention things that are being dumped
- orig_call_list = callDetailsToList orig_calls
- (dump_calls, free_calls) = partition captured orig_call_list
- captured (id,tys,(dicts, fvs)) = fvs `intersectsVarSet` dump_idset
- || id `elemVarSet` dump_idset
+ free_calls = filterCalls dump_set orig_calls
dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
| dump_idset `intersectsVarSet` fvs -- Dump it
| otherwise -- Don't dump it
= (free_dbs `snocBag` db, dump_dbs, dump_idset)
+
+filterCalls :: VarSet -> CallDetails -> CallDetails
+-- Remove any calls that mention the variables
+filterCalls bs calls
+ = mapFM (\_ cs -> filter_calls cs) $
+ filterFM (\k _ -> not (k `elemVarSet` bs)) calls
+ where
+ filter_calls :: CallInfo -> CallInfo
+ filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
\end{code}
\begin{code}
type SpecM a = UniqSM a
-thenSM = thenUs
-returnSM = returnUs
-getUniqSM = getUniqueUs
-mapSM = mapUs
+initSM :: UniqSupply -> SpecM a -> a
initSM = initUs_
-mapAndCombineSM f [] = returnSM ([], emptyUDs)
-mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) ->
- mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
- returnSM (y:ys, uds1 `plusUDs` uds2)
+mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
+mapAndCombineSM _ [] = return ([], emptyUDs)
+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
+ (ys, uds2) <- mapAndCombineSM f xs
+ return (y:ys, uds1 `plusUDs` uds2)
cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
-- Clone the binders of the bind; return new bind with the cloned binders
-- Return the substitution to use for RHSs, and the one to use for the body
-cloneBindSM subst (NonRec bndr rhs)
- = getUs `thenUs` \ us ->
- let
- (subst', bndr') = cloneIdBndr subst us bndr
- in
- returnUs (subst, subst', NonRec bndr' rhs)
-
-cloneBindSM subst (Rec pairs)
- = getUs `thenUs` \ us ->
+cloneBindSM subst (NonRec bndr rhs) = do
+ us <- getUniqueSupplyM
+ let (subst', bndr') = cloneIdBndr subst us bndr
+ return (subst, subst', NonRec bndr' rhs)
+
+cloneBindSM subst (Rec pairs) = do
+ us <- getUniqueSupplyM
+ let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
+ return (subst', subst', Rec (bndrs' `zip` map snd pairs))
+
+cloneBinders :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
+cloneBinders subst bndrs = do
+ us <- getUniqueSupplyM
+ return (cloneIdBndrs subst us bndrs)
+
+newIdSM :: Id -> Type -> SpecM Id
+newIdSM old_id new_ty = do
+ uniq <- getUniqueM
let
- (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
- in
- returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
-
-cloneBinders subst bndrs
- = getUs `thenUs` \ us ->
- returnUs (cloneIdBndrs subst us bndrs)
-
-newIdSM old_id new_ty
- = getUniqSM `thenSM` \ uniq ->
- let
- -- Give the new Id a similar occurrence name to the old one
- name = idName old_id
- new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name)
- in
- returnSM new_id
+ -- Give the new Id a similar occurrence name to the old one
+ name = idName old_id
+ new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name)
+ return new_id
\end{code}
projects / ghc-hetmet.git / blobdiff