#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules )
-import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
- idSpecialisation, setIdNoDiscard, isExportedId,
- modifyIdInfo, idUnfolding
+import DynFlags ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal )
+import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta, isClassPred,
+ tcCmpType, isUnLiftedType
)
-import IdInfo ( zapSpecPragInfo )
-import VarSet
-import VarEnv
-
-import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
- mkForAllTys, boxedTypeKind
- )
-import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList,
- substId, substAndCloneId, substAndCloneIds, lookupIdSubst
+import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
+ substBndr, substBndrs, substTy, substInScope,
+ cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
)
-import Var ( TyVar, mkSysTyVar, setVarUnique )
import VarSet
import VarEnv
import CoreSyn
-import CoreUtils ( applyTypeToArgs )
-import CoreUnfold ( certainlyWillInline )
-import CoreFVs ( exprFreeVars, exprsFreeVars )
-import CoreLint ( beginPass, endPass )
-import PprCore ( pprCoreRules )
-import Rules ( addIdSpecialisations )
-
+import CoreUtils ( applyTypeToArgs, mkPiTypes )
+import CoreFVs ( exprFreeVars, exprsFreeVars, idRuleVars )
+import CoreTidy ( tidyRules )
+import CoreLint ( showPass, endPass )
+import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
+import PprCore ( pprRules )
import UniqSupply ( UniqSupply,
- UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
- getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
+import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes )
-import ErrUtils ( dumpIfSet )
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
import Outputable
-
+import FastString
infixr 9 `thenSM`
\end{code}
%************************************************************************
\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 opt_D_dump_rules "Top-level specialisations"
- (vcat (map dump_specs (concat (map bindersOf binds'))))
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
+ (pprRules (tidyRules emptyTidyEnv (rulesOfBinds 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 = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
+
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
- specBind emptySubst bind uds `thenSM` \ (bind', uds') ->
+ specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
\end{code}
%************************************************************************
\begin{code}
specVar :: Subst -> Id -> CoreExpr
-specVar subst v = case lookupIdSubst subst v of
- DoneEx e -> e
- DoneId v _ -> Var v
+specVar subst v = lookupIdSubst subst v
specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
-- We carry a substitution down:
returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
go (Var f) args = case specVar subst f of
- Var f' -> returnSM (Var f', mkCallUDs f' args)
+ Var f' -> returnSM (Var f', mkCallUDs subst f' args)
e' -> returnSM (e', emptyUDs) -- I don't expect this!
go other args = specExpr subst other
-- 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 alts)
- = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
+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' alts', uds_scrut `plusUDs` uds_alts)
+ returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
where
- (subst_alt, case_bndr') = substId subst case_bndr
+ (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) ->
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
- && not (certainlyWillInline fn) -- And it's not small
+ | 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
-- Make a specialised version for each call in calls_for_me
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 zapped_fn spec_env_stuff
+ fn' = addIdSpecialisations fn spec_rules
in
returnSM ((fn',rhs'),
spec_defns,
| otherwise -- No calls or RHS doesn't fit our preconceptions
= specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ((zapped_fn, rhs'), [], rhs_uds)
+ returnSM ((fn, rhs'), [], rhs_uds)
where
- zapped_fn = modifyIdInfo zapSpecPragInfo 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
- fn_type = idType fn
- (tyvars, theta, tau) = splitSigmaTy fn_type
- n_tyvars = length tyvars
- n_dicts = length theta
+ (rhs_tyvars, rhs_ids, rhs_body)
+ = collectTyAndValBinders (dropInline rhs)
+ -- It's important that we "see past" any INLINE pragma
+ -- else we'll fail to specialise an INLINE thing
- (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 :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance
- -> SpecM ((Id,CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call (call_ts, (call_ds, call_fvs))
- = 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
-- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
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]
+ rhs_subst = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
in
cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
let
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)
+ body_ty = applyTypeToArgs rhs fn_type inst_args
+ (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted
+ | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs
+ = (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 poly_tyvars body) `thenSM` \ (spec_rhs, rhs_uds) ->
+ specExpr rhs_subst' (mkLams lam_args 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 = (poly_tyvars ++ rhs_dicts',
- inst_args,
- mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+ spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+ AlwaysActive (idName fn)
+ (poly_tyvars ++ rhs_dicts')
+ inst_args
+ (mkVarApps (Var spec_f) app_args)
-- 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.
+
in
- returnSM ((spec_f, spec_rhs),
+ returnSM ((spec_f, spec_rhs),
final_uds,
spec_env_rule)
where
my_zipEqual doc xs ys
- | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
- | otherwise = 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 -> CoreExpr
+dropInline (Note InlineMe rhs) = rhs
+dropInline rhs = rhs
\end{code}
%************************************************************************
emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
type ProtoUsageDetails = ([DictBind],
- [(Id, [Maybe Type], ([DictExpr], VarSet))]
+ [(Id, CallKey, ([DictExpr], VarSet))]
)
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
+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 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, [Maybe Type], [DictExpr]) -> CallDetails
-singleCall (id, tys, dicts)
- = unitFM id (unitFM tys (dicts, call_fvs))
+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)
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 (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) 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
+ -- 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 = tyVarsOfTheta 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)]
- mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
- = Just ty
- | otherwise
- = Nothing
+ mk_spec_ty tyvar ty
+ | tyvar `elemVarSet` constrained_tyvars = Just ty
+ | otherwise = Nothing
------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
mkDB bind = (bind, bind_fvs bind)
-bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+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 [exprFreeVars rhs | (bndr,rhs) <- prs]
+ rhs_fvs = unionVarSets (map pair_fvs prs)
+
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+ -- Don't forget variables mentioned in the
+ -- rules of the bndr. C.f. OccAnal.addRuleUsage
+
addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
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 `unionVarSet` mkVarSet (bindersOf bind))
+ extendVarSetList dump_idset (bindersOf bind))
| otherwise -- Don't dump it
= (free_dbs `snocBag` db, dump_dbs, dump_idset)
%************************************************************************
\begin{code}
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupVarEnv env id of
- Nothing -> id
- Just id' -> id'
-
-----------------------------------------
type SpecM a = UniqSM a
thenSM = thenUs
-thenSM_ = thenUs_
returnSM = returnUs
getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
mapSM = mapUs
initSM = initUs_
-- 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 ->
+ = getUs `thenUs` \ us ->
let
- (subst', us', bndr') = substAndCloneId subst us bndr
+ (subst', bndr') = cloneIdBndr subst us bndr
in
- setUs us' `thenUs_`
returnUs (subst, subst', NonRec bndr' rhs)
cloneBindSM subst (Rec pairs)
- = getUs `thenUs` \ us ->
+ = getUs `thenUs` \ us ->
let
- (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
+ (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
in
- setUs us' `thenUs_`
returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
cloneBinders subst bndrs
- = getUs `thenUs` \ us ->
- let
- (subst', us', bndrs') = substAndCloneIds subst us bndrs
- in
- setUs us' `thenUs_`
- returnUs (subst', bndrs')
-
+ = getUs `thenUs` \ us ->
+ returnUs (cloneIdBndrs subst us bndrs)
newIdSM old_id new_ty
= getUniqSM `thenSM` \ uniq ->
-- 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)
-
- -- If the old Id was exported, make the new one non-discardable,
- -- else we will discard it since it doesn't seem to be called.
- new_id' | isExportedId old_id = setIdNoDiscard new_id
- | otherwise = new_id
in
- returnSM new_id'
-
-newTyVarSM
- = getUniqSM `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq boxedTypeKind)
+ returnSM new_id
\end{code}
projects / ghc-hetmet.git / blobdiff