%
-% (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,
- initSpecData,
-
- SpecialiseData(..)
- ) where
+module Specialise ( specProgram ) where
#include "HsVersions.h"
-import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
- partitionBag, listToBag, bagToList, Bag
- )
-import Class ( Class )
-import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
- opt_SpecialiseTrace
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal )
+import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta, isClassPred,
+ mkForAllTys, tcCmpType
)
-import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
+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 ( coreExprType, squashableDictishCcExpr )
-import FiniteMap ( addListToFM_C, FiniteMap )
-import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
-import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
- isBottomingId,
- isDataCon,
- isImportedId, mkIdWithNewUniq,
- dataConTyCon, applyTypeEnvToId,
- nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, IdEnv,
- emptyIdSet, mkIdSet, unitIdSet,
- elementOfIdSet, minusIdSet,
- unionIdSets, unionManyIdSets, IdSet,
- GenId{-instance Eq-}, Id
- )
-import Literal ( Literal{-instance Outputable-} )
-import Maybes ( catMaybes, firstJust, maybeToBool )
-import Name ( isLocallyDefined )
-import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
- GenType{-instance Outputable-}, GenTyVar{-ditto-},
- TyCon{-ditto-}
- )
-import PrimOp ( PrimOp(..) )
-import SpecUtils
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
- tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
- Type
- )
-import TyCon ( TyCon{-instance Eq-} )
-import TyVar ( cloneTyVar, mkSysTyVar,
- elementOfTyVarSet, TyVarSet,
- emptyTyVarEnv, growTyVarEnvList, TyVarEnv,
- GenTyVar{-instance Eq-}
- )
-import TysWiredIn ( liftDataCon )
-import Unique ( Unique{-instance Eq-} )
-import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
-import UniqSupply ( splitUniqSupply, getUniques, getUnique )
-import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
- thenCmp
+import CoreUtils ( applyTypeToArgs )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
+import CoreLint ( showPass, endPass )
+import Rules ( addIdSpecialisations, lookupRule )
+
+import UniqSupply ( UniqSupply,
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
)
+import Name ( nameOccName, mkSpecOcc, getSrcLoc )
+import FiniteMap
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
+import Bag
import List ( partition )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
import Outputable
+import FastString
infixr 9 `thenSM`
-
-specProgram = panic "SpecProgram"
-
---ToDo:kill
-data SpecInfo = SpecInfo [Maybe Type] Int Id
-
-
-{-
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
-addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
-cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
-getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
-isClassOpId = panic "Specialise.isClassOpId (ToDo)"
-isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
-isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
-isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
-isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
-lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
-mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
-mkSpecId = panic "Specialise.mkSpecId (ToDo)"
-selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
-specialiseTy = panic "Specialise.specialiseTy (ToDo)"
\end{code}
%************************************************************************
%************************************************************************
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
-then
+it means that we can replace the call
- f t1 t2 t3 d1 d2 ===> f t2
+ f Int t ===> (\d. f' t)
+
+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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*** no specialised version is overloaded ***
+%************************************************************************
+%* *
+\subsubsection{The exported function}
+%* *
+%************************************************************************
+
\begin{code}
-specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
+ = do
+ showPass dflags "Specialise"
----------------- 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)
+ let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
+ returnSM (dumpAllDictBinds uds' binds'))
+
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
+
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
+ (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
+
+ return binds'
+ where
+ -- We need to start with a Subst that knows all the things
+ -- that are in scope, so that the substitution engine doesn't
+ -- accidentally re-use a unique that's already in use
+ -- Easiest thing is to do it all at once, as if all the top-level
+ -- decls were mutually recursive
+ top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
+
+ go [] = returnSM ([], emptyUDs)
+ go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
+ specBind top_subst bind uds `thenSM` \ (bind', uds') ->
+ returnSM (bind' ++ binds', uds')
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@specExpr@: the main function}
+%* *
+%************************************************************************
+
+\begin{code}
+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!)
-specExpr (Coerce co ty body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (Coerce co ty body')
+---------------- First the easy cases --------------------
+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 (SCC cc body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (SCC cc body')
+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 (Lam bndr 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
- 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 (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
-
- spec_alg_alt (con, args, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- let
- (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
- in
- returnSM ((con, args, rhs''), uds')
-
- spec_prim_alt (lit, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
- returnSM ((lit, rhs'), uds)
+ (subst_alt, case_bndr') = simplBndr subst case_bndr
+ -- No need to clone case binder; it can't float like a let(rec)
- spec_deflt NoDefault = (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'') = dumpManyUDs [ValBinder arg] uds rhs'
+ (uds', rhs'') = dumpUDs args uds rhs'
in
- returnSM (BindDefault arg rhs'', uds')
+ returnSM ((con, args', rhs''), uds')
+ where
+ (subst_rhs, args') = simplBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
-specExpr (Let (NonRec bndr rhs) 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 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}
+
+%************************************************************************
+%* *
+\subsubsection{Dealing with a binding}
+%* *
+%************************************************************************
+
+\begin{code}
+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 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)
+ -- 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
+ 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
- -- 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) ->
+ dbsToPairs [] = []
+ dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
+-- 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 = deleteCalls (rhs_uds `plusUDs` body_uds) bndr'
+ 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
- if bndr `elementOfIdSet` free_dicts body_uds then
- -- This is a dictionary binding; we must pick it up
- -- and float it outwards.
- ASSERT( null spec_defns )
- returnSM (body', addDictBind all_uds bndr' rhs')
-
- else if isSpecPragmaId bndr then
- -- SpecPragmaIds are there solely to generate specialisations
- -- Just drop the whole binding
- ASSERT( null spec_defns )
- returnSM (body', all_uds)
+ returnSM (new_bind, spec_uds)
- else
- -- An ordinary binding, so glue it all together
- returnSM (
- Let (NonRec bndr' rhs') (mkLets spec_defns body'),
- all_uds
- )
+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
+ new_bind = Rec (spec_defns ++ pairs')
+ in
+ 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
- [(Id, CoreExpr)], -- Extra, specialised bindings
+ [(Id,CoreExpr)], -- Extra, specialised bindings
UsageDetails -- Stuff to fling upwards from the RHS and its
) -- specialised versions
-specDefn calls (fn, rhs)
+specDefn subst calls (fn, rhs)
-- The first case is the interesting one
- | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
- && n_dicts <= length rhs_bndrs -- and enough dict args
- && not (null calls_for_me) -- And there are some calls to specialise
+ | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
+ && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
+ && notNull calls_for_me -- And there are some calls to specialise
+
+-- At one time I tried not specialising small functions
+-- but sometimes there are big functions marked INLINE
+-- that we'd like to specialise. In particular, dictionary
+-- functions, which Marcin is keen to inline
+-- && not (certainlyWillInline fn) -- And it's not small
+ -- If it's small, it's better just to inline
+ -- it than to construct lots of specialisations
= -- Specialise the body of the function
- specExpr body `thenSM` \ (body', body_uds) ->
+ specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
-- Make a specialised version for each call in calls_for_me
- mapSM (spec_call body_uds) calls_for_me `thenSM` \ stuff ->
+ mapSM spec_call calls_for_me `thenSM` \ stuff ->
let
- (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
-
- (rhs_uds, body'') = dumpUDs rhs_bndrs body_uds body'
- rhs' = foldr Lam bndrs body''
+ (spec_defns, spec_uds, spec_rules) = unzip3 stuff
- fn' = addIdSpecialisations fn spec_env_stuff
+ fn' = addIdSpecialisations zapped_fn spec_rules
in
returnSM ((fn',rhs'),
spec_defns,
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
- (tyvars, theta, tau) = splitSigmaTy (idType fn)
- n_tyvars = length tyvars
- n_dicts = length theta
+ zapped_fn = zapSpecPragmaId fn
+ -- If the fn is a SpecPragmaId, make it discardable
+ -- It's role as a holder for a call instance is o'er
+ -- But it might be alive for some other reason by now.
+
+ fn_type = idType fn
+ (tyvars, theta, _) = tcSplitSigmaTy fn_type
+ n_tyvars = length tyvars
+ n_dicts = length theta
+
+ -- It's important that we "see past" any INLINE pragma
+ -- else we'll fail to specialise an INLINE thing
+ (inline_me, rhs') = dropInline rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
- (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
rhs_dicts = take n_dicts rhs_ids
- rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
- body = mkValLam (drop n_dicts rhs_ids) rhs_body
+ rhs_bndrs = rhs_tyvars ++ rhs_dicts
+ body = mkLams (drop n_dicts rhs_ids) rhs_body
-- Glue back on the non-dict lambdas
calls_for_me = case lookupFM calls fn of
Nothing -> []
Just cs -> fmToList cs
-
+ ----------------------------------------------------------
-- Specialise to one particular call pattern
- spec_call :: UsageDetails -- From the original body
- -> ([Maybe Type], [DictVar]) -- Call instance
- -> ((Id, CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([Type], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call body_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 -> (..body 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) <- tyvars `zip` call_tys]
- spec_tys = zipWith mk_spec_ty call_ts tyvars
- spec_rhs = mkTyLam spec_tyvars $
- mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
- spec_id_ty = mkForAllTys spec_tyvars (applyTys (idType f) spec_tys)
-
- mk_spec_ty (Just ty) _ = ty
- mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
+ -- 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 f spec_id_ty `thenSM` \ spec_f ->
-
+ cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
+ let
+ inst_args = ty_args ++ map Var rhs_dicts'
- -- Construct the stuff for f's spec env
- -- [t1,b,t3,d] |-> \d1 d2 -> f1 b d
+ -- 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
- spec_env_rhs = mkValLam call_ds $
- mkTyApp (Var spec_f) $
- map mkTyVarTy spec_tyvars
- spec_env_info = (spec_tys, spec_env_rhs)
- in
-
- -- Specialise the UDs from f's RHS
- specUDs (zipEqual rhs_tyvars call_ts)
- (zipEqual rhs_dicts call_ds)
- body_uds `thenSM` \ spec_uds ->
-
- returnSM ((spec_f, spec_rhs),
- spec_uds,
- spec_env_info
- )
+ -- The rule to put in the function's specialisation is:
+ -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
+ spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+ AlwaysActive
+ (poly_tyvars ++ rhs_dicts')
+ inst_args
+ (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+
+ -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
+ -- the original function said INLINE, the specialised copies won't.
+ -- The idea is that the point of inlining was precisely to specialise
+ -- the function at its call site, and that's not so important for the
+ -- specialised copies. But it still smells like an ad hoc decision.
+
+ 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 {
- free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds
-
- dict_binds :: !Bag (DictVar, CoreExpr, 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
-- (Remember, Bags preserve order in GHC.)
- -- The FreeDicts is the free vars of the RHS
calls :: !CallDetails
}
-type CallMap = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- [DictVar] -- Dict args
+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, CallKey, ([DictExpr], VarSet))]
+ )
+
+------------------------------------------------------------
+type CallDetails = FiniteMap Id CallInfo
+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 -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts
+ = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
+ where
+ call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+ tys_fvs = tyVarsOfTypes (catMaybes tys)
+ -- The type args (tys) are guaranteed to be part of the dictionary
+ -- types, because they are just the constrained types,
+ -- and the dictionary is therefore sure to be bound
+ -- inside the binding for any type variables free in the type;
+ -- hence it's safe to neglect tyvars free in tys when making
+ -- the free-var set for this call
+ -- BUT I don't trust this reasoning; play safe and include tys_fvs
+ --
+ -- We don't include the 'id' itself.
+
+listToCallDetails calls
+ = foldr (unionCalls . mk_call) emptyFM calls
+ where
+ mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
+ -- NB: the free vars of the call are provided
+
+callDetailsToList calls = [ (id,tys,dicts)
+ | (id,fm) <- fmToList calls,
+ (tys, dicts) <- fmToList fm
+ ]
+
+mkCallUDs subst f args
+ | null theta
+ || not (all isClassPred theta)
+ -- Only specialise if all overloading is on class params.
+ -- In ptic, with implicit params, the type args
+ -- *don't* say what the value of the implicit param is!
+ || not (spec_tys `lengthIs` n_tyvars)
+ || not ( dicts `lengthIs` n_dicts)
+ || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
+ -- There's already a rule covering this call. A typical case
+ -- is where there's an explicit user-provided rule. Then
+ -- we don't want to create a specialised version
+ -- of the function that overlaps.
+ = emptyUDs -- Not overloaded, or no specialisation wanted
+
+ | otherwise
+ = MkUD {dict_binds = emptyBag,
+ calls = singleCall f spec_tys dicts
+ }
+ where
+ (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
+
+------------------------------------------------------------
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
-plusUDs (MkUD {fvs = fvs1, dictBinds = db1, calls = calls1})
- (MkUD {fvs = fvs2, dictBinds = db2, calls = calls2})
- = MkUD {fvs, dictBinds, calls}
+plusUDs (MkUD {dict_binds = db1, calls = calls1})
+ (MkUD {dict_binds = db2, calls = calls2})
+ = MkUD {dict_binds = d, calls = c}
where
- fvs = fvs1 `unionIdSets` fvs2
- dictBinds = db1 `unionBags` db2
- calls = calls1 `unionBags` calls2
+ d = db1 `unionBags` db2
+ c = calls1 `unionCalls` calls2
+plusUDList = foldr plusUDs emptyUDs
-tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs))
+-- zapCalls deletes calls to ids from uds
+zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
-deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr }
+mkDB bind = (bind, bind_fvs bind)
-addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict,
- dict_binds = (dict, rhs, f
+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]
-dumpUDs :: [CoreBinder]
- -> UsageDetails -> CoreExpr
- -> (UsageDetails, CoreExpr)
+addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
-dumpUDs bndrs uds@(MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) body
- = ASSERT( isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs))
- -- The tyvars shouldn't be free in any of the usage details
- -- If it was, then we should have found a dictionary lambda first
+dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
+ = foldrBag add binds dbs
+ where
+ add (bind,_) binds = bind : binds
- if isEmptyIdSet (id_set `intersectIdSets` fvs) then
+dumpUDs :: [CoreBndr]
+ -> UsageDetails -> CoreExpr
+ -> (UsageDetails, CoreExpr)
+dumpUDs bndrs uds 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
+ -> (UsageDetails, -- These don't mention the binders
+ ProtoUsageDetails) -- These do
+
+splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
+ calls = orig_calls})
+
+ = if isEmptyBag dump_dbs && null dump_calls then
-- Common case: binder doesn't affect floats
- (uds, body)
+ (uds, ([],[]))
else
-- Binders bind some of the fvs of the floats
- (MkUDs {fvs = filtered_fvs,
- dictBinds = filtered_dbs,
- calls = filtered_calls},
- foldrBag mk_dict_bind body dump_dbs)
+ (MkUD {dict_binds = free_dbs,
+ calls = listToCallDetails free_calls},
+ (bagToList dump_dbs, dump_calls)
+ )
where
- tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
- id_list = [id | ValBinder id <- bndrs]
- id_set = mkIdSet id_list
- ftvs = tyVarsOfUDs uds
- filtered_fvs = orig_fvs `minusIdSet` id_set
-
- (filtered_dbs, dump_dbs, dump_idset)
- = foldlBag dump (emptyBag, emptyBag, id_set) orig_dbs
+ bndr_set = mkVarSet bndrs
+
+ (free_dbs, dump_dbs, dump_idset)
+ = 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
- -- It's a bit tiresome because of the two-level finite map
- filtered_calls = mapFM del (foldr delFromFM orig_calls id_list)
- del _ dicts = filter (not (`elementOfIdSet` dump_id_set)) dicts
-
- dump (ok_dbs, dump_dbs, dump_idset) db@(dict, rhs, fvs)
- | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
- = (ok_dbs `snocBag` db, dump_dbs, dump_idset)
-
- | otherwise -- Dump it
- = (ok_dbs, dump_dbs `snocBag` db, idEmptyIdSet (dump_idset `intersectIdSets` fvs)
-
- mk_dict_bind (dict, rhs, _) body = Let (NonRec dict rhs) body
-\end{code}
-
-Given a type and value substitution, specUDs creates a specialised copy of
-the given UDs
-
-\begin{code}
-specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls})
- = mapAccumLSM spec_bind
- (tv_env, id_env)
- (bagToList orig_dbs) `thenSM` \ ((tv_env', id_env'), new_dbs) ->
- let
- subst_call call_info = listToFM [(map (instantiateTy ty_env') ts,
- map (lookupId id_env') call_ds)
- | (call_ts, call_ds) <- fmToList call_info
- ]
- in
- MkUDs { fvs = substFVSet id_env orig_fvs,
- dictBinds = listToBag new_dbs,
- calls = mapFM orig_calls subst_call
- }
- where
- tv_env = mkTyVarEnv tv_assoc
- id_env = mkIdEnv id_assoc
-
- spec_bind (ty_env, id_env) (dict, rhs, fvs)
- = newIdSM dict spec_ty `thenSM` \ spec_dict ->
- returnSM ((ty_env, addOneToIdEnv id_env dict spec_dict), (spec_dict, spec_rhs))
- where
- spec_ty = instantiateTy ty_env (idType dict)
- spec_rhs = instantiateDictRhs ty_env id_env rhs
+ 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
+
+ dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+ | dump_idset `intersectsVarSet` fvs -- Dump it
+ = (free_dbs, dump_dbs `snocBag` db,
+ extendVarSetList dump_idset (bindersOf bind))
+
+ | otherwise -- Don't dump it
+ = (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
%************************************************************************
\begin{code}
-substFVSet :: IdEnv Id -> IdSet -> IdSet
-substFVSet env s = mkIdSet [lookupId env id | id <- idSetToList s]
-
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupIdEnv 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 (App e1 (ValArg a)) = App (go e1) (ValArg (lookupId id_env a))
- go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t))
- go (Var v) = Var (lookupId id_env v)
- go (Lit l) = Lit l
-
-dictRhsFVs :: CoreExpr -> IdSet
- -- Cheapo function for simple RHSs
-dictRhsFVs (App e1 (ValArg a)) = dictRhsFVs e1 `addOneToIdSet` a
- go (App e1 (TyArg t)) = dictRhsFVs e1
- go (Var v) = singletonIdSet v
- go (Lit l) = emptyIdSet
-
-mkLets [] body = body
-mkLets ((bndr,rhs):binds) body = Let (NonRec bndr rhs) (mkLets binds body)
-
-zipNothings [] [] = []
-zipNothings (Nothing : tys) (tyvar : tyvars) = mkTyVarTy tyvar : zipNothings tys tyvars
-zipNothings (Just ty : tys) tyvars = ty : zipNothings tys tyvars
-\end{code}
-
-
-=========================== OLD STUFF =================================
-
-%************************************************************************
-%* *
-\subsubsection[CallInstances]{@CallInstances@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-type FreeVarsSet = IdSet
-type FreeTyVarsSet = TyVarSet
-
-data CallInstance
- = CallInstance
- Id -- This Id; *new* ie *cloned* id
- [Maybe Type] -- Specialised at these types (*new*, cloned)
- -- Nothing => no specialisation on this type arg
- -- is required (flag dependent).
- [CoreArg] -- And these dictionaries; all ValArgs
- FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
- (Maybe SpecInfo) -- For specialisation with explicit SpecId
-\end{code}
+type SpecM a = UniqSM a
+
+thenSM = thenUs
+returnSM = returnUs
+getUniqSM = getUniqueUs
+mapSM = mapUs
+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)
-\begin{code}
-pprCI :: CallInstance -> Doc
-pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
- = hang (hsep [ptext SLIT("Call inst for"), ppr id])
- 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
- case maybe_specinfo of
- Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
- Just (SpecInfo _ _ spec_id)
- -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
- ])
-
--- ToDo: instance Outputable CoreArg?
-ppr_arg (TyArg t) = ppr sty t
-ppr_arg (LitArg i) = ppr sty i
-ppr_arg (VarArg v) = ppr sty v
-
-isUnboxedCI :: CallInstance -> Bool
-isUnboxedCI (CallInstance _ spec_tys _ _ _)
- = any isUnboxedType (catMaybes spec_tys)
-
-isExplicitCI :: CallInstance -> Bool
-isExplicitCI (CallInstance _ _ _ _ (Just _))
- = True
-isExplicitCI (CallInstance _ _ _ _ Nothing)
- = False
+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
+ name = idName old_id
+ new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
+ in
+ returnSM new_id
\end{code}
-Comparisons are based on the {\em types}, ignoring the dictionary args:
-\begin{code}
+ Old (but interesting) stuff about unboxed bindings
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-cmpCI :: CallInstance -> CallInstance -> Ordering
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
+What should we do when a value is specialised to a *strict* unboxed value?
-cmpCI_tys :: CallInstance -> CallInstance -> Ordering
-cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
- = cmpUniTypeMaybeList tys1 tys2
+ map_*_* f (x:xs) = let h = f x
+ t = map f xs
+ in h:t
-eqCI_tys :: CallInstance -> CallInstance -> Bool
-eqCI_tys c1 c2
- = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
+Could convert let to case:
-isCIofTheseIds :: [Id] -> CallInstance -> Bool
-isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
- = any ((==) ci_id) ids
+ map_*_Int# f (x:xs) = case f x of h# ->
+ let t = map f xs
+ in h#:t
-singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
-singleCI id tys dicts
- = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
- emptyBag [] emptyIdSet 0 0
- where
- fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
+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.
-explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
-explicitCI id tys specinfo
- = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
- where
- call_inst = CallInstance id tys dicts fv_set (Just specinfo)
- dicts = panic "Specialise:explicitCI:dicts"
- fv_set = unitIdSet id
-
--- We do not process the CIs for top-level dfuns or defms
--- Instead we require an explicit SPEC inst pragma for dfuns
--- and an explict method within any instances for the defms
-
-getCIids :: Bool -> [Id] -> [Id]
-getCIids True ids = filter not_dict_or_defm ids
-getCIids _ ids = ids
-
-not_dict_or_defm id
- = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
-
-getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
-getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
- = let
- (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
- cis_here_list = bagToList cis_here
- in
- -- pprTrace "getCIs:"
- -- (hang (hcat [char '{',
- -- interppSP ids,
- -- char '}'])
- -- 4 (vcat (map pprCI cis_here_list)))
- (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
-
-dumpCIs :: Bag CallInstance -- The call instances
- -> Bool -- True <=> top level bound Ids
- -> Bool -- True <=> dict bindings to be floated (specBind only)
- -> [CallInstance] -- Call insts for bound ids (instBind only)
- -> [Id] -- Bound ids *new*
- -> [Id] -- Full bound ids: includes dumped dicts
- -> Bag CallInstance -- Kept call instances
-
- -- CIs are dumped if:
- -- 1) they are a CI for one of the bound ids, or
- -- 2) they mention any of the dicts in a local unfloated binding
- --
- -- For top-level bindings we allow the call instances to
- -- float past a dict bind and place all the top-level binds
- -- in a *global* Rec.
- -- We leave it to the simplifier will sort it all out ...
-
-dumpCIs cis top_lev floating inst_cis bound_ids full_ids
- = (if not (isEmptyBag cis_of_bound_id) &&
- not (isEmptyBag cis_of_bound_id_without_inst_cis)
- then
- pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
- " (may be a non-HM recursive call)\n")
- (hang (hcat [char '{',
- interppSP bound_ids,
- char '}'])
- 4 (vcat [ptext SLIT("Dumping CIs:"),
- vcat (map pprCI (bagToList cis_of_bound_id)),
- ptext SLIT("Instantiating CIs:"),
- vcat (map pprCI inst_cis)]))
- else id) (
- if top_lev || floating then
- cis_not_bound_id
- else
- (if not (isEmptyBag cis_dump_unboxed)
- then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
- (hang (hcat [char '{',
- interppSP full_ids,
- char '}'])
- 4 (vcat (map pprCI (bagToList cis_dump))))
- else id)
- cis_keep_not_bound_id
- )
- where
- (cis_of_bound_id, cis_not_bound_id)
- = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
-
- (cis_dump, cis_keep_not_bound_id)
- = partitionBag ok_to_dump_ci cis_not_bound_id
-
- ok_to_dump_ci (CallInstance _ _ _ fv_set _)
- = any (\ i -> i `elementOfIdSet` fv_set) full_ids
-
- (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
- have_inst_ci ci = any (eqCI_tys ci) inst_cis
-
- (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
-\end{code}
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
-Any call instances of a bound_id can be safely dumped, because any
-recursive calls should be at the same instance as the parent instance.
+ 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
- letrec f = /\a -> \x::a -> ...(f t x')...
+Now give it to the simplifier and the _Lifting will be optimised away.
-Here, the type, t, at which f is used in its own RHS should be
-just "a"; that is, the recursive call is at the same type as
-the original call. That means that when specialising f at some
-type, say Int#, we shouldn't find any *new* instances of f
-arising from specialising f's RHS. The only instance we'll find
-is another call of (f Int#).
-
-We check this in dumpCIs by passing in all the instantiated call
-instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
-for which there is no such instance.
-
-We also report CIs dumped due to a bound dictionary arg if they
-contain unboxed types.
-
-%************************************************************************
-%* *
-\subsubsection[TyConInstances]{@TyConInstances@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data TyConInstance
- = TyConInstance TyCon -- Type Constructor
- [Maybe Type] -- Applied to these specialising types
-
-cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
-cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-
-cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
- = cmpUniTypeMaybeList tys1 tys2
-
-singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
-singleTyConI ty_con spec_tys
- = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
-
-isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
-isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
-
-isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
-isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
-
-getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
-getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
- = let
- (tycon_cis_local, tycon_cis_global)
- = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
- tycon_cis_local_list = bagToList tycon_cis_local
- in
- (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[UsageDetails]{@UsageDetails@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data UsageDetails
- = UsageDetails
- (Bag CallInstance) -- The collection of call-instances
- (Bag TyConInstance) -- Constructor call-instances
- [DictBindDetails] -- Dictionary bindings in data-dependence order!
- FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
- Int -- no. of spec calls
- Int -- no. of spec insts
-\end{code}
-
-The DictBindDetails are fully processed; their call-instance
-information is incorporated in the call-instances of the UsageDetails
-which includes the DictBindDetails. The free vars in a usage details
-will *include* the binders of the DictBind details.
-
-A @DictBindDetails@ contains bindings for dictionaries *only*.
-
-\begin{code}
-data DictBindDetails
- = DictBindDetails
- [Id] -- Main binders, originally visible in scope of binding (cloned)
- CoreBinding -- Fully processed
- FreeVarsSet -- Free in binding group (cloned)
- FreeTyVarsSet -- Free in binding group
-\end{code}
-
-\begin{code}
-emptyUDs :: UsageDetails
-unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
-unionUDList :: [UsageDetails] -> UsageDetails
-
--- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
-tickSpecInsts :: UsageDetails -> UsageDetails
-
--- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
--- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
-
-tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
- = UsageDetails cis ty_cis dbs fvs c (i+1)
-
-emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
-
-unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
- = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
- (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
- -- The append here is really redundant, since the bindings don't
- -- scope over each other. ToDo.
-
-unionUDList = foldr unionUDs emptyUDs
-
-singleFvUDs (VarArg v) | not (isImportedId v)
- = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
-singleFvUDs other
- = emptyUDs
-
-singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
-
-dumpDBs :: [DictBindDetails]
- -> Bool -- True <=> top level bound Ids
- -> [TyVar] -- TyVars being bound (cloned)
- -> [Id] -- Ids being bound (cloned)
- -> FreeVarsSet -- Fvs of body
- -> ([CoreBinding], -- These ones have to go here
- [DictBindDetails], -- These can float further
- [Id], -- Incoming list + names of dicts bound here
- FreeVarsSet -- Incoming fvs + fvs of dicts bound here
- )
-
- -- It is just to complex to try to float top-level
- -- dict bindings with constant methods, inst methods,
- -- auxillary derived instance defns and user instance
- -- defns all getting in the way.
- -- So we dump all dbinds as soon as we get to the top
- -- level and place them in a *global* Rec.
- -- We leave it to the simplifier will sort it all out ...
-
-dumpDBs [] top_lev bound_tyvars bound_ids fvs
- = ([], [], bound_ids, fvs)
-
-dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
- top_lev bound_tyvars bound_ids fvs
- | top_lev
- || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
- || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
- = let -- Ha! Dump it!
- (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
- in
- (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
-
- | otherwise -- This one can float out further
- = let
- (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
- in
- (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
-
-
-
-dumpUDs :: UsageDetails
- -> Bool -- True <=> top level bound Ids
- -> Bool -- True <=> dict bindings to be floated (specBind only)
- -> [CallInstance] -- Call insts for bound Ids (instBind only)
- -> [Id] -- Ids which are just being bound; *new*
- -> [TyVar] -- TyVars which are just being bound
- -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
- UsageDetails) -- The above bindings removed, and
- -- any call-instances which mention the ids dumped too
-
-dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
- = let
- (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs top_lev tvs bound_ids fvs
- cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
- fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
- in
- (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
-\end{code}
-
-\begin{code}
-addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
- -> UsageDetails -- The usage to augment
- -> UsageDetails
-addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
- (UsageDetails cis tycon_cis dbs fvs c i)
- = UsageDetails (db_cis `unionBags` cis)
- (db_tycon_cis `unionBags` tycon_cis)
- (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
- fvs c i
- -- NB: We ignore counts from dictbinds since it is not user code
- where
- -- The free tyvars of the dictionary bindings should really be
- -- gotten from the RHSs, but I'm pretty sure it's good enough just
- -- to look at the type of the dictionary itself.
- -- Doing the proper job would entail keeping track of free tyvars as
- -- well as free vars, which would be a bore.
- db_ftvs = tyVarsOfTypes (map idType dbinders)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
-%* *
-%************************************************************************
-
-@SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
-
-1) (NoLift LitArg l) : an Id which is bound to a literal
-
-2) (NoLift LitArg l) : an Id bound to a "new" Id
- The new Id is a possibly-type-specialised clone of the original
-
-3) Lifted lifted_id unlifted_id :
-
- This indicates that the original Id has been specialised to an
- unboxed value which must be lifted (see "Unboxed bindings" above)
- @unlifted_id@ is the unboxed clone of the original Id
- @lifted_id@ is a *lifted* version of the original Id
-
- When you lookup Ids which are Lifted, you have to insert a case
- expression to un-lift the value (done with @bindUnlift@)
-
- You also have to insert a case to lift the value in the binding
- (done with @liftExpr@)
-
-
-\begin{code}
-type SpecIdEnv = IdEnv CloneInfo
-
-data CloneInfo
- = NoLift CoreArg -- refers to cloned id or literal
-
- | Lifted Id -- lifted, cloned id
- Id -- unlifted, cloned id
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specialise-data]{Data returned by specialiser}
-%* *
-%************************************************************************
-
-\begin{code}
--}
-
-data SpecialiseData
- = SpecData Bool
- -- True <=> Specialisation performed
- Bool
- -- False <=> Specialisation completed with errors
-
- [TyCon]
- -- Local tycons declared in this module
-
- [TyCon]
- -- Those in-scope data types for which we want to
- -- generate code for their constructors.
- -- Namely: data types declared in this module +
- -- any big tuples used in this module
- -- The initial (and default) value is the local tycons
-
- (FiniteMap TyCon [(Bool, [Maybe Type])])
- -- TyCon specialisations to be generated
- -- We generate specialialised code (Bool=True) for data types
- -- defined in this module and any tuples used in this module
- -- The initial (and default) value is the specialisations
- -- requested by source-level SPECIALIZE data pragmas (Bool=True)
- -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
-
- (Bag (Id,[Maybe Type]))
- -- Imported specialisation errors
- (Bag (Id,[Maybe Type]))
- -- Imported specialisation warnings
- (Bag (TyCon,[Maybe Type]))
- -- Imported TyCon specialisation errors
-
-initSpecData local_tycons tycon_specs
- = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
-
-{-
-\end{code}
-
-ToDo[sansom]: Transformation data to process specialisation requests.
-
-%************************************************************************
-%* *
-\subsection[specProgram]{Specialising a core program}
-%* *
-%************************************************************************
-
-\begin{code}
-specProgram :: UniqSupply
- -> [CoreBinding] -- input ...
- -> SpecialiseData
- -> ([CoreBinding], -- main result
- SpecialiseData) -- result specialise data
-
-specProgram uniqs binds
- (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
- = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
- (final_binds, tycon_specs_list,
- UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
- -> let
- used_conids = filter isDataCon (uniqSetToList fvs)
- used_tycons = map dataConTyCon used_conids
- used_gen = filter isLocalGenTyCon used_tycons
- gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
-
- result_specs = addListToFM_C (++) init_specs tycon_specs_list
-
- uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
- cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
- (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
- cis_warn = init_warn `unionBags` listToBag cis_other
- cis_errs = init_errs `unionBags` listToBag cis_unboxed
-
- uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
- tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
- tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
-
- no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
- && (not opt_SpecialiseImports || isEmptyBag cis_warn)
- in
- (if opt_D_simplifier_stats then
- pprTrace "\nSpecialiser Stats:\n" (vcat [
- hcat [ptext SLIT("SpecCalls "), int spec_calls],
- hcat [ptext SLIT("SpecInsts "), int spec_insts],
- space])
- else id)
-
- (final_binds,
- SpecData True no_errs local_tycons gen_tycons result_specs
- cis_errs cis_warn tycis_errs)
-
-specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
- = panic "Specialise:specProgram: specialiser called more than once"
-
--- It may be possible safely to call the specialiser more than once,
--- but I am not sure there is any benefit in doing so (Patrick)
-
--- ToDo: What about unfoldings performed after specialisation ???
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specTyConsAndScope]{Specialising data constructors within tycons}
-%* *
-%************************************************************************
-
-In the specialiser we just collect up the specialisations which will
-be required. We don't create the specialised constructors in
-Core. These are only introduced when we convert to StgSyn.
-
-ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
-
-\begin{code}
-specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
- -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
-
-specTyConsAndScope scopeM
- = scopeM `thenSM` \ (binds, scope_uds) ->
- let
- (tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
-
- tycon_specs_list = collectTyConSpecs tycons_cis
- in
- (if opt_SpecialiseTrace && not (null tycon_specs_list) then
- pprTrace "Specialising TyCons:\n"
- (vcat [ if not (null specs) then
- hang (hsep [(ppr tycon), ptext SLIT("at types")])
- 4 (vcat (map pp_specs specs))
- else empty
- | (tycon, specs) <- tycon_specs_list])
- else id) (
- returnSM (binds, tycon_specs_list, gotci_scope_uds)
- )
- where
- collectTyConSpecs []
- = []
- collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
- = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
- where
- (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
- uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
- tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
-
- pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specTopBinds]{Specialising top-level bindings}
-%* *
-%************************************************************************
-
-\begin{code}
-specTopBinds :: [CoreBinding]
- -> SpecM ([CoreBinding], UsageDetails)
-
-specTopBinds binds
- = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
- let
- -- Add bindings for floated dbinds and collect fvs
- -- In actual fact many of these bindings are dead code since dict
- -- arguments are dropped when a specialised call is created
- -- The simplifier should be able to cope ...
-
- (dbinders_s, dbinds, dfvs_s)
- = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
-
- full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
- fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
-
- -- It is just to complex to try to sort out top-level dependencies
- -- So we just place all the top-level binds in a *global* Rec and
- -- leave it to the simplifier to sort it all out ...
- in
- ASSERT(null dbinds)
- returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
-
- where
- spec_top_binds (first_bind:rest_binds)
- = specBindAndScope True first_bind (
- spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
- returnSM (ItsABinds rest_binds, rest_uds)
- ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
- returnSM (first_binds ++ rest_binds, all_uds)
-
- spec_top_binds []
- = returnSM ([], emptyUDs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specExpr]{Specialising expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-specExpr :: CoreExpr
- -> [CoreArg] -- The arguments:
- -- TypeArgs are speced
- -- ValArgs are unprocessed
- -> SpecM (CoreExpr, -- Result expression with specialised versions installed
- UsageDetails)-- Details of usage of enclosing binders in the result
- -- expression.
-
-specExpr (Var v) args
- = specId v $ \ v_arg ->
- case v_arg of
- LitArg lit -> ASSERT( null args )
- returnSM (Lit lit, emptyUDs)
-
- VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
- returnSM (mkGenApp (Var new_v) args, uds)
-
-specExpr expr@(Lit _) null_args
- = ASSERT (null null_args)
- returnSM (expr, emptyUDs)
-
-specExpr (Con con args) null_args
- = ASSERT (null null_args)
- specArgs args $ \ args' ->
- mkTyConInstance con args' `thenSM` \ con_uds ->
- returnSM (Con con args', con_uds)
-
-specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
- = ASSERT (null null_args)
- specArgs args $ \ args' ->
- mapSM specTy arg_tys `thenSM` \ arg_tys' ->
- specTy res_ty `thenSM` \ res_ty' ->
- returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
-
-specExpr (Prim prim args) null_args
- = ASSERT (null null_args)
- specArgs args $ \ args' ->
- -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
-
-{- ToDo: specPrimOp
-
-specPrimOp :: PrimOp
- -> [Type]
- -> SpecM (PrimOp,
- [Type],
- UsageDetails)
-
--- Checks that PrimOp can handle (possibly unboxed) tys passed
--- and/or chooses PrimOp specialised to any unboxed tys
--- Errors are dealt with by returning a PrimOp call instance
--- which will result in a cis_errs message
-
--- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
--}
-
-
-specExpr (App fun arg) args
- = specArg arg `thenSM` \ new_arg ->
- specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
- returnSM (expr, uds)
-
-specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
- = lookup_arg arg `thenSM` \ arg ->
- bindId binder arg (specExpr body args)
- where
- lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
- lookup_arg (VarArg v) = lookupId v
-
-specExpr (Lam (ValBinder binder) body) []
- = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
- returnSM (Lam (ValBinder binder) body, uds)
-
-specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
- = -- Type lambda with argument; argument already spec'd
- bindTyVar tyvar ty ( specExpr body args )
-
-specExpr (Lam (TyBinder tyvar) body) []
- = -- No arguments
- cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
- bindTyVar tyvar (mkTyVarTy new_tyvar) (
- specExpr body [] `thenSM` \ (body, body_uds) ->
- let
- (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
- in
- returnSM (Lam (TyBinder new_tyvar)
- (mkCoLetsNoUnboxed binds_here body),
- final_uds)
- )
-
-specExpr (Case scrutinee alts) args
- = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
- specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
- returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
- where
- scrutinee_type = coreExprType scrutinee
-
-specExpr (Let bind body) args
- = specBindAndScope False bind (
- specExpr body args `thenSM` \ (body, body_uds) ->
- returnSM (ItsAnExpr body, body_uds)
- ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
- returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
-
-specExpr (SCC cc expr) args
- = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
- mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
- let
- scc_expr
- = if squashableDictishCcExpr cc expr -- can toss the _scc_
- then expr
- else SCC cc expr
- in
- returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
- unionUDList args_uds_s `unionUDs` expr_uds)
-
-specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
-
--- ToDo: This may leave some unspec'd dictionaries!!
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Specialising a lambda}
-%* *
-%************************************************************************
-
-\begin{code}
-specLambdaOrCaseBody :: [Id] -- The binders
- -> CoreExpr -- The body
- -> [CoreArg] -- Its args
- -> SpecM ([Id], -- New binders
- CoreExpr, -- New body
- UsageDetails)
-
-specLambdaOrCaseBody bound_ids body args
- = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
- bindIds bound_ids clone_infos (
-
- specExpr body args `thenSM` \ (body, body_uds) ->
-
- let
- -- Dump any dictionary bindings (and call instances)
- -- from the scope which mention things bound here
- (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
- in
- returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
- )
-
--- ToDo: Opportunity here to common-up dictionaries with same type,
--- thus avoiding recomputation.
-\end{code}
-
-A variable bound in a lambda or case is normally monomorphic so no
-specialised versions will be required. This is just as well since we
-do not know what code to specialise!
-
-Unfortunately this is not always the case. For example a class Foo
-with polymorphic methods gives rise to a dictionary with polymorphic
-components as follows:
-
-\begin{verbatim}
-class Foo a where
- op1 :: a -> b -> a
- op2 :: a -> c -> a
-
-instance Foo Int where
- op1 = op1Int
- op2 = op2Int
-
-... op1 1 3# ...
-
-==>
-
-d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
-d.Foo.Int = (op1_Int, op2_Int)
-
-op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-
-... op1 {Int Int#} d.Foo.Int 1 3# ...
-\end{verbatim}
-
-N.B. The type of the dictionary is not Hindley Milner!
-
-Now we must specialise op1 at {* Int#} which requires a version of
-meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
-not have access to its code to create the specialised version.
-
-If we specialise on overloaded types as well we specialise op1 at
-{Int Int#} d.Foo.Int:
-
-op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
-
-Though this is still invalid, after further simplification we get:
-
-op1_Int_Int# = opInt1 {Int#}
-
-Another round of specialisation will result in the specialised
-version of op1Int being called directly.
-
-For now we PANIC if a polymorphic lambda/case bound variable is found
-in a call instance with an unboxed type. Other call instances, arising
-from overloaded type arguments, are discarded since the unspecialised
-version extracted from the method can be called as normal.
-
-ToDo: Implement and test second round of specialisation.
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising case alternatives}
-%* *
-%************************************************************************
-
-
-\begin{code}
-specAlts (AlgAlts alts deflt) scrutinee_ty args
- = mapSM specTy ty_args `thenSM` \ ty_args ->
- mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (AlgAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
- where
- -- We use ty_args of scrutinee type to identify specialisation of
- -- alternatives:
-
- (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
- splitAlgTyConApp scrutinee_ty
-
- specAlgAlt ty_args (con,binders,rhs)
- = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
- mkTyConInstance con ty_args `thenSM` \ con_uds ->
- returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-
-specAlts (PrimAlts alts deflt) scrutinee_ty args
- = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (PrimAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
- where
- specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
- returnSM ((lit,rhs), uds)
-
-
-specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
-specDeflt (BindDefault binder rhs) args
- = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (BindDefault binder rhs, uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising an atom}
-%* *
-%************************************************************************
-
-\begin{code}
-partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
-partition_args args
- = span is_ty_arg args
- where
- is_ty_arg (TyArg _) = True
- is_ty_arg _ = False
-
-----------
-specId :: Id
- -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
- -> SpecM (CoreExpr, UsageDetails)
-specId v
- = lookupId v `thenSM` \ vlookup ->
- case vlookup of
-
- Lifted vl vu
- -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
- returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
-
- NoLift vatom
- -> thing_inside vatom `thenSM` \ (expr, uds) ->
- returnSM (expr, singleFvUDs vatom `unionUDs` uds)
-
-specArg :: CoreArg
- -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
- -> SpecM (CoreExpr, UsageDetails))
-
-specArg (TyArg ty) thing_inside
- = specTy ty `thenSM` \ new_ty ->
- thing_inside (TyArg new_ty)
-
-specArg (LitArg lit)
- = thing_inside (LitArg lit)
-
-specArg (VarArg v)
-
-
-specArgs [] thing_inside
- = thing_inside []
-
-specArgs (arg:args) thing_inside
- = specArg arg $ \ arg' ->
- specArgs args $ \ args' ->
- thing_inside (arg' : args')
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising bindings}
-%* *
-%************************************************************************
-
-A classic case of when having a polymorphic recursive function would help!
-
-\begin{code}
-data BindsOrExpr = ItsABinds [CoreBinding]
- | ItsAnExpr CoreExpr
-\end{code}
-
-\begin{code}
-specBindAndScope
- :: Bool -- True <=> a top level group
- -> CoreBinding -- As yet unprocessed
- -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([CoreBinding], -- Processed
- BindsOrExpr, -- Combined result
- UsageDetails) -- Usage details of the whole lot
-
-specBindAndScope top_lev bind scopeM
- = cloneLetBinders top_lev (is_rec bind) binders
- `thenSM` \ (new_binders, clone_infos) ->
-
- -- Two cases now: either this is a bunch of local dictionaries,
- -- in which case we float them; or its a bunch of other values,
- -- in which case we see if they correspond to any call-instances
- -- we have from processing the scope
-
- if not top_lev && all (isDictTy . idType) binders
- then
- -- Ha! A group of local dictionary bindings
-
- bindIds binders clone_infos (
-
- -- Process the dictionary bindings themselves
- specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
-
- -- Process their scope
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- -- Add the bindings to the current stuff
- final_uds = addDictBinds new_binders bind rhs_uds scope_uds
- in
- returnSM ([], thing, final_uds)
- )
- else
- -- Ho! A group of bindings
-
- fixSM (\ ~(_, _, _, rec_spec_infos) ->
-
- bindSpecIds binders clone_infos rec_spec_infos (
- -- It's ok to have new binders in scope in
- -- non-recursive decls too, cos name shadowing is gone by now
-
- -- Do the scope of the bindings
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
-
- equiv_ciss = equivClasses cmpCI_tys call_insts
- inst_cis = map head equiv_ciss
- in
-
- -- Do the bindings themselves
- specBind top_lev False new_binders inst_cis bind
- `thenSM` \ (spec_bind, spec_uds) ->
-
- -- Create any necessary instances
- instBind top_lev new_binders bind equiv_ciss inst_cis
- `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
-
- let
- -- NB: dumpUDs only worries about new_binders since the free var
- -- stuff only records free new_binders
- -- The spec_ids only appear in SpecInfos and final speced calls
-
- -- Build final binding group and usage details
- (final_binds, final_uds)
- = if top_lev then
- -- For a top-level binding we have to dumpUDs from
- -- spec_uds and inst_uds and scope_uds creating
- -- *global* dict bindings
- let
- (scope_dict_binds, final_scope_uds)
- = dumpUDs gotci_scope_uds True False [] new_binders []
- (spec_dict_binds, final_spec_uds)
- = dumpUDs spec_uds True False inst_cis new_binders []
- (inst_dict_binds, final_inst_uds)
- = dumpUDs inst_uds True False inst_cis new_binders []
- in
- ([spec_bind] ++ inst_binds ++ scope_dict_binds
- ++ spec_dict_binds ++ inst_dict_binds,
- final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
- else
- -- For a local binding we only have to dumpUDs from
- -- scope_uds since the UDs from spec_uds and inst_uds
- -- have already been dumped by specBind and instBind
- let
- (scope_dict_binds, final_scope_uds)
- = dumpUDs gotci_scope_uds False False [] new_binders []
- in
- ([spec_bind] ++ inst_binds ++ scope_dict_binds,
- spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
-
- -- inst_uds comes last, because there may be dict bindings
- -- floating outward in scope_uds which are mentioned
- -- in the call-instances, and hence in spec_uds.
- -- This ordering makes sure that the precedence order
- -- among the dict bindings finally floated out is maintained.
- in
- returnSM (final_binds, thing, final_uds, spec_infos)
- )
- ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
- returnSM (binds, thing, final_uds)
- where
- binders = bindersOf bind
-
- is_rec (NonRec _ _) = False
- is_rec _ = True
-\end{code}
-
-\begin{code}
-specBind :: Bool -> Bool -> [Id] -> [CallInstance]
- -> CoreBinding
- -> SpecM (CoreBinding, UsageDetails)
- -- The UsageDetails returned has already had stuff to do with this group
- -- of binders deleted; that's why new_binders is passed in.
-specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
- = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
- `thenSM` \ ((binder,rhs), rhs_uds) ->
- returnSM (NonRec binder rhs, rhs_uds)
-
-specBind top_lev floating new_binders inst_cis (Rec pairs)
- = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
- `thenSM` \ (pairs, rhs_uds_s) ->
- returnSM (Rec pairs, unionUDList rhs_uds_s)
-
-
-specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
- -> (Id,CoreExpr)
- -> SpecM ((Id,CoreExpr), UsageDetails)
-
-specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
- = lookupId binder `thenSM` \ blookup ->
- specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
- let
- specid_maybe_maybe = isSpecPragmaId_maybe binder
- is_specid = maybeToBool specid_maybe_maybe
- Just specinfo_maybe = specid_maybe_maybe
- specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
-
- -- If we have a SpecInfo stored in a SpecPragmaId binder
- -- it will contain a SpecInfo with an explicit SpecId
- -- We add the explicit ci to the usage details
- -- Any ordinary cis for orig_id (there should only be one)
- -- will be ignored later
-
- pragma_uds
- = if is_specid && specid_with_info then
- let
- (SpecInfo spec_tys _ spec_id) = spec_info
- Just (orig_id, _) = isSpecId_maybe spec_id
- in
- ASSERT(toplevelishId orig_id) -- must not be cloned!
- explicitCI orig_id spec_tys spec_info
- else
- emptyUDs
-
- -- For a local binding we dump the usage details, creating
- -- any local dict bindings required
- -- At the top-level the uds will be dumped in specBindAndScope
- -- and the dict bindings made *global*
-
- (local_dict_binds, final_uds)
- = if not top_lev then
- dumpUDs rhs_uds False floating inst_cis new_binders []
- else
- ([], rhs_uds)
- in
- case blookup of
- Lifted lift_binder unlift_binder
- -> -- We may need to record an unboxed instance of
- -- the _Lift data type in the usage details
- mkTyConInstance liftDataCon [idType unlift_binder]
- `thenSM` \ lift_uds ->
- returnSM ((lift_binder,
- mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
- final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
-
- NoLift (VarArg binder)
- -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
- final_uds `unionUDs` pragma_uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@instBind@}
-%* *
-%************************************************************************
-
-\begin{code}
-instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
- | null equiv_ciss
- = returnSM ([], emptyUDs, [])
-
- | all same_overloading other_binders
- = -- For each call_inst, build an instance
- mapAndUnzip3SM do_this_class equiv_ciss
- `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
-
- -- Add in the remaining UDs
- returnSM (catMaybes inst_binds,
- unionUDList inst_uds_s,
- spec_infos
- )
-
- | otherwise -- Incompatible overloadings; see below by same_overloading
- = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
- then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
- else if top_lev
- then pprTrace "dumpCIs: not same overloading ... top level \n"
- else (\ x y -> y)
- ) (hang (hcat [ptext SLIT("{"),
- interppSP new_ids,
- ptext SLIT("}")])
- 4 (vcat [vcat (map (pprGenType . idType) new_ids),
- vcat (map pprCI (concat equiv_ciss))]))
- (returnSM ([], emptyUDs, []))
-
- where
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
- tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
-
- no_of_tyvars = length tyvar_tmpls
- no_of_dicts = length class_tyvar_pairs
-
- do_this_class equiv_cis
- = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
- where
- (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
- do_cis = head (normal_cis ++ explicit_cis)
- -- must choose a normal_cis in preference since dict_args will
- -- not be defined for an explicit_cis
-
- -- same_overloading tests whether the types of all the binders
- -- are "compatible"; ie have the same type and dictionary abstractions
- -- Almost always this is the case, because a recursive group is abstracted
- -- all together. But, it can happen that it ain't the case, because of
- -- code generated from instance decls:
- --
- -- rec
- -- dfun.Foo.Int :: (forall a. a -> Int, Int)
- -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
- --
- -- const.op1.Int :: forall a. a -> Int
- -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
- --
- -- const.op2.Int :: Int
- -- const.op2.Int = 3
- --
- -- Note that the first two defns have different polymorphism, but they are
- -- mutually recursive!
-
- same_overloading :: Id -> Bool
- same_overloading id
- = no_of_tyvars == length this_id_tyvars
- -- Same no of tyvars
- && no_of_dicts == length this_id_class_tyvar_pairs
- -- Same no of vdicts
- && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
- && length class_tyvar_pairs == length this_id_class_tyvar_pairs
- -- Same overloading
- where
- (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
- tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
-
- same_ov (clas1,tyvar1) (clas2,tyvar2)
- = clas1 == clas2 &&
- tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
-\end{code}
-
-OK, so we have:
- - a call instance eg f [t1,t2,t3] [d1,d2]
- - the rhs of the function eg orig_rhs
- - a constraint vector, saying which of eg [T,F,T]
- the functions type args are constrained
- (ie overloaded)
-
-We return a new definition
-
- $f1 = /\a -> orig_rhs t1 a t3 d1 d2
-
-The SpecInfo for f will be:
-
- SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
-
-Based on this SpecInfo, a call instance of f
-
- ...(f t1 t2 t3)...
-
-should get replaced by
-
- ...(\d1 d2 -> $f1 t2)...
-
-(But that is the business of the simplifier.)
-
-\begin{code}
-mkOneInst :: CallInstance
- -> [CallInstance] -- Any explicit cis for this inst
- -> Int -- No of dicts to specialise
- -> Bool -- Top level binders?
- -> [CallInstance] -- Instantiated call insts for binders
- -> [Id] -- New binders
- -> CoreBinding -- Unprocessed
- -> SpecM (Maybe CoreBinding, -- Instantiated version of input
- UsageDetails,
- [Maybe SpecInfo] -- One for each id in the original binding
- )
-
-mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
- no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
- = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
- `thenSM` \ spec_ids ->
- newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
- let
- -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
- -- which correspond to unspecialised args
- arg_tys :: [Type]
- (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
-
- args :: [CoreArg]
- args = map TyArg arg_tys ++ dict_args
-
- (new_id:_) = new_ids
- (spec_id:_) = spec_ids
-
- do_bind (NonRec orig_id rhs)
- = do_one_rhs (spec_id, new_id, (orig_id,rhs))
- `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
- case maybe_spec of
- Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
- Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
-
- do_bind (Rec pairs)
- = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
- `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
- returnSM (Just (Rec (catMaybes maybe_pairs)),
- unionUDList rhss_uds_s, spec_infos)
-
- do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
-
- -- Avoid duplicating a spec which has already been created ...
- -- This can arise in a Rec involving a dfun for which a
- -- a specialised instance has been created but specialisation
- -- "required" by one of the other Ids in the Rec
- | top_lev && maybeToBool lookup_orig_spec
- = (if opt_SpecialiseTrace
- then trace_nospec " Exists: " orig_id
- else id) (
-
- returnSM (Nothing, emptyUDs, Nothing)
- )
-
- -- Check for a (single) explicit call instance for this id
- | not (null explicit_cis_for_this_id)
- = ASSERT (length explicit_cis_for_this_id == 1)
- (if opt_SpecialiseTrace
- then trace_nospec " Explicit: " explicit_id
- else id) (
-
- returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
- )
-
- -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
- | otherwise
- = ASSERT (no_of_dicts_to_specialise == length dict_args)
- specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
- let
- -- For a local binding we dump the usage details, creating
- -- any local dict bindings required
- -- At the top-level the uds will be dumped in specBindAndScope
- -- and the dict bindings made *global*
-
- (local_dict_binds, final_uds)
- = if not top_lev then
- dumpUDs inst_uds False False inst_cis new_ids []
- else
- ([], inst_uds)
-
- spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
- in
- if isUnboxedType (idType spec_id) then
- ASSERT (null poly_tyvars)
- liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
- mkTyConInstance liftDataCon [idType unlift_spec_id]
- `thenSM` \ lift_uds ->
- returnSM (Just (lift_spec_id,
- mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
- tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
- else
- returnSM (Just (spec_id,
- mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
- tickSpecInsts final_uds, spec_info)
- where
- lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys
-
- explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
- [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
- SpecInfo _ _ explicit_id = explicit_spec_info
-
- trace_nospec :: String -> Id -> a -> a
- trace_nospec str spec_id
- = pprTrace str
- (hsep [ppr new_id, hsep (map pp_ty arg_tys),
- ptext SLIT("==>"), ppr spec_id])
- in
- (if opt_SpecialiseTrace then
- pprTrace "Specialising:"
- (hang (hcat [char '{',
- interppSP new_ids,
- char '}'])
- 4 (vcat [
- hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
- if isExplicitCI do_cis then empty else
- hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
- hcat [ptext SLIT("specs: "), ppr spec_ids]]))
- else id) (
-
- do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
-
- returnSM (maybe_inst_bind, inst_uds, spec_infos)
- )
- where
- pp_dict d = ppr_arg d
- pp_ty t = pprParendGenType t
-
- do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
- do_the_wotsit tyvars (Just ty) = (tyvars, ty)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Misc]{Miscellaneous junk}
-%* *
-%************************************************************************
-
-\begin{code}
-mkCallInstance :: Id
- -> Id
- -> [CoreArg]
- -> SpecM UsageDetails
-
-mkCallInstance id new_id args
- | null args || -- No args at all
- idWantsToBeINLINEd id || -- It's going to be inlined anyway
- not enough_args || -- Not enough type and dict args
- not interesting_overloading -- Overloaded types are just tyvars
- = returnSM emptyUDs
-
- | otherwise
- = returnSM (singleCI new_id spec_tys dicts)
-
- where
- (tyvars, theta, _) = splitSigmaTy (idType id)
- constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
-
- arg_res = take_type_args tyvars class_tyvar_pairs args
- enough_args = maybeToBool arg_res
- (Just (tys, dicts, rest_args)) = arg_res
-
- interesting_overloading = not (null (catMaybes spec_tys))
- spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
-
- ---------------------------------------------------------------
- -- Should we specialise on this type argument?
- spec_ty tyvar ty | isTyVarTy ty = Nothing
-
- spec_ty tyvar ty | opt_SpecialiseAll
- || (opt_SpecialiseUnboxed
- && isUnboxedType ty
- && isBoxedTypeKind (tyVarKind tyvar))
- || (opt_SpecialiseOverloaded
- && tyvar `elemTyVarSet` constrained_tyvars)
- = Just ty
-
- | otherwise = Nothing
-
- ----------------- Rather a gruesome help-function ---------------
- take_type_args (_:tyvars) (TyArg ty : args)
- = case (take_type_args tyvars args) of
- Nothing -> Nothing
- Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-
- take_type_args (_:tyvars) [] = Nothing
-
- take_type_args [] args
- = case (take_dict_args class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (dicts, others) -> Just ([], dicts, others)
-
- take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
- = case (take_dict_args class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (dicts, others) -> Just (dict:dicts, others)
-
- take_dict_args (_:class_tyvar_pairs) args = Nothing
-
- take_dict_args [] args = Just ([], args)
-\end{code}
-
-
-\begin{code}
-mkTyConInstance :: Id
- -> [Type]
- -> SpecM UsageDetails
-mkTyConInstance con tys
- = recordTyConInst con tys `thenSM` \ record_inst ->
- case record_inst of
- Nothing -- No TyCon instance
- -> -- pprTrace "NoTyConInst:"
- -- (hsep [ppr tycon, ptext SLIT("at"),
- -- ppr con, hsep (map (ppr) tys)])
- (returnSM (singleConUDs con))
-
- Just spec_tys -- Record TyCon instance
- -> -- pprTrace "TyConInst:"
- -- (hsep [ppr tycon, ptext SLIT("at"),
- -- ppr con, hsep (map (ppr) tys),
- -- hcat [char '(',
- -- hsep [pprMaybeTy ty | ty <- spec_tys],
- -- char ')']])
- (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
- where
- tycon = dataConTyCon con
-\end{code}
-
-\begin{code}
-recordTyConInst :: Id
- -> [Type]
- -> SpecM (Maybe [Maybe Type])
-
-recordTyConInst con tys
- = let
- spec_tys = specialiseConstrTys tys
-
- do_tycon_spec = maybeToBool (firstJust spec_tys)
-
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation con)
- tys)
- in
- -- pprTrace "ConSpecExists?: "
- -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
- -- ppr PprShowAll con, hsep (map ppr tys)])
- (if (not spec_exists && do_tycon_spec)
- then returnSM (Just spec_tys)
- else returnSM Nothing)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[monad-Specialise]{Monad used in specialisation}
-%* *
-%************************************************************************
-
-Monad has:
-
- inherited: control flags and
- recordInst functions with flags cached
-
- environment mapping tyvars to types
- environment mapping Ids to Atoms
-
- threaded in and out: unique supply
-
-\begin{code}
-type TypeEnv = TyVarEnv Type
-
-type SpecM result
- = TypeEnv
- -> SpecIdEnv
- -> UniqSupply
- -> result
-
-initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
-
-returnSM :: a -> SpecM a
-thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
-fixSM :: (a -> SpecM a) -> SpecM a
-
-thenSM m k tvenv idenv us
- = case splitUniqSupply us of { (s1, s2) ->
- case (m tvenv idenv s1) of { r ->
- k r tvenv idenv s2 }}
-
-returnSM r tvenv idenv us = r
-
-fixSM k tvenv idenv us
- = r
- where
- r = k r tvenv idenv us -- Recursive in r!
-\end{code}
-
-The only interesting bit is figuring out the type of the SpecId!
-
-\begin{code}
-newSpecIds :: [Id] -- The id of which to make a specialised version
- -> [Maybe Type] -- Specialise to these types
- -> Int -- No of dicts to specialise
- -> SpecM [Id]
-
-newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
- = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
- | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
- where
- uniqs = getUniques (length new_ids) us
- spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
-
-newTyVars :: Int -> SpecM [TyVar]
-newTyVars n tvenv idenv us
- = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
-\end{code}
-
-@cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
-binders, and build ``clones'' for them. The clones differ from the
-originals in three ways:
-
- (a) they have a fresh unique
- (b) they have the current type environment applied to their type
- (c) for Let binders which have been specialised to unboxed values
- the clone will have a lifted type
-
-As well as returning the list of cloned @Id@s they also return a list of
-@CloneInfo@s which the original binders should be bound to.
-
-\begin{code}
-cloneLambdaOrCaseBinders :: [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
-
-cloneLambdaOrCaseBinders old_ids tvenv idenv us
- = let
- uniqs = getUniques (length old_ids) us
- in
- unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
- where
- clone_it old_id uniq
- = (new_id, NoLift (VarArg new_id))
- where
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
-
-cloneLetBinders :: Bool -- Top level ?
- -> Bool -- Recursice
- -> [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
-
-cloneLetBinders top_lev is_rec old_ids tvenv idenv us
- = let
- uniqs = getUniques (2 * length old_ids) us
- in
- unzip (clone_them old_ids uniqs)
- where
- clone_them [] [] = []
-
- clone_them (old_id:olds) (u1:u2:uniqs)
- | top_lev
- = (old_id,
- NoLift (VarArg old_id)) : clone_rest
-
- -- Don't clone if it is a top-level thing. Why not?
- -- (a) we don't want to change the uniques
- -- on such things
- -- (b) we don't have to be paranoid about name capture
- -- (c) the thing is polymorphic so no need to subst
-
- | otherwise
- = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
- then (lifted_id,
- Lifted lifted_id unlifted_id) : clone_rest
- else (new_id,
- NoLift (VarArg new_id)) : clone_rest
-
- where
- clone_rest = clone_them olds uniqs
-
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
- new_ty = idType new_id
- old_ty = idType old_id
-
- (lifted_id, unlifted_id) = mkLiftedId new_id u2
-
-
-cloneTyVarSM :: TyVar -> SpecM TyVar
-
-cloneTyVarSM old_tyvar tvenv idenv us
- = let
- uniq = getUnique us
- in
- cloneTyVar old_tyvar uniq -- new_tyvar
-
-bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
-
-bindId id val specm tvenv idenv us
- = specm tvenv (addOneToIdEnv idenv id val) us
-
-bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
-
-bindIds olds news specm tvenv idenv us
- = specm tvenv (growIdEnvList idenv (zip olds news)) us
-
-bindSpecIds :: [Id] -- Old
- -> [(CloneInfo)] -- New
- -> [[Maybe SpecInfo]] -- Corresponding specialisations
- -- Each sub-list corresponds to a different type,
- -- and contains one Maybe spec_info for each id
- -> SpecM thing
- -> SpecM thing
-
-bindSpecIds olds clones spec_infos specm tvenv idenv us
- = specm tvenv (growIdEnvList idenv old_to_clone) us
- where
- old_to_clone = mk_old_to_clone olds clones spec_infos
-
- -- The important thing here is that we are *lazy* in spec_infos
- mk_old_to_clone [] [] _ = []
- mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
- = (old, add_spec_info clone) :
- mk_old_to_clone rest_olds rest_clones spec_infos_rest
- where
- add_spec_info (NoLift (VarArg new))
- = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
- add_spec_info lifted
- = lifted -- no specialised instances for unboxed lifted values
-
- spec_infos_this_id = catMaybes (map head spec_infos)
- spec_infos_rest = map tail spec_infos
-
-
-bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
-
-bindTyVar tyvar ty specm tvenv idenv us
- = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
-\end{code}
-
-\begin{code}
-lookupId :: Id -> SpecM CloneInfo
-
-lookupId id tvenv idenv us
- = case lookupIdEnv idenv id of
- Nothing -> NoLift (VarArg id)
- Just info -> info
-\end{code}
-
-\begin{code}
-specTy :: Type -> SpecM Type -- Apply the current type envt to the type
-
-specTy ty tvenv idenv us
- = instantiateTy tvenv ty
-\end{code}
-
-\begin{code}
-liftId :: Id -> SpecM (Id, Id)
-liftId id tvenv idenv us
- = let
- uniq = getUnique us
- in
- mkLiftedId id uniq
-\end{code}
-
-In other monads these @mapSM@ things are usually called @listM@.
-I think @mapSM@ is a much better name. The `2' and `3' variants are
-when you want to return two or three results, and get at them
-separately. It saves you having to do an (unzip stuff) right after.
-
-\begin{code}
-mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
-mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
-mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
-mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
-
-mapSM f [] = returnSM []
-mapSM f (x:xs) = f x `thenSM` \ r ->
- mapSM f xs `thenSM` \ rs ->
- returnSM (r:rs)
-
-mapAndUnzipSM f [] = returnSM ([],[])
-mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
- mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
- returnSM ((r1:rs1),(r2:rs2))
-
-mapAndUnzip3SM f [] = returnSM ([],[],[])
-mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
- mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
-
-mapAndUnzip4SM f [] = returnSM ([],[],[],[])
-mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
- mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
--}
-\end{code}
-
-
-
-===================== OLD CODE, scheduled for deletion =================
-
-\begin{code}
-{-
-mkCall :: Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM CoreExpr
-
-mkCall new_id arg_infos = returnSM (
-
- | maybeToBool (isSuperDictSelId_maybe new_id)
- && any isUnboxedType ty_args
- -- No specialisations for super-dict selectors
- -- Specialise unboxed calls to SuperDictSelIds by extracting
- -- the super class dictionary directly form the super class
- -- NB: This should be dead code since all uses of this dictionary should
- -- have been specialised. We only do this to keep core-lint happy.
- = let
- Just (_, super_class) = isSuperDictSelId_maybe new_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
- Nothing -> panic "Specialise:mkCall:SuperDictId"
- Just id -> id
- in
- returnSM (False, Var super_dict_id)
-
- | otherwise
- = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
- Nothing -> checkUnspecOK new_id ty_args (
- returnSM (False, unspec_call)
- )
-
- Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
- -> let
- -- It may be necessary to specialsie a constant method spec_id again
- (spec_id, tys_left, dicts_to_toss) =
- case (maybeToBool (isConstMethodId_maybe spec_id_1),
- lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
- (False, _ ) -> spec_1_details
- (True, Nothing) -> spec_1_details
- (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
- -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
-
- args_left = toss_dicts dicts_to_toss val_args
- in
- checkSpecOK new_id ty_args spec_id tys_left (
-
- -- The resulting spec_id may be a top-level unboxed value
- -- This can arise for:
- -- 1) constant method values
- -- eq: class Num a where pi :: a
- -- instance Num Double# where pi = 3.141#
- -- 2) specilised overloaded values
- -- eq: i1 :: Num a => a
- -- i1 Int# d.Num.Int# ==> i1.Int#
- -- These top level defns should have been lifted.
- -- We must add code to unlift such a spec_id.
-
- if isUnboxedType (idType spec_id) then
- ASSERT (null tys_left && null args_left)
- if toplevelishId spec_id then
- liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
- returnSM (True, bindUnlift lift_spec_id unlift_spec_id
- (Var unlift_spec_id))
- else
- pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
- (hsep [ppr new_id,
- hsep (map (pprParendGenType) ty_args),
- ptext SLIT("==>"),
- ppr spec_id])
- else
- let
- (vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkTyApp (Var spec_id) tys_left
- applied_vals = mkGenApp applied_tys vals_left
- in
- returnSM (True, applyBindUnlifts unlifts_left applied_vals)
- )
- where
- (tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
+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:
- -- ty_args is the types at the front of the arg list
- -- val_args is the rest of the arg-list
+ 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
- (ty_args, val_args) = get args
- where
- get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
- -- toss_dicts chucks away dict args, checking that they ain't types!
- toss_dicts 0 args = args
- toss_dicts n ((a,_,_) : args)
- | isValArg a = toss_dicts (n-1) args
+Question: When won't the _Lifting be eliminated?
-\end{code}
+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.
-\begin{code}
-checkUnspecOK :: Id -> [Type] -> a -> a
-checkUnspecOK check_id tys
- = if isLocallyDefined check_id && any isUnboxedType tys
- then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
- (hsep [ppr check_id,
- hsep (map (pprParendGenType) tys)])
- else id
-
-checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
-checkSpecOK check_id tys spec_id tys_left
- = if any isUnboxedType tys_left
- then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
- (vcat [hsep [ppr check_id,
- hsep (map (pprParendGenType) tys)],
- hsep [ppr spec_id,
- hsep (map (pprParendGenType) tys_left)]])
- else id
--}
-\end{code}
projects / ghc-hetmet.git / blobdiff