X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=055c85821a0eaceb7807ddd9de67539612fc62e1;hb=6246f5738bc482423e51342eb117a40539be790e;hp=7a0d8bcdb14c913513f030fb0a0e946f76afcfb5;hpb=940524aec90652b5ef81789c9a453c57c0e42cc9;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 7a0d8bc..055c858 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,6 +4,12 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} +-- 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 +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Specialise ( specProgram ) where #include "HsVersions.h" @@ -29,23 +35,19 @@ import CoreLint ( showPass, endPass ) 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} %************************************************************************ @@ -576,12 +578,12 @@ Hence, the invariant is this: \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' @@ -595,12 +597,12 @@ specProgram dflags us binds -- 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} %************************************************************************ @@ -621,76 +623,73 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) -- 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} %************************************************************************ @@ -707,70 +706,72 @@ specBind :: Subst -- Use this for RHSs 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 @@ -783,31 +784,33 @@ specDefn :: Subst -- Subst to use for RHS specDefn subst calls (fn, rhs) -- The first case is the interesting one - | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas - && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args + | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas + && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args && notNull calls_for_me -- And there are some calls to specialise -- && 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 - = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> - returnSM ((fn, rhs'), [], rhs_uds) + = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn ) + -- Note [Specialisation shape] + (do { (rhs', rhs_uds) <- specExpr subst rhs + ; return ((fn, rhs'), [], rhs_uds) }) where fn_type = idType fn @@ -822,7 +825,6 @@ specDefn subst calls (fn, rhs) (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 @@ -836,8 +838,8 @@ specDefn subst calls (fn, rhs) -> 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 @@ -862,10 +864,10 @@ specDefn subst calls (fn, 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' @@ -876,14 +878,15 @@ specDefn subst calls (fn, rhs) = (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_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) - AlwaysActive (idName fn) + inline_prag -- Note [Auto-specialisation and RULES] + (idName fn) (poly_tyvars ++ rhs_dicts') inst_args (mkVarApps (Var spec_f) app_args) @@ -893,15 +896,73 @@ specDefn subst calls (fn, rhs) 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 - | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs) + | 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]) | otherwise = zipEqual doc xs ys \end{code} +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised rule. +So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also +not be active until phase 2. + + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +This doesn't always work. One example I came across was htis: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly exapmle, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + + Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We transfer to the specialised function any INLINE stuff from the @@ -949,20 +1010,27 @@ data UsageDetails -- 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 @@ -975,25 +1043,30 @@ type CallInfo = FiniteMap CallKey -- 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) @@ -1007,17 +1080,7 @@ singleCall id tys dicts -- -- 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) @@ -1026,7 +1089,7 @@ mkCallUDs subst f args -- *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 @@ -1034,9 +1097,7 @@ mkCallUDs subst f args = 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 @@ -1052,26 +1113,31 @@ mkCallUDs subst f args ------------------------------------------------------------ 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 @@ -1079,8 +1145,14 @@ pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr -- 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 @@ -1089,44 +1161,23 @@ dumpAllDictBinds (MkUD {dict_binds = dbs}) binds dumpUDs :: [CoreBndr] -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr) -dumpUDs bndrs uds body - = (free_uds, foldr add_let body dict_binds) - 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) - ) - +dumpUDs bndrs (MkUD { dict_binds = orig_dbs + , calls = orig_calls + , ud_fvs = fvs}) body + = (MkUD { dict_binds = free_dbs + , calls = free_calls + , ud_fvs = fvs `minusVarSet` bndr_set}, -- This may delete fewer variables + foldrBag add_let body dump_dbs) -- than in priciple possible 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 @@ -1135,6 +1186,15 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, | 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 _ -> k `elemVarSet` bs) calls + where + filter_calls :: CallInfo -> CallInfo + filter_calls = filterFM (\_ (_, fvs) -> fvs `intersectsVarSet` bs) \end{code} @@ -1147,46 +1207,41 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, \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}