%
-% (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 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 IdInfo ( zapSpecPragInfo )
+import VarSet
+import VarEnv
-import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
- tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
+import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
+ mkForAllTys, boxedTypeKind
)
-import TyCon ( TyCon )
-import TyVar ( TyVar, mkTyVar,
- TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
- elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
- minusTyVarSet,
- TyVarEnv, mkTyVarEnv, delFromTyVarEnv
- )
-import Kind ( mkBoxedTypeKind )
+import PprType ( {- instance Outputable Type -} )
+import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
+ substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
+ )
+import Var ( TyVar, mkSysTyVar, setVarUnique )
+import VarSet
+import VarEnv
import CoreSyn
-import PprCore () -- Instances
-import Name ( NamedThing(..), getSrcLoc, mkSysLocalName )
-import SrcLoc ( noSrcLoc )
-import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
+import CoreUtils ( applyTypeToArgs )
+import CoreUnfold ( certainlyWillInline )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreLint ( beginPass, endPass )
+import PprCore ( pprCoreRules )
+import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
+ UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
+ getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
)
-import Unique ( mkAlphaTyVarUnique )
+import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), maybeToBool )
+import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet )
import Bag
import List ( partition )
-import Util ( zipEqual )
+import Util ( zipEqual, zipWithEqual, mapAccumL )
import Outputable
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 :: 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'
+
+ dumpIfSet opt_D_dump_rules "Top-level specialisations"
+ (vcat (map dump_specs (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 (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')
+
+dump_specs var = pprCoreRules var (idSpecialisation var)
\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') = substBndrs 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') = substId 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') = substBndrs 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) ->
+specBind rhs_subst bind body_uds
+ = specBindItself rhs_subst 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
- | isSpecPragmaId bndr
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ([], rhs_uds `plusUDs` body_uds)
+ dbsToPairs [] = []
+ dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
- | 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) ->
+-- 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
- (all_uds, (dict_binds, dump_calls))
- = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds)
-
- -- If we make specialisations then we Rec the whole lot together
- -- If not, leave it as a NonRec
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) (spec_uds `plusUDs` body_uds)
- 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
+ && 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
- fn' = addIdSpecialisations fn spec_env_stuff
- rhs' = foldr Lam (mkDictLets dict_binds body') rhs_bndrs
+ fn' = addIdSpecialisations zapped_fn spec_env_stuff
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
+ 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, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
- mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyVarTemplates
- 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
----------------------------------------------------------
-- 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)
+ 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 )
-- 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
+ -- 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
- spec_tyvars = [tyvar | (tyvar, Nothing) <- tyVarTemplates `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)
+ -- 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
+ 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
+ newIdSM fn spec_id_ty `thenSM` \ spec_f ->
+ specExpr rhs_subst' (mkLams poly_tyvars body) `thenSM` \ (spec_rhs, rhs_uds) ->
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
+ -- 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))
+
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
in
- specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds ->
-
returnSM ((spec_f, spec_rhs),
- spec_uds,
- spec_env_info
- )
+ 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
\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)
+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, [Maybe Type], ([DictExpr], VarSet))]
)
------------------------------------------------------------
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], 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
+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))
+ 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
]
-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
+mkCallUDs subst f args
| null theta
|| length spec_tys /= n_tyvars
|| length dicts /= n_dicts
- = emptyUDs -- Not overloaded
+ || maybeToBool (lookupRule (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
+ 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
+ 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}
-addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
+mkDB bind = (bind, bind_fvs bind)
+
+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)
+ add (bind,_) binds = bind : binds
-mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
-mkDictLets dbs body = foldr mk body dbs
- where
- mk (d,r,_,_) e = Let (NonRec d r) e
-
-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
-
- 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)
+ dump_idset `unionVarSet` mkVarSet (bindersOf bind))
- 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
+lookupId env id = case lookupVarEnv env id of
Nothing -> id
Just id' -> id'
-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 (LitArg l)) = go e1
- 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 (Note _ 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))
- 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
+thenSM_ = thenUs_
returnSM = returnUs
-getUniqSM = getUnique
+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', us', bndr') = substAndCloneId subst us bndr
+ in
+ setUs us' `thenUs_`
+ returnUs (subst, subst', NonRec bndr' rhs)
+
+cloneBindSM subst (Rec pairs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', us', bndrs') = substAndCloneIds 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')
+
+
newIdSM old_id new_ty
- = getUnique `thenSM` \ uniq ->
- returnSM (mkUserLocal (getOccName old_id)
- uniq
- new_ty
- (getSrcLoc old_id)
- )
+ = 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)
+
+ -- 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)
\end{code}
projects / ghc-hetmet.git / blobdiff