%
-% (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 Id ( Id, DictVar, idType, mkUserLocal,
-
- getIdSpecialisation, setIdSpecialisation,
-
- IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
- emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
-
- IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv, delOneFromIdEnv
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec )
+import Id ( Id, idType, mkTemplateLocals, mkUserLocal,
+ getIdSpecialisation, setIdSpecialisation,
+ isSpecPragmaId,
)
+import VarSet
+import VarEnv
-import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
- tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
- )
-import TyCon ( TyCon )
-import TyVar ( TyVar,
- TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
- elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
- TyVarEnv, mkTyVarEnv, delFromTyVarEnv
+import Type ( Type, TyVarSubst, mkTyVarTy, splitSigmaTy, substTy,
+ fullSubstTy, tyVarsOfType, tyVarsOfTypes,
+ mkForAllTys, boxedTypeKind
)
+import Var ( TyVar, mkSysTyVar, setVarUnique )
+import VarSet
+import VarEnv
import CoreSyn
+import CoreUtils ( IdSubst, SubstCoreExpr(..), exprFreeVars,
+ substExpr, substId, substIds, coreExprType
+ )
+import CoreLint ( beginPass, endPass )
import PprCore () -- Instances
-import Name ( NamedThing(..), getSrcLoc )
-import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
+import SpecEnv ( addToSpecEnv )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
+ UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs,
+ getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
)
-
+import Name ( NamedThing(getOccName) )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool )
+import Maybes ( MaybeErr(..), catMaybes )
import Bag
import List ( partition )
-import Util ( zipEqual )
+import Util ( zipEqual, mapAccumL )
import Outputable
%************************************************************************
These notes describe how we implement specialisation to eliminate
-overloading, and optionally to eliminate unboxed polymorphism, and
-full polymorphism.
+overloading.
-The specialisation pass is a partial evaluator which works on Core
+The specialisation pass works on Core
syntax, complete with all the explicit dictionary application,
abstraction and construction as added by the type checker. The
existing type checker remains largely as it is.
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
f@t1/t2 = <f_rhs> t1 t2 d1 d2
-(f_rhs presumably has some big lambdas and dictionary lambdas, so lots
-of simplification will now result.) Then we should recursively do
-everything again.
-
-The new id has its own unique, but its print-name (if exported) has
-an explicit representation of the instance types t1/t2.
+f_rhs presumably has some big lambdas and dictionary lambdas, so lots
+of simplification will now result. However we don't actually *do* that
+simplification. Rather, we leave it for the simplifier to do. If we
+*did* do it, though, we'd get more call instances from the specialised
+RHS. We can work out what they are by instantiating the call-instance
+set from f's RHS with the types t1, t2.
Add this new id to f's IdInfo, to record that f has a specialised version.
in
fl
-We still have recusion for non-overloadd functions which we
-speciailise, but the recursive call should get speciailised to the
+We still have recusion for non-overloaded functions which we
+speciailise, but the recursive call should get specialised to the
same recursive version.
f@t1/ = /\b -> <f_rhs> t1 b d1 d2
-This seems pretty simple, and a Good Thing.
+We do this.
-Polymorphism 3 -- Unboxed
-~~~~~~~~~~~~~~
-If we are speciailising at unboxed types we must speciailise
-regardless of the overloading constraint. In the exaple above it is
-worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
-etc.
+Dictionary floating
+~~~~~~~~~~~~~~~~~~~
+Consider this
-Note that specialising an overloaded type at an uboxed type requires
-an unboxed instance -- we cannot default to an unspecialised version!
+ f a (d::Num a) = let g = ...
+ in
+ ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
+Here, g is only called at one type, but the dictionary isn't in scope at the
+definition point for g. Usually the type checker would build a
+definition for d1 which enclosed g, but the transformation system
+might have moved d1's defn inward. Solution: float dictionary bindings
+outwards along with call instances.
-Dictionary floating
-~~~~~~~~~~~~~~~~~~~
Consider
f x = let g p q = p==q
to widen its scope. Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.
-DELICATE MATTER: the way we tell a dictionary binding is by looking to
-see if it has a Dict type. If the type has been "undictify'd", so that
-it looks like a tuple, then the dictionary binding won't be floated, and
-an opportunity to specialise might be lost.
-
User SPECIALIZE pragmas
~~~~~~~~~~~~~~~~~~~~~~~
Specialisation pragmas can be digested by the type checker, and implemented
The information about what instance of the dfun exist gets added to
the dfun's IdInfo in the same way as a user-defined function too.
-In fact, matters are a little bit more complicated than this.
-When we make one of these specialised instances, we are defining
-a constant dictionary, and so we want immediate access to its constant
-methods and superclasses. Indeed, these constant methods and superclasses
-must be in the IdInfo for the class selectors! We need help from the
-typechecker to sort this out, perhaps by generating a separate IdInfo
-for each.
Automatic instance decl specialisation?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new call-instances of the dfuns, and so on. This all arises because of
the unrestricted mutual recursion between instance decls and value decls.
+Still, there's no actual problem; it just means that we may not do all
+the specialisation we could theoretically do.
+
Furthermore, instance decls are usually exported and used non-locally,
so we'll want to compile enough to get those specialisations done.
back in as a pragma when next compiling the file. So for now,
we only specialise instance decls in response to pragmas.
-That means that even if an instance decl ain't otherwise exported it
-needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
-something to say which module defined the instance, so the usage info
-can be fed into the right reqts info file. Blegh.
-
-
-SPECIAILISING DATA DECLARATIONS
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-With unboxed specialisation (or full specialisation) we also require
-data types (and their constructors) to be speciailised on unboxed
-type arguments.
-
-In addition to normal call instances we gather TyCon call instances at
-unboxed types, determine equivalence classes for the locally defined
-TyCons and build speciailised data constructor Ids for each TyCon and
-substitute these in the Con calls.
-
-We need the list of local TyCons to partition the TyCon instance info.
-We pass out a FiniteMap from local TyCons to Specialised Instances to
-give to the interface and code genertors.
-
-N.B. The specialised data constructors reference the original data
-constructor and type constructor which do not have the updated
-specialisation info attached. Any specialisation info must be
-extracted from the TyCon map returned.
-
SPITTING OUT USAGE INFORMATION
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is done at the top-level when all the call instances which escape
must be for imported functions and data types.
+*** Not currently done ***
+
Partial specialisation by pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In short, dfun Ids need IdInfo with a specialisation for each
constant instance of their instance declaration.
+All this uses a single mechanism: the SpecEnv inside an Id
+
What does the specialisation IdInfo look like?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- SpecInfo
- [Maybe Type] -- Instance types
- Int -- No of dicts to eat
- Id -- Specialised version
+The SpecEnv of an Id maps a list of types (the template) to an expression
+
+ [Type] |-> Expr
For example, if f has this SpecInfo:
- SpecInfo [Just t1, Nothing, Just t3] 2 f'
+ [Int, a] -> \d:Ord Int. f' a
+
+it means that we can replace the call
-then
+ f Int t ===> (\d. f' t)
- f t1 t2 t3 d1 d2 ===> f t2
+This chucks one dictionary away and proceeds with the
+specialised version of f, namely f'.
-The "Nothings" identify type arguments in which the specialised
-version is polymorphic.
What can't be done this way?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
overloading altogether anyway!
-Mutter mutter
-~~~~~~~~~~~~~
-What about types/classes mentioned in SPECIALIZE pragmas spat out,
-but not otherwise exported. Even if they are exported, what about
-their original names.
-
-Suggestion: use qualified names in pragmas, omitting module for
-prelude and "this module".
-
-
-Mutter mutter 2
-~~~~~~~~~~~~~~~
-Consider this
-
- f a (d::Num a) = let g = ...
- in
- ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
-
-Here, g is only called at one type, but the dictionary isn't in scope at the
-definition point for g. Usually the type checker would build a
-definition for d1 which enclosed g, but the transformation system
-might have moved d1's defn inward.
-
-
-Unboxed bindings
-~~~~~~~~~~~~~~~~
-
-What should we do when a value is specialised to a *strict* unboxed value?
-
- map_*_* f (x:xs) = let h = f x
- t = map f xs
- in h:t
-
-Could convert let to case:
-
- map_*_Int# f (x:xs) = case f x of h# ->
- let t = map f xs
- in h#:t
-
-This may be undesirable since it forces evaluation here, but the value
-may not be used in all branches of the body. In the general case this
-transformation is impossible since the mutual recursion in a letrec
-cannot be expressed as a case.
-
-There is also a problem with top-level unboxed values, since our
-implementation cannot handle unboxed values at the top level.
-
-Solution: Lift the binding of the unboxed value and extract it when it
-is used:
-
- map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
- t = map f xs
- in case h of
- _Lift h# -> h#:t
-
-Now give it to the simplifier and the _Lifting will be optimised away.
-
-The benfit is that we have given the specialised "unboxed" values a
-very simplep lifted semantics and then leave it up to the simplifier to
-optimise it --- knowing that the overheads will be removed in nearly
-all cases.
-
-In particular, the value will only be evaluted in the branches of the
-program which use it, rather than being forced at the point where the
-value is bound. For example:
-
- filtermap_*_* p f (x:xs)
- = let h = f x
- t = ...
- in case p x of
- True -> h:t
- False -> t
- ==>
- filtermap_*_Int# p f (x:xs)
- = let h = case (f x) of h# -> _Lift h#
- t = ...
- in case p x of
- True -> case h of _Lift h#
- -> h#:t
- False -> t
-
-The binding for h can still be inlined in the one branch and the
-_Lifting eliminated.
-
-
-Question: When won't the _Lifting be eliminated?
-
-Answer: When they at the top-level (where it is necessary) or when
-inlining would duplicate work (or possibly code depending on
-options). However, the _Lifting will still be eliminated if the
-strictness analyser deems the lifted binding strict.
-
A note about non-tyvar dictionaries
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding]
+specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
specProgram us binds
- = initSM us (go binds `thenSM` \ (binds', uds') ->
- returnSM (dumpAllDictBinds uds' binds')
- )
+ = do
+ beginPass "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'
+
where
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
---------------- First the easy cases --------------------
+specExpr e@(Type _) = returnSM (e, emptyUDs)
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 (Coerce co ty body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (Coerce co ty body', uds)
+specExpr e@(Con con args)
+ = mapAndCombineSM specExpr args `thenSM` \ (args', uds) ->
+ returnSM (Con con args', uds)
-specExpr (SCC cc body)
+specExpr (Note note body)
= specExpr body `thenSM` \ (body', uds) ->
- returnSM (SCC cc body', uds)
+ returnSM (Note note body', uds)
---------------- Applications might generate a call instance --------------------
-specExpr e@(App fun arg)
- = go fun [arg]
+specExpr 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 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
---------------- Lambda/case require dumping of usage details --------------------
specExpr e@(Lam _ _)
let
(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
-- 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 alts)
- = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
- spec_alts alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts)
+specExpr (Case scrut case_bndr alts)
+ = specExpr 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)
+ spec_alt (con, args, rhs)
= specExpr rhs `thenSM` \ (rhs', uds) ->
let
- (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
+ (uds', rhs'') = dumpUDs args uds rhs'
in
returnSM ((con, args, rhs''), uds')
- spec_prim_alt (lit, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- returnSM ((lit, rhs'), uds)
-
- spec_deflt NoDefault = returnSM (NoDefault, emptyUDs)
- spec_deflt (BindDefault arg rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- let
- (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs'
- in
- returnSM (BindDefault arg rhs'', uds')
-
---------------- Finally, let is the interesting case --------------------
specExpr (Let bind body)
= -- Deal with the body
%************************************************************************
\begin{code}
-specBind :: CoreBinding
+specBind :: 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) ->
+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) ->
let
- all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs'
+ 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 bind_uds may mention
+ -- dictionaries bound in body_uds.
in
- returnSM ([], all_uds)
+ 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
- | 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) ->
- let
- (all_uds, (dict_binds, dump_calls))
- = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds)
+ 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 (NonRec bndr rhs) call_info
+ = specDefn 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 : dict_binds, all_uds )
+ returnSM (new_bind, spec_uds)
-specBind (Rec pairs) body_uds
- = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff ->
+specBindItself (Rec pairs) call_info
+ = mapSM (specDefn 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) (spec_uds `plusUDs` body_uds)
- new_bind = Rec (spec_defns ++ pairs')
+ new_bind = Rec (spec_defns ++ pairs')
in
- returnSM ( new_bind : dict_binds, all_uds )
+ returnSM (new_bind, spec_uds)
+
specDefn :: 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
(spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
fn' = addIdSpecialisations fn spec_env_stuff
- rhs' = foldr Lam (foldr Let body' dict_binds) rhs_bndrs
+ rhs' = mkLams rhs_bndrs (mkDictLets dict_binds body')
in
returnSM ((fn',rhs'),
spec_defns,
(tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
- mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyvars
- where
- mk_spec_ty (Just ty) _ = ty
- mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
- (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders 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
Nothing -> []
Just cs -> fmToList cs
- -- Filter out calls for which we already have a specialisation
- calls_to_spec = filter spec_me calls_for_me
- spec_me (call_ts, _) = not (maybeToBool (lookupSpecEnv id_spec_env (mk_spec_tys call_ts)))
- id_spec_env = getIdSpecialisation fn
-
----------------------------------------------------------
-- Specialise to one particular call pattern
spec_call :: ProtoUsageDetails -- From the original body, captured by
-- the dictionary lambdas
- -> ([Maybe Type], [DictVar]) -- Call instance
+ -> ([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)
+ spec_call bound_uds (call_ts, (call_ds, _))
= ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
-- Calls are only recorded for properly-saturated applications
-- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
-- and the type of this binder
let
- spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts]
- spec_tys = mk_spec_tys call_ts
- 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)
+ 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 ->
+ 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
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
- spec_env_rhs = mkValLam call_ds $
- mkTyApp (Var spec_f) $
+ 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
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
+ 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)
in
specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds ->
data UsageDetails
= MkUD {
- dict_binds :: !(Bag (DictVar, CoreExpr, TyVarSet, FreeDicts)),
+ dict_binds :: !(Bag DictBind),
-- Floated dictionary bindings
-- The order is important;
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
calls :: !CallDetails
}
+type DictBind = (CoreBind, IdOrTyVarSet)
+ -- 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 = ([CoreBinding], -- Dict bindings
- [(Id, [Maybe Type], [DictVar])]
+type ProtoUsageDetails = ([DictBind],
+ [(Id, [Maybe Type], ([DictExpr], IdOrTyVarSet))]
)
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- [DictVar] -- Dict args
+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
-- The finite maps eliminate duplicates
-- The list of types and dictionaries is guaranteed to
-- match the type of f
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusFM_C plusFM c1 c2
+
+singleCall (id, tys, dicts)
+ = unitFM id (unitFM tys (dicts, dict_fvs))
+ where
+ dict_fvs = foldr (unionVarSet . exprFreeVars) emptyVarSet dicts
+ -- 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
+ --
+ -- 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
]
-listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls
-
-unionCalls :: CallDetails -> CallDetails -> CallDetails
-unionCalls c1 c2 = plusFM_C plusFM c1 c2
-
-singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts)
-
mkCallUDs f args
| null theta
|| length spec_tys /= n_tyvars
| 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
+ constrained_tyvars = foldr (unionVarSet . tyVarsOfTypes . snd) emptyVarSet 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
+ mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
= Just ty
| otherwise
= Nothing
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 (map fst prs)
+ where
+ rhs_fvs = foldr (unionVarSet . exprFreeVars . snd) emptyVarSet prs
+
+addDictBind uds bind = uds { dict_binds = mkDB bind `consBag` dict_binds uds }
dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
= foldrBag add binds dbs
where
- add (dict,rhs,_,_) binds = NonRec dict rhs : binds
+ add (bind,_) binds = bind : binds
+
+mkDictBinds :: [DictBind] -> [CoreBind]
+mkDictBinds = map fst
-dumpUDs :: [CoreBinder]
+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, foldr Let body dict_binds)
+ = (free_uds, mkDictLets dict_binds body)
where
(free_uds, (dict_binds, _)) = splitUDs bndrs uds
-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
- = (free_dbs, dump_dbs `snocBag` NonRec dict rhs,
- dump_idset `addOneToIdSet` dict)
+ 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))
+
+ | otherwise -- Don't dump it
+ = (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 :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env_list dict_env_list (dbs, calls)
- = specDBs dict_env dbs `thenSM` \ (dict_env', dbs') ->
- returnSM (MkUD { dict_binds = dbs',
- calls = listToCallDetails (map (inst_call dict_env') calls)
+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
- tv_env = mkTyVarEnv tv_env_list
- dict_env = mkIdEnv dict_env_list
-
- 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 (NonRec dict rhs : dbs)
- = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
- let
- dict_env' = addOneToIdEnv dict_env dict dict'
- rhs' = instantiateDictRhs tv_env dict_env rhs
- in
- specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
- returnSM ( dict_env'', mkDB dict' rhs' `consBag` dbs' )
+ 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 lookupIdEnv env id of
+lookupId env id = case lookupVarEnv env id of
Nothing -> id
Just id' -> id'
-instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
- -- Cheapo function for simple RHSs
-instantiateDictRhs ty_env id_env rhs
- = go rhs
- where
- go_arg (VarArg a) = VarArg (lookupId id_env a)
- go_arg (TyArg t) = TyArg (instantiateTy ty_env t)
-
- go (App e1 arg) = App (go e1) (go_arg arg)
- go (Var v) = Var (lookupId id_env v)
- go (Lit l) = Lit l
- go (Con con args) = Con con (map go_arg args)
- go (Coerce c t e) = Coerce c (instantiateTy ty_env t) (go e)
- go (Case e alts) = Case (go e) alts -- See comment below re alts
- go other = pprPanic "instantiateDictRhs" (ppr rhs)
-
-
-dictRhsFVs :: CoreExpr -> IdSet
- -- Cheapo function for simple RHSs
-dictRhsFVs e
- = go e
- where
- go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
- go (App e1 (TyArg t)) = go e1
- go (Var v) = unitIdSet v
- go (Lit l) = emptyIdSet
- go (Con _ args) = mkIdSet [id | VarArg id <- args]
- go (Coerce _ _ e) = go e
-
- go (Case e _) = go e -- Claim: no free dictionaries in the alternatives
- -- These case expressions are of the form
- -- case d of { D a b c -> b }
-
- go other = pprPanic "dictRhsFVs" (ppr e)
-
-
addIdSpecialisations id spec_stuff
= (if not (null errs) then
pprTrace "Duplicate specialisations" (vcat (map ppr errs))
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
+thenSM_ = thenUs_
returnSM = returnUs
-getUniqSM = getUnique
+getUniqSM = getUniqueUs
+getUniqSupplySM = getUs
+setUniqSupplySM = setUs
mapSM = mapUs
initSM = initUs
returnSM (y:ys, uds1 `plusUDs` uds2)
newIdSM old_id new_ty
- = getUnique `thenSM` \ uniq ->
+ = getUniqSM `thenSM` \ uniq ->
returnSM (mkUserLocal (getOccName old_id)
uniq
new_ty
- (getSrcLoc old_id)
)
+
+newTyVarSM
+ = getUniqSM `thenSM` \ uniq ->
+ returnSM (mkSysTyVar uniq boxedTypeKind)
\end{code}
+ Old (but interesting) stuff about unboxed bindings
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+What should we do when a value is specialised to a *strict* unboxed value?
+
+ map_*_* f (x:xs) = let h = f x
+ t = map f xs
+ in h:t
+
+Could convert let to case:
+
+ map_*_Int# f (x:xs) = case f x of h# ->
+ let t = map f xs
+ in h#:t
+
+This may be undesirable since it forces evaluation here, but the value
+may not be used in all branches of the body. In the general case this
+transformation is impossible since the mutual recursion in a letrec
+cannot be expressed as a case.
+
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
+
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
+
+ map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
+ t = map f xs
+ in case h of
+ _Lift h# -> h#:t
+
+Now give it to the simplifier and the _Lifting will be optimised away.
+
+The benfit is that we have given the specialised "unboxed" values a
+very simplep lifted semantics and then leave it up to the simplifier to
+optimise it --- knowing that the overheads will be removed in nearly
+all cases.
+
+In particular, the value will only be evaluted in the branches of the
+program which use it, rather than being forced at the point where the
+value is bound. For example:
+
+ filtermap_*_* p f (x:xs)
+ = let h = f x
+ t = ...
+ in case p x of
+ True -> h:t
+ False -> t
+ ==>
+ filtermap_*_Int# p f (x:xs)
+ = let h = case (f x) of h# -> _Lift h#
+ t = ...
+ in case p x of
+ True -> case h of _Lift h#
+ -> h#:t
+ False -> t
+
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
+
+
+Question: When won't the _Lifting be eliminated?
+
+Answer: When they at the top-level (where it is necessary) or when
+inlining would duplicate work (or possibly code depending on
+options). However, the _Lifting will still be eliminated if the
+strictness analyser deems the lifted binding strict.
+
projects / ghc-hetmet.git / blobdiff