%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-module Specialise (
- specProgram,
- idSpecVars
- ) where
+module Specialise ( specProgram ) where
#include "HsVersions.h"
-import MkId ( mkUserLocal )
-import Id ( Id, DictVar, idType, mkTemplateLocals,
-
- getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
-
- IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
- emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
-
- IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv, delOneFromIdEnv
- )
-
-import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
- tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
- )
-import TyCon ( TyCon )
-import TyVar ( TyVar, mkTyVar, mkSysTyVar,
- TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
- elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
- minusTyVarSet,
- TyVarEnv, mkTyVarEnv, delFromTyVarEnv
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal )
+import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta, isClassPred,
+ mkForAllTys, tcCmpType
)
-import Kind ( mkBoxedTypeKind )
+import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
+ simplBndr, simplBndrs,
+ substAndCloneId, substAndCloneIds, substAndCloneRecIds,
+ lookupIdSubst, substInScope
+ )
+import Var ( zapSpecPragmaId )
+import VarSet
+import VarEnv
import CoreSyn
-import FreeVars ( exprFreeVars )
-import PprCore () -- Instances
-import Name ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined )
-import SrcLoc ( noSrcLoc )
-import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
+import CoreUtils ( applyTypeToArgs )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
+import CoreLint ( showPass, endPass )
+import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
)
-import Unique ( mkAlphaTyVarUnique )
+import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool, catMaybes )
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
-import Util ( zipEqual )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
import Outputable
-
+import FastString
infixr 9 `thenSM`
\end{code}
then I think it's unlikely. In any case, we simply don't accumulate such
partial applications.)
-There's a choice of whether to collect details of all *polymorphic* functions
-or simply all *overloaded* ones. How to sort this out?
- Pass in a predicate on the function to say if it is "interesting"?
- This is dependent on the user flags: SpecialiseOverloaded
- SpecialiseUnboxed
- SpecialiseAll
STEP 2: EQUIVALENCES
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding]
-specProgram us binds
- = initSM us (go binds `thenSM` \ (binds', uds') ->
- returnSM (dumpAllDictBinds uds' binds')
- )
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
+ = do
+ showPass dflags "Specialise"
+
+ let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
+ returnSM (dumpAllDictBinds uds' binds'))
+
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
+
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
+ (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
+
+ return binds'
where
+ -- We need to start with a Subst that knows all the things
+ -- that are in scope, so that the substitution engine doesn't
+ -- 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 = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
+
go [] = returnSM ([], emptyUDs)
- go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
- specBind bind uds `thenSM` \ (bind', uds') ->
+ go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
+ specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
\end{code}
%************************************************************************
\begin{code}
-specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
+specVar :: Subst -> Id -> CoreExpr
+specVar subst v = case lookupIdSubst subst v of
+ DoneEx e -> e
+ DoneId v _ -> Var v
+
+specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+-- We carry a substitution down:
+-- a) we must clone any binding that might flaot outwards,
+-- to avoid name clashes
+-- b) we carry a type substitution to use when analysing
+-- the RHS of specialised bindings (no type-let!)
---------------- First the easy cases --------------------
-specExpr e@(Var _) = returnSM (e, emptyUDs)
-specExpr e@(Lit _) = returnSM (e, emptyUDs)
-specExpr e@(Con _ _) = returnSM (e, emptyUDs)
-specExpr e@(Prim _ _) = returnSM (e, emptyUDs)
+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 (Note note body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (Note note body', uds)
+specExpr subst (Note note body)
+ = specExpr subst body `thenSM` \ (body', uds) ->
+ returnSM (Note (specNote subst note) body', uds)
---------------- Applications might generate a call instance --------------------
-specExpr e@(App fun arg)
- = go fun [arg]
+specExpr subst expr@(App fun arg)
+ = go expr []
where
- go (App fun arg) args = go fun (arg:args)
- go (Var f) args = returnSM (e, mkCallUDs f args)
- go other args = specExpr other `thenSM` \ (e', uds) ->
- returnSM (foldl App e' args, uds)
+ 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 (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
---------------- Lambda/case require dumping of usage details --------------------
-specExpr e@(Lam _ _)
- = specExpr body `thenSM` \ (body', uds) ->
+specExpr subst e@(Lam _ _)
+ = specExpr subst' body `thenSM` \ (body', uds) ->
let
- (filtered_uds, body'') = dumpUDs bndrs uds body'
+ (filtered_uds, body'') = dumpUDs bndrs' uds body'
in
- returnSM (foldr Lam body'' bndrs, filtered_uds)
+ returnSM (mkLams bndrs' body'', filtered_uds)
where
- (bndrs, body) = go [] e
-
+ (bndrs, body) = collectBinders e
+ (subst', bndrs') = simplBndrs subst bndrs
-- More efficient to collect a group of binders together all at once
- go bndrs (Lam bndr e) = go (bndr:bndrs) e
- go bndrs e = (reverse bndrs, e)
-
+ -- and we don't want to split a lambda group with dumped bindings
-specExpr (Case scrut alts)
- = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
- spec_alts alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts)
+specExpr subst (Case scrut case_bndr alts)
+ = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
+ mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
+ returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
- spec_alts (AlgAlts alts deflt)
- = mapAndCombineSM spec_alg_alt alts `thenSM` \ (alts', uds1) ->
- spec_deflt deflt `thenSM` \ (deflt', uds2) ->
- returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
-
- spec_alts (PrimAlts alts deflt)
- = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) ->
- spec_deflt deflt `thenSM` \ (deflt', uds2) ->
- returnSM (PrimAlts alts' deflt', uds1 `plusUDs` uds2)
-
- spec_alg_alt (con, args, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- let
- (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
- in
- returnSM ((con, args, rhs''), uds')
-
- spec_prim_alt (lit, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- returnSM ((lit, rhs'), uds)
+ (subst_alt, case_bndr') = simplBndr subst case_bndr
+ -- No need to clone case binder; it can't float like a let(rec)
- spec_deflt NoDefault = returnSM (NoDefault, emptyUDs)
- spec_deflt (BindDefault arg rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
+ spec_alt (con, args, rhs)
+ = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
let
- (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs'
+ (uds', rhs'') = dumpUDs args uds rhs'
in
- returnSM (BindDefault arg rhs'', uds')
+ returnSM ((con, args', rhs''), uds')
+ where
+ (subst_rhs, args') = simplBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
-specExpr (Let bind body)
- = -- Deal with the body
- specExpr body `thenSM` \ (body', body_uds) ->
+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) ->
-- Deal with the bindings
- specBind bind body_uds `thenSM` \ (binds', uds) ->
+ specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) ->
-- All done
returnSM (foldr Let body' binds', uds)
+
+-- Must apply the type substitution to coerceions
+specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
+specNote subst note = note
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-specBind :: CoreBinding
+specBind :: Subst -- Use this for RHSs
+ -> CoreBind
-> UsageDetails -- Info on how the scope of the binding
- -> SpecM ([CoreBinding], -- New bindings
+ -> SpecM ([CoreBind], -- New bindings
UsageDetails) -- And info to pass upstream
-specBind (NonRec bndr rhs) body_uds
- | isDictTy (idType bndr)
- = -- It's a dictionary binding
- -- Pick it up and float it outwards.
- specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- let
- all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs'
- in
- returnSM ([], all_uds)
-
- | isSpecPragmaId bndr
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ([], rhs_uds `plusUDs` body_uds)
-
- | otherwise
- = -- Deal with the RHS, specialising it according
- -- to the calls found in the body
- specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+specBind rhs_subst bind body_uds
+ = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
let
- (all_uds, (dict_binds, dump_calls))
- = splitUDs [ValBinder bndr]
- (body_uds `plusUDs` spec_uds)
+ bndrs = bindersOf bind
+ all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
-- It's important that the `plusUDs` is this way round,
-- because body_uds may bind dictionaries that are
-- used in the calls passed to specDefn. So the
- -- dictionary bindings in spec_uds may mention
+ -- dictionary bindings in bind_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 }
+ where
+ bind_prs (NonRec b r) = [(b,r)]
+ bind_prs (Rec prs) = prs
+
+ dbsToPairs [] = []
+ dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
- -- If we make specialisations then we Rec the whole lot together
- -- If not, leave it as a NonRec
+-- 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) ->
+ 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 : mkDictBinds dict_binds, all_uds )
+ returnSM (new_bind, spec_uds)
-specBind (Rec pairs) body_uds
- = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff ->
+specBindItself rhs_subst (Rec pairs) call_info
+ = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff ->
let
(pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
spec_defns = concat spec_defns_s
spec_uds = plusUDList spec_uds_s
-
- (all_uds, (dict_binds, dump_calls))
- = splitUDs (map (ValBinder . fst) pairs)
- (body_uds `plusUDs` spec_uds)
- -- See notes for non-rec case
-
- new_bind = Rec (spec_defns ++ pairs')
+ new_bind = Rec (spec_defns ++ pairs')
in
- returnSM ( new_bind : mkDictBinds dict_binds, all_uds )
+ returnSM (new_bind, spec_uds)
-specDefn :: CallDetails -- Info on how it is used in its scope
+
+specDefn :: Subst -- Subst to use for RHS
+ -> CallDetails -- Info on how it is used in its scope
-> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
-> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
-- the Id may now have specialisations attached
UsageDetails -- Stuff to fling upwards from the RHS and its
) -- specialised versions
-specDefn calls (fn, rhs)
+specDefn subst calls (fn, rhs)
-- The first case is the interesting one
- | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
- && n_dicts <= length rhs_bndrs -- and enough dict args
- && not (null calls_for_me) -- And there are some calls to specialise
+ | 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
+ && notNull calls_for_me -- And there are some calls to specialise
+
+-- At one time I tried not specialising small functions
+-- but sometimes there are big functions marked INLINE
+-- that we'd like to specialise. In particular, dictionary
+-- functions, which Marcin is keen to inline
+-- && not (certainlyWillInline fn) -- And it's not small
+ -- If it's small, it's better just to inline
+ -- it than to construct lots of specialisations
= -- Specialise the body of the function
- specExpr body `thenSM` \ (body', body_uds) ->
- let
- (float_uds, bound_uds@(dict_binds,_)) = splitUDs rhs_bndrs body_uds
- in
+ specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
-- Make a specialised version for each call in calls_for_me
- mapSM (spec_call bound_uds) calls_for_me `thenSM` \ stuff ->
+ mapSM spec_call calls_for_me `thenSM` \ stuff ->
let
- (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
+ (spec_defns, spec_uds, spec_rules) = unzip3 stuff
- fn' = addIdSpecialisations fn spec_env_stuff
- rhs' = foldr Lam (mkDictLets dict_binds body') rhs_bndrs
+ fn' = addIdSpecialisations zapped_fn spec_rules
in
returnSM ((fn',rhs'),
spec_defns,
- float_uds `plusUDs` plusUDList spec_uds)
+ rhs_uds `plusUDs` plusUDList spec_uds)
| otherwise -- No calls or RHS doesn't fit our preconceptions
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ((fn, rhs'), [], rhs_uds)
+ = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ((zapped_fn, rhs'), [], rhs_uds)
where
- fn_type = idType fn
- (tyvars, theta, tau) = splitSigmaTy fn_type
- n_tyvars = length tyvars
- n_dicts = length theta
+ zapped_fn = zapSpecPragmaId fn
+ -- If the fn is a SpecPragmaId, make it discardable
+ -- It's role as a holder for a call instance is o'er
+ -- But it might be alive for some other reason by now.
+
+ fn_type = idType fn
+ (tyvars, theta, _) = tcSplitSigmaTy fn_type
+ n_tyvars = length tyvars
+ n_dicts = length theta
+
+ -- It's important that we "see past" any INLINE pragma
+ -- else we'll fail to specialise an INLINE thing
+ (inline_me, rhs') = dropInline rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
- (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
rhs_dicts = take n_dicts rhs_ids
- rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
- body = mkValLam (drop n_dicts rhs_ids) rhs_body
+ rhs_bndrs = rhs_tyvars ++ rhs_dicts
+ body = mkLams (drop n_dicts rhs_ids) rhs_body
-- Glue back on the non-dict lambdas
calls_for_me = case lookupFM calls fn of
----------------------------------------------------------
-- Specialise to one particular call pattern
- spec_call :: ProtoUsageDetails -- From the original body, captured by
- -- the dictionary lambdas
- -> ([Maybe Type], [DictVar]) -- Call instance
- -> SpecM ((Id,CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([TyVar], [Type], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call bound_uds (call_ts, call_ds)
- = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+ spec_call :: (CallKey, ([DictExpr], VarSet)) -- Call instance
+ -> 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 )
-- Calls are only recorded for properly-saturated applications
- -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2]
-
- -- Construct the new binding
- -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
- -- and the type of this binder
- let
- mk_spec_ty Nothing = newTyVarSM `thenSM` \ tyvar ->
- returnSM (Just tyvar, mkTyVarTy tyvar)
- mk_spec_ty (Just ty) = returnSM (Nothing, ty)
- in
- mapSM mk_spec_ty call_ts `thenSM` \ stuff ->
+ -- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
+ -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
+
+ -- Construct the new binding
+ -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
+ -- PLUS the usage-details
+ -- { d1' = dx1; d2' = dx2 }
+ -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
+ --
+ -- Note that the substitution is applied to the whole thing.
+ -- This is convenient, but just slightly fragile. Notably:
+ -- * There had better be no name clashes in a/b/c/d
+ --
let
- (maybe_spec_tyvars, spec_tys) = unzip stuff
- spec_tyvars = catMaybes maybe_spec_tyvars
- spec_rhs = mkTyLam spec_tyvars $
- mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
- spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
- ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys)
+ -- poly_tyvars = [b,d] in the example above
+ -- spec_tyvars = [a,c]
+ -- ty_args = [t1,b,t3,d]
+ poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+ spec_tyvars = [tv | (tv, Just _) <- rhs_tyvars `zip` call_ts]
+ 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
+ rhs_subst = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
in
-
- newIdSM fn spec_id_ty `thenSM` \ spec_f ->
-
-
- -- Construct the stuff for f's spec env
- -- [b,d] [t1,b,t3,d] |-> \d1 d2 -> f1 b d
- -- The only awkward bit is that d1,d2 might well be global
- -- dictionaries, so it's tidier to make new local variables
- -- for the lambdas in the RHS, rather than lambda-bind the
- -- dictionaries themselves.
- --
- -- In fact we use the standard template locals, so that the
- -- they don't need to be "tidied" before putting in interface files
+ cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
let
- arg_ds = mkTemplateLocals (map idType call_ds)
- spec_env_rhs = mkValLam arg_ds $
- mkTyApp (Var spec_f) $
- map mkTyVarTy spec_tyvars
- spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs)
- in
-
- -- Specialise the UDs from f's RHS
- let
- -- Only the overloaded tyvars should be free in the uds
- ty_env = [ (rhs_tyvar,ty)
- | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
- ]
- dict_env = zipEqual "specUDs2" rhs_dicts call_ds
+ inst_args = ty_args ++ map Var rhs_dicts'
+
+ -- Figure out the type of the specialised function
+ spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
in
- specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds ->
+ newIdSM fn spec_id_ty `thenSM` \ spec_f ->
+ specExpr rhs_subst' (mkLams poly_tyvars body) `thenSM` \ (spec_rhs, rhs_uds) ->
+ 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 = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+ AlwaysActive
+ (poly_tyvars ++ rhs_dicts')
+ inst_args
+ (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+
+ -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
+ -- the original function said INLINE, the specialised copies won't.
+ -- The idea is that the point of inlining was precisely to specialise
+ -- the function at its call site, and that's not so important for the
+ -- specialised copies. But it still smells like an ad hoc decision.
- returnSM ((spec_f, spec_rhs),
- spec_uds,
- spec_env_info
- )
+ in
+ returnSM ((spec_f, spec_rhs),
+ 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)
+ | otherwise = zipEqual doc xs ys
+
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs = (False, rhs)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type FreeDicts = IdSet
-
data UsageDetails
= MkUD {
dict_binds :: !(Bag DictBind),
-- The order is important;
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
-- (Remember, Bags preserve order in GHC.)
- -- The FreeDicts is the free vars of the RHS
calls :: !CallDetails
}
-type DictBind = (DictVar, CoreExpr, TyVarSet, FreeDicts)
- -- The FreeDicts are the free dictionaries (only)
- -- of the RHS of the dictionary bindings
- -- Similarly the TyVarSet
+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, [Maybe Type], [DictVar])]
+ [(Id, CallKey, ([DictExpr], VarSet))]
)
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- [DictVar] -- Dict args
+newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument
+type CallInfo = FiniteMap CallKey
+ ([DictExpr], VarSet) -- Dict args and the vars of the whole
+ -- call (including tyvars)
+ -- [*not* include the main id itself, of course]
-- The finite maps eliminate duplicates
-- The list of types and dictionaries is guaranteed to
-- match the type of f
-callDetailsToList calls = [ (id,tys,dicts)
- | (id,fm) <- fmToList calls,
- (tys,dicts) <- fmToList fm
- ]
+-- 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 }
-listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls
+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 (Just t1) (Just t2) = tcCmpType t1 t2
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusFM_C plusFM c1 c2
-singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts)
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts
+ = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
+ where
+ call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+ tys_fvs = tyVarsOfTypes (catMaybes tys)
+ -- The type args (tys) are guaranteed to be part of the dictionary
+ -- types, because they are just the constrained types,
+ -- and the dictionary is therefore sure to be bound
+ -- inside the binding for any type variables free in the type;
+ -- hence it's safe to neglect tyvars free in tys when making
+ -- the free-var set for this call
+ -- BUT I don't trust this reasoning; play safe and include tys_fvs
+ --
+ -- 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 f args
+mkCallUDs subst f args
| null theta
- || length spec_tys /= n_tyvars
- || length dicts /= n_dicts
- = emptyUDs -- Not overloaded
+ || not (all isClassPred theta)
+ -- Only specialise if all overloading is on class params.
+ -- In ptic, with implicit params, the type 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) 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
+ -- of the function that overlaps.
+ = emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
= MkUD {dict_binds = emptyBag,
- calls = singleCall (f, spec_tys, dicts)
+ calls = singleCall f spec_tys dicts
}
where
- (tyvars, theta, tau) = splitSigmaTy (idType f)
- constrained_tyvars = foldr (unionTyVarSets . tyVarsOfTypes . snd) emptyTyVarSet theta
- n_tyvars = length tyvars
- n_dicts = length theta
+ (tyvars, theta, _) = tcSplitSigmaTy (idType f)
+ constrained_tyvars = tyVarsOfTheta theta
+ n_tyvars = length tyvars
+ n_dicts = length theta
- spec_tys = [mk_spec_ty tv ty | (tv, TyArg ty) <- tyvars `zip` args]
- dicts = [d | (_, VarArg d) <- theta `zip` (drop n_tyvars args)]
+ spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
+ dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
- mk_spec_ty tyvar ty | tyvar `elementOfTyVarSet` constrained_tyvars
- = Just ty
- | otherwise
- = Nothing
+ mk_spec_ty tyvar ty
+ | tyvar `elemVarSet` constrained_tyvars = Just ty
+ | otherwise = Nothing
------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
plusUDs (MkUD {dict_binds = db1, calls = calls1})
(MkUD {dict_binds = db2, calls = calls2})
- = MkUD {dict_binds, calls}
+ = MkUD {dict_binds = d, calls = c}
where
- dict_binds = db1 `unionBags` db2
- calls = calls1 `unionCalls` calls2
+ d = db1 `unionBags` db2
+ c = calls1 `unionCalls` calls2
plusUDList = foldr plusUDs emptyUDs
-mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs)
- where
- db_ftvs = tyVarsOfType (idType dict) -- Superset of RHS fvs
- db_fvs = dictRhsFVs rhs
+-- zapCalls deletes calls to ids from uds
+zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
+
+mkDB bind = (bind, bind_fvs bind)
-addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
+bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
+ where
+ bndrs = map fst prs
+ rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
+
+addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
= foldrBag add binds dbs
where
- add (dict,rhs,_,_) binds = NonRec dict rhs : binds
-
-mkDictBinds :: [DictBind] -> [CoreBinding]
-mkDictBinds = map (\(d,r,_,_) -> NonRec d r)
-
-mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
-mkDictLets dbs body = foldr mk body dbs
- where
- mk (d,r,_,_) e = Let (NonRec d r) e
+ add (bind,_) binds = bind : binds
-dumpUDs :: [CoreBinder]
+dumpUDs :: [CoreBndr]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
dumpUDs bndrs uds body
- = (free_uds, mkDictLets dict_binds 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 :: [CoreBinder]
+splitUDs :: [CoreBndr]
-> UsageDetails
-> (UsageDetails, -- These don't mention the binders
ProtoUsageDetails) -- These do
)
where
- tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
- id_set = mkIdSet [id | ValBinder id <- bndrs]
+ bndr_set = mkVarSet bndrs
(free_dbs, dump_dbs, dump_idset)
- = foldlBag dump_db (emptyBag, emptyBag, id_set) orig_dbs
+ = 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
- -- Don't need to worry about the tyvars because the dicts will
- -- spot the captured ones; any fully polymorphic arguments will
- -- be Nothings in the call details
- orig_call_list = callDetailsToList orig_calls
- (dump_calls, free_calls) = partition captured orig_call_list
- captured (id,tys,dicts) = any (`elementOfIdSet` dump_idset) (id:dicts)
-
- dump_db (free_dbs, dump_dbs, dump_idset) db@(dict, rhs, ftvs, fvs)
- | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
- && isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)
- = (free_dbs `snocBag` db, dump_dbs, dump_idset)
+ 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
- | otherwise -- Dump it
+ dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+ | dump_idset `intersectsVarSet` fvs -- Dump it
= (free_dbs, dump_dbs `snocBag` db,
- dump_idset `addOneToIdSet` dict)
-\end{code}
-
-Given a type and value substitution, specUDs creates a specialised copy of
-the given UDs
-
-\begin{code}
-specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env_list dict_env_list (dbs, calls)
- = specDBs dict_env_list dbs `thenSM` \ (dict_env_list', dbs') ->
- let
- dict_env = mkIdEnv dict_env_list'
- in
- returnSM (MkUD { dict_binds = dbs',
- calls = listToCallDetails (map (inst_call dict_env) calls)
- })
- where
- bound_tyvars = mkTyVarSet (map fst tv_env_list)
- tv_env = mkTyVarEnv tv_env_list -- Doesn't change
+ dump_idset `unionVarSet` mkVarSet (bindersOf bind))
- inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys,
- map (lookupId dict_env) dicts)
-
- inst_maybe_ty Nothing = Nothing
- inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty)
-
- specDBs dict_env []
- = returnSM (dict_env, emptyBag)
- specDBs dict_env ((dict, rhs, ftvs, fvs) : dbs)
- = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
- let
- rhs' = foldl App (foldr Lam rhs (t_bndrs ++ d_bndrs)) (t_args ++ d_args)
- (t_bndrs, t_args) = unzip [(TyBinder tv, TyArg ty) | (tv,ty) <- tv_env_list,
- tv `elementOfTyVarSet` ftvs]
- (d_bndrs, d_args) = unzip [(ValBinder d, VarArg d') | (d,d') <- dict_env,
- d `elementOfIdSet` fvs]
- dict_env' = (dict,dict') : dict_env
- ftvs' = tyVarsOfTypes [ty | TyArg ty <- t_args] `unionTyVarSets`
- (ftvs `minusTyVarSet` bound_tyvars)
- fvs' = mkIdSet [d | VarArg d <- d_args] `unionIdSets`
- (fvs `minusIdSet` mkIdSet [d | ValBinder d <- d_bndrs])
- in
- specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
- returnSM ( dict_env'', (dict', rhs', ftvs', fvs') `consBag` dbs' )
+ | otherwise -- Don't dump it
+ = (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
+
%************************************************************************
%* *
\subsubsection{Boring helper functions}
%************************************************************************
\begin{code}
-tyVarTemplates :: [TyVar]
-tyVarTemplates = map mk [1..]
- where
- mk i = mkTyVar (mkSysLocalName uniq occ noSrcLoc) mkBoxedTypeKind
- where
- uniq = mkAlphaTyVarUnique i
- occ = _PK_ ("$t" ++ show i)
-\end{code}
-
-\begin{code}
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupIdEnv env id of
- Nothing -> id
- Just id' -> id'
-
-dictRhsFVs :: CoreExpr -> IdSet
-dictRhsFVs e = exprFreeVars isLocallyDefined e
-
-addIdSpecialisations id spec_stuff
- = (if not (null errs) then
- pprTrace "Duplicate specialisations" (vcat (map ppr errs))
- else \x -> x
- )
- setIdSpecialisation id new_spec_env
- where
- (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff
-
- add (tyvars, tys, template) (spec_env, errs)
- = case addToSpecEnv True spec_env tyvars tys template of
- Succeeded spec_env' -> (spec_env', errs)
- Failed err -> (spec_env, err:errs)
-
--- Given an Id, isSpecVars returns all its specialisations.
--- We extract these from its SpecEnv.
--- This is used by the occurrence analyser and free-var finder;
--- we regard an Id's specialisations as free in the Id's definition.
-
-idSpecVars :: Id -> [Id]
-idSpecVars id
- = map get_spec (specEnvValues (getIdSpecialisation id))
- where
- -- get_spec is another cheapo function like dictRhsFVs
- -- It knows what these specialisation temlates look like,
- -- and just goes for the jugular
- get_spec (App f _) = get_spec f
- get_spec (Lam _ b) = get_spec b
- get_spec (Var v) = v
-
-----------------------------------------
type SpecM a = UniqSM a
thenSM = thenUs
returnSM = returnUs
-getUniqSM = getUnique
+getUniqSM = getUniqueUs
mapSM = mapUs
-initSM = initUs
+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)
+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') = substAndCloneId subst us bndr
+ in
+ returnUs (subst, subst', NonRec bndr' rhs)
+
+cloneBindSM subst (Rec pairs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
+ in
+ returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
+
+cloneBinders subst bndrs
+ = getUs `thenUs` \ us ->
+ returnUs (substAndCloneIds subst us bndrs)
+
newIdSM old_id new_ty
- = getUnique `thenSM` \ uniq ->
- returnSM (mkUserLocal (getOccName old_id)
- uniq
- new_ty
- (getSrcLoc old_id)
- )
-
-newTyVarSM
- = getUnique `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq mkBoxedTypeKind)
+ = 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 (getSrcLoc name)
+ in
+ returnSM new_id
\end{code}