X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=fa067429abadcc24678b9284da7e2c9c34d74fea;hb=43d903cfaafb0b41242af128c7ddbf0b649f63bd;hp=0e66b0bc7820d7cd4dfa1d7ac42e6f7f83727416;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 0e66b0b..fa06742 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -9,7 +9,8 @@ module Specialise ( specProgram ) where #include "HsVersions.h" import DynFlags ( DynFlags, DynFlag(..) ) -import Id ( Id, idName, idType, mkUserLocal ) +import Id ( Id, idName, idType, mkUserLocal, + idInlinePragma, setInlinePragma ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, isClassPred, tcCmpType, isUnLiftedType @@ -22,7 +23,7 @@ import VarSet import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs, mkPiTypes ) -import CoreFVs ( exprFreeVars, exprsFreeVars, idRuleVars ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import CoreTidy ( tidyRules ) import CoreLint ( showPass, endPass ) import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds ) @@ -31,7 +32,7 @@ import UniqSupply ( UniqSupply, UniqSM, initUs_, thenUs, returnUs, getUniqueUs, getUs, mapUs ) -import Name ( nameOccName, mkSpecOcc, getSrcLoc ) +import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, maybeToBool ) @@ -623,7 +624,9 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) 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 subst (Cast e co) = + specExpr subst e `thenSM` \ (e', uds) -> + returnSM ((Cast e' (substTy subst co)), uds) specExpr subst (Note note body) = specExpr subst body `thenSM` \ (body', uds) -> returnSM (Note (specNote subst note) body', uds) @@ -687,7 +690,6 @@ specExpr subst (Let bind body) 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} @@ -781,17 +783,14 @@ specDefn :: Subst -- Subst to use for RHS specDefn subst calls (fn, rhs) -- The first case is the interesting one - | 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 + | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas + && rhs_ids `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 +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions + = -- Specialise the body of the function specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> @@ -807,7 +806,9 @@ specDefn subst calls (fn, rhs) rhs_uds `plusUDs` plusUDList spec_uds) | otherwise -- No calls or RHS doesn't fit our preconceptions - = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> + = WARN( notNull calls_for_me, ptext SLIT("Missed specialisation opportunity for") <+> ppr fn ) + -- Note [Specialisation shape] + specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> returnSM ((fn, rhs'), [], rhs_uds) where @@ -815,11 +816,12 @@ specDefn subst calls (fn, rhs) (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta + inline_prag = idInlinePragma fn - (rhs_tyvars, rhs_ids, rhs_body) - = collectTyAndValBinders (dropInline rhs) -- It's important that we "see past" any INLINE pragma -- else we'll fail to specialise an INLINE thing + (inline_rhs, rhs_inside) = dropInline rhs + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside rhs_dicts = take n_dicts rhs_ids rhs_bndrs = rhs_tyvars ++ rhs_dicts @@ -891,25 +893,79 @@ specDefn subst calls (fn, rhs) -- 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. - + spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs) + | otherwise = (spec_f, spec_rhs) in - returnSM ((spec_f, spec_rhs), - final_uds, - spec_env_rule) + returnSM (spec_pr, 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) +#ifdef DEBUG + | not (equalLength xs ys) = pprPanic "my_zipEqual" (vcat + [ ppr xs, ppr ys + , ppr fn <+> ppr call_ts + , ppr (idType fn), ppr theta + , ppr n_dicts, ppr rhs_dicts + , ppr rhs]) +#endif | otherwise = zipEqual doc xs ys +\end{code} -dropInline :: CoreExpr -> CoreExpr -dropInline (Note InlineMe rhs) = rhs -dropInline rhs = rhs +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +This doesn't always work. One example I came across was htis: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly exapmle, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We transfer to the specialised function any INLINE stuff from the +original. This means (a) the Activation in the IdInfo, and (b) any +InlineMe on the RHS. + +This is a change (Jun06). Previously 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 +*pragma-directed* specialisation now takes place in the +typechecker/desugarer, with manually specified INLINEs. The +specialiation here is automatic. It'd be very odd if a function +marked INLINE was specialised (because of some local use), and then +forever after (including importing modules) the specialised version +wasn't INLINEd. After all, the programmer said INLINE! + +You might wonder why we don't just not specialise INLINE functions. +It's because even INLINE functions are sometimes not inlined, when +they aren't applied to interesting arguments. But perhaps the type +arguments alone are enough to specialise (even though the args are too +boring to trigger inlining), and it's certainly better to call the +specialised version. + +A case in point is dictionary functions, which are current marked +INLINE, but which are worth specialising. + +\begin{code} +dropInline :: CoreExpr -> (Bool, CoreExpr) +dropInline (Note InlineMe rhs) = (True, rhs) +dropInline rhs = (False, rhs) \end{code} %************************************************************************ @@ -1050,10 +1106,12 @@ bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs bndrs = map fst prs rhs_fvs = unionVarSets (map pair_fvs prs) -pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr +pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr -- Don't forget variables mentioned in the -- rules of the bndr. C.f. OccAnal.addRuleUsage - + -- Also tyvars mentioned in its type; they may not appear in the RHS + -- type T a = Int + -- x :: T a = 3 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds } @@ -1160,7 +1218,7 @@ newIdSM old_id new_ty 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) + new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name) in returnSM new_id \end{code}