#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec )
-import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
- getIdSpecialisation, setIdSpecialisation,
- isSpecPragmaId,
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta,
+ mkForAllTys, tcCmpType
)
-import VarSet
-import VarEnv
-
-import Type ( Type, TyVarSubst, mkTyVarTy, splitSigmaTy, substTy,
- fullSubstTy, tyVarsOfType, tyVarsOfTypes,
- mkForAllTys, boxedTypeKind
- )
-import Var ( TyVar, mkSysTyVar, setVarUnique )
+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 CoreUtils ( IdSubst, SubstCoreExpr(..), exprFreeVars,
- substExpr, substId, substIds, coreExprType
- )
-import CoreLint ( beginPass, endPass )
-import PprCore () -- Instances
-import SpecEnv ( addToSpecEnv )
+import CoreUtils ( applyTypeToArgs )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
+import CoreLint ( showPass, endPass )
+import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs,
- getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
)
-import Name ( nameOccName )
+import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes )
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
-import Util ( zipEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
import Outputable
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram us binds
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
= do
- beginPass "Specialise"
+ showPass dflags "Specialise"
let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
returnSM (dumpAllDictBinds uds' binds'))
- endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) 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@(Type _) = returnSM (e, emptyUDs)
-specExpr e@(Var _) = returnSM (e, emptyUDs)
-
-specExpr e@(Con con args)
- = mapAndCombineSM specExpr args `thenSM` \ (args', uds) ->
- returnSM (Con con args', uds)
+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 expr@(App fun arg)
+specExpr subst expr@(App fun arg)
= go expr []
where
- go (App fun arg) args = specExpr arg `thenSM` \ (arg', uds_arg) ->
+ 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 = returnSM (Var f, mkCallUDs f args)
- go other args = specExpr other
+ 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 (mkLams bndrs body'', 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
-- and we don't want to split a lambda group with dumped bindings
- go bndrs (Lam bndr e) = go (bndr:bndrs) e
- go bndrs e = (reverse bndrs, e)
-
-specExpr (Case scrut case_bndr alts)
- = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
+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)
+ returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
+ (subst_alt, case_bndr') = simplBndr subst case_bndr
+ -- No need to clone case binder; it can't float like a let(rec)
+
spec_alt (con, args, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
+ = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
let
(uds', rhs'') = dumpUDs args uds rhs'
in
- returnSM ((con, args, 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 :: CoreBind
+specBind :: Subst -- Use this for RHSs
+ -> CoreBind
-> UsageDetails -- Info on how the scope of the binding
-> SpecM ([CoreBind], -- New bindings
UsageDetails) -- And info to pass upstream
-specBind bind@(NonRec bndr rhs) body_uds
- | isSpecPragmaId bndr -- Aha! A spec-pragma Id. Collect UDs from
- -- its RHS and discard it!
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ([], rhs_uds `plusUDs` body_uds)
-
-
-specBind bind body_uds
- = specBindItself bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
+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)
-- specBindItself deals with the RHS, specialising it according
-- to the calls found in the body (if any)
-specBindItself (NonRec bndr rhs) call_info
- = specDefn call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+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)
in
returnSM (new_bind, spec_uds)
-specBindItself (Rec pairs) call_info
- = mapSM (specDefn call_info) 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
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
+ && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have
+ -- stupid overloading that simply discard the dictionary
+
+-- 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' = mkLams rhs_bndrs (mkDictLets dict_binds body')
+ 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) = collectTyAndValBinders rhs
rhs_dicts = take n_dicts rhs_ids
rhs_bndrs = rhs_tyvars ++ rhs_dicts
body = mkLams (drop n_dicts rhs_ids) rhs_body
----------------------------------------------------------
-- Specialise to one particular call pattern
- spec_call :: ProtoUsageDetails -- From the original body, captured by
- -- the dictionary lambdas
- -> ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- 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 = mkLams spec_tyvars $
- mkApps rhs (map Type spec_tys ++ call_ds)
- spec_id_ty = mkForAllTys spec_tyvars (substTy ty_env tau)
- ty_env = zipVarEnv 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
- let
- arg_ds = mkTemplateLocals (map coreExprType call_ds)
- spec_env_rhs = mkLams arg_ds $
- mkTyApps (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
+ cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
let
- -- Only the overloaded tyvars should be free in the uds
- ty_env = mkVarEnv [ (rhs_tyvar, ty)
- | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
- ]
- dict_env = zipVarEnv rhs_dicts (map Done 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 (_PK_ ("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 = (CoreBind, IdOrTyVarSet)
+type DictBind = (CoreBind, VarSet)
-- The set is the free vars of the binding
-- both tyvars and dicts
emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
type ProtoUsageDetails = ([DictBind],
- [(Id, [Maybe Type], ([DictExpr], IdOrTyVarSet))]
+ [(Id, CallKey, ([DictExpr], VarSet))]
)
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- ([DictExpr], IdSet) -- Dict args and the free dicts
- -- free dicts does *not* include the main id itself
+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
+-- 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 }
+
+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, dict_fvs))
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts
+ = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
where
- dict_fvs = foldr (unionVarSet . exprFreeVars) emptyVarSet dicts
+ 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.
callDetailsToList calls = [ (id,tys,dicts)
| (id,fm) <- fmToList calls,
- (tys,dicts) <- fmToList fm
+ (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 (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 (unionVarSet . tyVarsOfTypes . snd) emptyVarSet 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, Type ty) <- tyvars `zip` args]
dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
mkDB bind = (bind, bind_fvs bind)
bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
-bind_fvs (Rec prs) = foldl delVarSet rhs_fvs (map fst prs)
+bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
where
- rhs_fvs = foldr (unionVarSet . exprFreeVars . snd) emptyVarSet prs
+ bndrs = map fst prs
+ rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
-addDictBind uds bind = uds { dict_binds = mkDB bind `consBag` dict_binds uds }
+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 (bind,_) binds = bind : binds
-mkDictBinds :: [DictBind] -> [CoreBind]
-mkDictBinds = map fst
-
-mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
-mkDictLets dbs body = foldr mk body dbs
- where
- mk (bind,_) e = Let bind e
-
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 :: [CoreBndr]
-> UsageDetails
= (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
-Given a type and value substitution, specUDs creates a specialised copy of
-the given UDs
-
-\begin{code}
-specUDs :: TyVarSubst -> IdSubst -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env dict_env (dbs, calls)
- = getUniqSupplySM `thenSM` \ us ->
- let
- ((us', dict_env'), dbs') = mapAccumL specDB (us, dict_env) dbs
- in
- setUniqSupplySM us' `thenSM_`
- returnSM (MkUD { dict_binds = listToBag dbs',
- calls = foldr (unionCalls . singleCall . inst_call dict_env')
- emptyFM calls
- })
- where
- inst_call dict_env (id, tys, (dicts,fvs)) = (id, map (inst_maybe_ty fvs) tys,
- map (substExpr tv_env dict_env fvs) dicts)
-
- inst_maybe_ty fvs Nothing = Nothing
- inst_maybe_ty fvs (Just ty) = Just (fullSubstTy tv_env fvs ty)
-
- specDB (us, dict_env) (NonRec bndr rhs, fvs)
- = ((us', dict_env'), mkDB (NonRec bndr' (substExpr tv_env dict_env fvs rhs)))
- where
- (dict_env', _, us', bndr') = substId clone_fn tv_env dict_env fvs us bndr
- -- Fudge the in_scope set a bit by using the free vars of
- -- the binding, and ignoring the one that comes back
-
- specDB (us, dict_env) (Rec prs, fvs)
- = ((us', dict_env'), mkDB (Rec (bndrs' `zip` rhss')))
- where
- (dict_env', _, us', bndrs') = substIds clone_fn tv_env dict_env fvs us (map fst prs)
- rhss' = [substExpr tv_env dict_env' fvs rhs | (_, rhs) <- prs]
-
- clone_fn _ us id = case splitUniqSupply us of
- (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupVarEnv env id of
- Nothing -> id
- Just id' -> id'
-
-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)
-
-----------------------------------------
type SpecM a = UniqSM a
thenSM = thenUs
-thenSM_ = thenUs_
returnSM = returnUs
getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
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
= getUniqSM `thenSM` \ uniq ->
let
-- Give the new Id a similar occurrence name to the old one
- new_id = mkUserLocal (nameOccName name) uniq new_ty
name = idName old_id
+ new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
in
returnSM new_id
-
-newTyVarSM
- = getUniqSM `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq boxedTypeKind)
\end{code}
projects / ghc-hetmet.git / blobdiff