\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
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
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 )
UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
getUs, mapUs
)
-import Name ( nameOccName, mkSpecOcc, getSrcLoc )
+import Name
import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
import Maybes ( catMaybes, maybeToBool )
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)
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}
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) ->
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
(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
-- 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}
+
+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.
-dropInline :: CoreExpr -> CoreExpr
-dropInline (Note InlineMe rhs) = rhs
-dropInline rhs = rhs
+\begin{code}
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs = (False, rhs)
\end{code}
%************************************************************************
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 }
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}
projects / ghc-hetmet.git / blobdiff