diff options
| author | Ian Lynagh <igloo@earth.li> | 2012-06-11 23:54:24 +0100 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2012-06-11 23:54:24 +0100 |
| commit | a6ec94937f9456f5c7ee122b088f37048bf8b265 (patch) | |
| tree | a43b4968f62d9e795e3faf13c1334198de857ad1 /compiler/specialise | |
| parent | 5c3a415b0dbe9465a27e609f9ad9ce90ab332dde (diff) | |
| download | haskell-a6ec94937f9456f5c7ee122b088f37048bf8b265.tar.gz | |
Fix whitespace in specialise/Specialise.lhs
Diffstat (limited to 'compiler/specialise')
| -rw-r--r-- | compiler/specialise/Specialise.lhs | 987 |
1 files changed, 490 insertions, 497 deletions
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 6c80f8fbde..94c7170966 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,13 +4,6 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Specialise ( specProgram ) where #include "HsVersions.h" @@ -19,19 +12,19 @@ import Id import TcType import Type import CoreMonad -import CoreSubst +import CoreSubst import CoreUnfold import VarSet import VarEnv import CoreSyn import Rules -import CoreUtils ( exprIsTrivial, applyTypeToArgs ) -import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) -import UniqSupply ( UniqSM, initUs_, MonadUnique(..) ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) +import UniqSupply ( UniqSM, initUs_, MonadUnique(..) ) import Name -import MkId ( voidArgId, realWorldPrimId ) -import Maybes ( catMaybes, isJust ) -import BasicTypes +import MkId ( voidArgId, realWorldPrimId ) +import Maybes ( catMaybes, isJust ) +import BasicTypes import HscTypes import Bag import Util @@ -44,9 +37,9 @@ import qualified FiniteMap as Map \end{code} %************************************************************************ -%* * +%* * \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -%* * +%* * %************************************************************************ These notes describe how we implement specialisation to eliminate @@ -73,8 +66,8 @@ The basic idea ~~~~~~~~~~~~~~ Suppose we have - let f = <f_rhs> - in <body> + let f = <f_rhs> + in <body> and suppose f is overloaded. @@ -94,9 +87,9 @@ partial applications.) STEP 2: EQUIVALENCES So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... Notice that f may take several type arguments. To avoid ambiguity, we say that f is called at type t1/t2 and t3/t4. @@ -108,7 +101,7 @@ STEP 3: SPECIALISATION For each equivalence class, choose a representative (f t1 t2 d1 d2), and create a local instance of f, defined thus: - f@t1/t2 = <f_rhs> t1 t2 d1 d2 + 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. However we don't actually *do* that @@ -132,15 +125,15 @@ its right-hand side, can we? But it's ok. The type checker *always* creates non-recursive definitions for overloaded recursive functions. For example: - f x = f (x+x) -- Yes I know its silly + f x = f (x+x) -- Yes I know its silly becomes - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl We still have recusion for non-overloaded functions which we speciailise, but the recursive call should get specialised to the @@ -159,19 +152,19 @@ t1/t2. There are two possibilities: of f. In this case there's no problem, we proceed just as before. A common example is as follows. Here's the Haskell: - g y = let f x = x+x - in f y + f y + g y = let f x = x+x + in f y + f y After typechecking we have - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) Notice that the call to f is at type type "a"; a non-constant type. Both calls to f are at the same type, so we can specialise to give: - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) (b) The other case is when the type variables in the instance types @@ -181,9 +174,9 @@ but "a" is not in scope at the definition of +.sel. Can we do anything? Yes, we can "common them up", a sort of limited common sub-expression deal. This would give: - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) This can save work, and can't be spotted by the type checker, because the two instances of +.sel weren't originally at the same type. @@ -209,7 +202,7 @@ Polymorphism 2 -- Overloading ~~~~~~~~~~~~~~ Consider a function whose most general type is - f :: forall a b. Ord a => [a] -> b -> b + f :: forall a b. Ord a => [a] -> b -> b There is really no point in making a version of g at Int/Int and another at Int/Bool, because it's only instancing the type variable "a" which @@ -223,7 +216,7 @@ Then when taking equivalence classes in STEP 2, we ignore the type args corresponding to unconstrained type variable. In STEP 3 we make polymorphic versions. Thus: - f@t1/ = /\b -> <f_rhs> t1 b d1 d2 + f@t1/ = /\b -> <f_rhs> t1 b d1 d2 We do this. @@ -232,9 +225,9 @@ Dictionary floating ~~~~~~~~~~~~~~~~~~~ Consider this - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + 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 @@ -244,26 +237,26 @@ outwards along with call instances. Consider - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x Before specialisation, leaving out type abstractions we have - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x After specialising h we get a specialised version of h, like this: - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) But we can't naively make an instance for g from this, because deq is not in scope at the defn of g. Instead, we have to float out the (new) defn of deq @@ -275,13 +268,13 @@ User SPECIALIZE pragmas Specialisation pragmas can be digested by the type checker, and implemented by adding extra definitions along with that of f, in the same way as before - f@t1/t2 = <f_rhs> t1 t2 d1 d2 + f@t1/t2 = <f_rhs> t1 t2 d1 d2 Indeed the pragmas *have* to be dealt with by the type checker, because only it knows how to build the dictionaries d1 and d2! For example - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} Here, the specialised version of g is an application of g's rhs to the Ord dictionary for (Tree Int), which only the type checker can conjure @@ -293,7 +286,7 @@ Problem. The type checker doesn't have to hand a convenient <f_rhs>, because it is buried in a complex (as-yet-un-desugared) binding group. Maybe we should say - f@t1/t2 = f* t1 t2 d1 d2 + f@t1/t2 = f* t1 t2 d1 d2 where f* is the Id f with an IdInfo which says "inline me regardless!". Indeed all the specialisation could be done in this way. @@ -303,17 +296,17 @@ any in-scope let-bound thing. Again, the pragma should permit polymorphism in unconstrained variables: - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} We *insist* that all overloaded type variables are specialised to ground types, (and hence there can be no context inside a SPECIALIZE pragma). We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable + - a ground type + - or left as a polymorphic type variable but nothing in between. So - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} is *illegal*. (It can be handled, but it adds complication, and gains the programmer nothing.) @@ -323,20 +316,20 @@ SPECIALISING INSTANCE DECLARATIONS ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} The original instance decl creates a dictionary-function definition: - dfun.Foo.List :: forall a. Foo a -> Foo [a] + dfun.Foo.List :: forall a. Foo a -> Foo [a] The SPECIALIZE pragma just makes a specialised copy, just as for ordinary function definitions: - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt 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. @@ -380,19 +373,19 @@ Partial specialisation by pragmas ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What about partial specialisation: - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} or even - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} Seems quite reasonable. Similar things could be done with instance decls: - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} Ho hum. Things are complex enough without this. I pass. @@ -404,14 +397,14 @@ The simplifier has to be able to take advantage of the specialisation. * When the simplifier finds an application of a polymorphic f, it looks in f's IdInfo in case there is a suitable instance to call instead. This converts - f t1 t2 d1 d2 ===> f_t1_t2 + f t1 t2 d1 d2 ===> f_t1_t2 Note that the dictionaries get eaten up too! * Dictionary selection operations on constant dictionaries must be short-circuited: - +.sel Int d ===> +Int + +.sel Int d ===> +Int The obvious way to do this is in the same way as other specialised calls: +.sel has inside it some IdInfo which tells that if it's applied @@ -423,13 +416,13 @@ methods. * Exactly the same applies if a superclass dictionary is being extracted: - Eq.sel Int d ===> dEqInt + Eq.sel Int d ===> dEqInt * Something similar applies to dictionary construction too. Suppose dfun.Eq.List is the function taking a dictionary for (Eq a) to one for (Eq [a]). Then we want - dfun.Eq.List Int d ===> dEq.List_Int + dfun.Eq.List Int d ===> dEq.List_Int Where does the Eq [Int] dictionary come from? It is built in response to a SPECIALIZE pragma on the Eq [a] instance decl. @@ -445,15 +438,15 @@ What does the specialisation IdInfo look like? The SpecEnv of an Id maps a list of types (the template) to an expression - [Type] |-> Expr + [Type] |-> Expr For example, if f has this SpecInfo: - [Int, a] -> \d:Ord Int. f' a + [Int, a] -> \d:Ord Int. f' a it means that we can replace the call - f Int t ===> (\d. f' t) + f Int t ===> (\d. f' t) This chucks one dictionary away and proceeds with the specialised version of f, namely f'. @@ -464,14 +457,14 @@ What can't be done this way? There is no way, post-typechecker, to get a dictionary for (say) Eq a from a dictionary for Eq [a]. So if we find - ==.sel [t] d + ==.sel [t] d we can't transform to - eqList (==.sel t d') + eqList (==.sel t d') where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool Of course, we currently have no way to automatically derive eqList, nor to connect it to the Eq [a] instance decl, but you @@ -485,7 +478,7 @@ A note about non-tyvar dictionaries ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some Ids have types like - forall a,b,c. Eq a -> Ord [a] -> tau + forall a,b,c. Eq a -> Ord [a] -> tau This seems curious at first, because we usually only have dictionary args whose types are of the form (C a) where a is a type variable. @@ -495,47 +488,47 @@ type constructor T. Should we specialise wrt this compound-type dictionary? We used to say "no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures +and in future GHC is likely to support full fledged type signatures like - f :: Eq [(a,b)] => ... + f :: Eq [(a,b)] => ... %************************************************************************ -%* * +%* * \subsubsection{The new specialiser} -%* * +%* * %************************************************************************ Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool + f :: (C a, D c) => (a,b,c,d) -> Bool -* Find any specialised calls of f, (f ts ds), where +* Find any specialised calls of f, (f ts ds), where ts are the type arguments t1 .. t4, and ds are the dictionary arguments d1 .. d2. * Add a new definition for f1 (say): - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 Note that we abstract over the unconstrained type arguments. * Add the mapping - [t1,b,t3,d] |-> \d1 d2 -> f1 b d + [t1,b,t3,d] |-> \d1 d2 -> f1 b d to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db + simplifier to replace calls + (f t1 t2 t3 t4) da db by - (\d1 d1 -> f1 t2 t4) da db + (\d1 d1 -> f1 t2 t4) da db All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the @@ -548,7 +541,7 @@ We don't build *partial* specialisations for f. For example: Here, little is gained by making a specialised copy of f. There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) +first build a dictionary for (Eq b, Eq c), and then select the (==) method from it! Even if it didn't, not a great deal is saved. We do, however, generate polymorphic, but not overloaded, specialisations: @@ -556,43 +549,43 @@ We do, however, generate polymorphic, but not overloaded, specialisations: f :: Eq a => [a] -> b -> b -> b {#- SPECIALISE f :: [Int] -> b -> b -> b #-} -Hence, the invariant is this: +Hence, the invariant is this: - *** no specialised version is overloaded *** + *** no specialised version is overloaded *** %************************************************************************ -%* * +%* * \subsubsection{The exported function} -%* * +%* * %************************************************************************ \begin{code} specProgram :: ModGuts -> CoreM ModGuts -specProgram guts +specProgram guts = do { hpt_rules <- getRuleBase ; let local_rules = mg_rules guts rule_base = extendRuleBaseList hpt_rules (mg_rules guts) - -- Specialise the bindings of this module + -- Specialise the bindings of this module ; (binds', uds) <- runSpecM (go (mg_binds guts)) - -- Specialise imported functions + -- Specialise imported functions ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds ; let final_binds | null spec_binds = binds' | otherwise = Rec (flattenBinds spec_binds) : binds' - -- Note [Glom the bindings if imported functions are specialised] + -- Note [Glom the bindings if imported functions are specialised] ; return (guts { mg_binds = final_binds , mg_rules = new_rules ++ local_rules }) } 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 = mkEmptySubst $ mkInScopeSet $ mkVarSet $ + -- 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 = mkEmptySubst $ mkInScopeSet $ mkVarSet $ bindersOfBinds $ mg_binds guts go [] = return ([], emptyUDs) @@ -600,11 +593,11 @@ specProgram guts (bind', uds') <- specBind top_subst bind uds return (bind' ++ binds', uds') -specImports :: VarSet -- Don't specialise these ones - -- See Note [Avoiding recursive specialisation] - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> UsageDetails -- Calls for imported things, and floating bindings +specImports :: VarSet -- Don't specialise these ones + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> UsageDetails -- Calls for imported things, and floating bindings -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings and floating bindings -- See Note [Specialise imported INLINABLE things] @@ -619,38 +612,38 @@ specImports done rb uds ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } -specImport :: VarSet -- Don't specialise these - -- See Note [Avoiding recursive specialisation] - -> RuleBase -- Rules from this module - -> Id -> [CallInfo] -- Imported function and calls for it +specImport :: VarSet -- Don't specialise these + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module + -> Id -> [CallInfo] -- Imported function and calls for it -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings specImport done rb fn calls_for_fn | fn `elemVarSet` done = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, becuase - -- the RHS of the specialised function contains a recursive - -- call to the original function + -- when specialising a recursive function, becuase + -- the RHS of the specialised function contains a recursive + -- call to the original function | isInlinablePragma (idInlinePragma fn) , Just rhs <- maybeUnfoldingTemplate (realIdUnfolding fn) = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along + -- We keep doing this in case we "page-fault in" + -- more rules as we go along ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env + ; eps <- liftIO $ hscEPS hsc_env ; let full_rb = unionRuleBase rb (eps_rule_base eps) - rules_for_fn = getRules full_rb fn + rules_for_fn = getRules full_rb fn ; (rules1, spec_pairs, uds) <- runSpecM $ specCalls emptySubst rules_for_fn calls_for_fn fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - ; (rules2, spec_binds2) <- specImports (extendVarSet done fn) + + -- Now specialise any cascaded calls + ; (rules2, spec_binds2) <- specImports (extendVarSet done fn) (extendRuleBaseList rb rules1) uds @@ -658,7 +651,7 @@ specImport done rb fn calls_for_fn | otherwise = WARN( True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn ) - return ([], []) + return ([], []) \end{code} Note [Specialise imported INLINABLE things] @@ -669,7 +662,7 @@ Moreover, we risk lots of orphan modules from vigorous specialisation. Note [Glom the bindings if imported functions are specialised] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function +Suppose we have an imported, *recursive*, INLINABLE function f :: Eq a => a -> a f = /\a \d x. ...(f a d)... In the module being compiled we have @@ -695,13 +688,13 @@ When we specialise 'f' we may find new overloaded calls to 'g', 'h' in specialise f any more! It's possible that f's RHS might have a recursive yet-more-specialised call, so we'd diverge in that case. And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is the reason for the +Avoiding this recursive specialisation loop is the reason for the 'done' VarSet passed to specImports and specImport. %************************************************************************ -%* * +%* * \subsubsection{@specExpr@: the main function} -%* * +%* * %************************************************************************ \begin{code} @@ -710,10 +703,10 @@ specVar subst v = lookupIdSubst (text "specVar") subst v specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) -- We carry a substitution down: --- a) we must clone any binding that might float outwards, --- to avoid name clashes --- b) we carry a type substitution to use when analysing --- the RHS of specialised bindings (no type-let!) +-- a) we must clone any binding that might float outwards, +-- to avoid name clashes +-- b) we carry a type substitution to use when analysing +-- the RHS of specialised bindings (no type-let!) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs) @@ -738,30 +731,30 @@ specExpr subst expr@(App {}) go (Var f) args = case specVar subst f of Var f' -> return (Var f', mkCallUDs f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr subst other + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr subst other ---------------- Lambda/case require dumping of usage details -------------------- specExpr subst e@(Lam _ _) = do (body', uds) <- specExpr subst' body - let (free_uds, dumped_dbs) = dumpUDs bndrs' uds + let (free_uds, dumped_dbs) = dumpUDs bndrs' uds return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) where (bndrs, body) = collectBinders e (subst', bndrs') = substBndrs subst bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings -specExpr subst (Case scrut case_bndr ty alts) +specExpr subst (Case scrut case_bndr ty alts) = do { (scrut', scrut_uds) <- specExpr subst scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase subst scrut' case_bndr alts + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase subst scrut' case_bndr alts ; return (Case scrut'' case_bndr' (CoreSubst.substTy subst ty) alts' , scrut_uds `plusUDs` alts_uds) } ---------------- Finally, let is the interesting case -------------------- specExpr subst (Let bind body) = do - -- Clone binders + -- Clone binders (rhs_subst, body_subst, bind') <- cloneBindSM subst bind -- Deal with the body @@ -780,15 +773,15 @@ specTickish subst (Breakpoint ix ids) -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish -specCase :: Subst - -> CoreExpr -- Scrutinee, already done +specCase :: Subst + -> CoreExpr -- Scrutinee, already done -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] + -> SpecM ( CoreExpr -- New scrutinee + , Id + , [CoreAlt] , UsageDetails) specCase subst scrut' case_bndr [(con, args, rhs)] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] + | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') @@ -797,17 +790,17 @@ specCase subst scrut' case_bndr [(con, args, rhs)] [(con, args', Var sc_arg')] | sc_arg' <- sc_args' ] - -- Extend the substitution for RHS to map the *original* binders - -- to their floated verions. Attach an unfolding to these floated - -- binders so they look interesting to interestingDict - mb_sc_flts :: [Maybe DictId] + -- Extend the substitution for RHS to map the *original* binders + -- to their floated verions. Attach an unfolding to these floated + -- binders so they look interesting to interestingDict + mb_sc_flts :: [Maybe DictId] mb_sc_flts = map (lookupVarEnv clone_env) args' clone_env = zipVarEnv sc_args' (zipWith add_unf sc_args_flt sc_rhss) subst_prs = (case_bndr, Var (add_unf case_bndr_flt scrut')) - : [ (arg, Var sc_flt) + : [ (arg, Var sc_flt) | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] subst_rhs' = extendIdSubstList subst_rhs subst_prs - + ; (rhs', rhs_uds) <- specExpr subst_rhs' rhs ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') case_bndr_set = unitVarSet case_bndr_flt @@ -821,7 +814,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)] where (subst_rhs, (case_bndr':args')) = substBndrs subst (case_bndr:args) sc_args' = filter is_flt_sc_arg args' - + clone_me bndr = do { uniq <- getUniqueM ; return (mkUserLocal occ uniq ty loc) } where @@ -836,7 +829,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)] arg_set = mkVarSet args' is_flt_sc_arg var = isId var && not (isDeadBinder var) - && isDictTy var_ty + && isDictTy var_ty && not (tyVarsOfType var_ty `intersectsVarSet` arg_set) where var_ty = idType var @@ -861,9 +854,9 @@ Consider g = \d. case d of { MkD sc ... -> ...(f sc)... } Naively we can't float d2's binding out of the case expression, because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. +specialise f, which seems a pity. -So we invert the case, by floating out a binding +So we invert the case, by floating out a binding for 'sc_flt' thus: sc_flt = case d of { MkD sc ... -> sc } Now we can float the call instance for 'f'. Indeed this is just @@ -872,7 +865,7 @@ but case is more efficient, and necessary with equalities. So it's good to work with both. You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is +call instance will only get nuked by the \d. BUT if 'g' itself is specialised, then transitively we should be able to specialise f. In general, given @@ -887,17 +880,17 @@ The "_flt" things are the floated binds; we use the current substitution to substitute sc -> sc_flt in the RHS %************************************************************************ -%* * +%* * 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 :: 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 -- Returned UsageDetails: -- No calls for binders of this bind @@ -906,29 +899,29 @@ specBind rhs_subst (NonRec fn rhs) body_uds ; (fn', spec_defns, body_uds1) <- specDefn rhs_subst body_uds fn rhs ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first + -- fn' mentions the spec_defns in its rules, + -- so put the latter first combined_uds = body_uds1 `plusUDs` rhs_uds - -- This way round a call in rhs_uds of a function f - -- at type T will override a call of f at T in body_uds1; and - -- that is good because it'll tend to keep "earlier" calls - -- See Note [Specialisation of dictionary functions] + -- This way round a call in rhs_uds of a function f + -- at type T will override a call of f at T in body_uds1; and + -- that is good because it'll tend to keep "earlier" calls + -- See Note [Specialisation of dictionary functions] - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - -- See Note [From non-recursive to recursive] + (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds + -- See Note [From non-recursive to recursive] final_binds | isEmptyBag dump_dbs = [NonRec b r | (b,r) <- pairs] | otherwise = [Rec (flattenDictBinds dump_dbs pairs)] - ; if float_all then - -- Rather than discard the calls mentioning the bound variables - -- we float this binding along with the others - return ([], free_uds `snocDictBinds` final_binds) + ; if float_all then + -- Rather than discard the calls mentioning the bound variables + -- we float this binding along with the others + return ([], free_uds `snocDictBinds` final_binds) else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (final_binds, free_uds) } + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (final_binds, free_uds) } specBind rhs_subst (Rec pairs) body_uds @@ -936,14 +929,14 @@ specBind rhs_subst (Rec pairs) body_uds = do { let (bndrs,rhss) = unzip pairs ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss ; let scope_uds = body_uds `plusUDs` rhs_uds - -- Includes binds and calls arising from rhss + -- Includes binds and calls arising from rhss ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_subst scope_uds pairs ; (bndrs3, spec_defns3, uds3) <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again + then return (bndrs1, [], uds1) + else do { -- Specialisation occurred; do it again (bndrs2, spec_defns2, uds2) <- specDefns rhs_subst uds1 (bndrs1 `zip` rhss) ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } @@ -951,20 +944,20 @@ specBind rhs_subst (Rec pairs) body_uds ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 bind = Rec (flattenDictBinds dumped_dbs $ spec_defns3 ++ zip bndrs3 rhss') - + ; if float_all then - return ([], final_uds `snocDictBind` bind) + return ([], final_uds `snocDictBind` bind) else - return ([bind], final_uds) } + return ([bind], final_uds) } --------------------------- specDefns :: Subst - -> UsageDetails -- Info on how it is used in its scope - -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([Id], -- Original Ids with RULES added - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions + -> UsageDetails -- Info on how it is used in its scope + -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([Id], -- Original Ids with RULES added + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions -- Specialise a list of bindings (the contents of a Rec), but flowing usages -- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } @@ -981,62 +974,62 @@ specDefns subst uds ((bndr,rhs):pairs) --------------------------- specDefn :: Subst - -> UsageDetails -- Info on how it is used in its scope - -> Id -> CoreExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions + -> UsageDetails -- Info on how it is used in its scope + -> Id -> CoreExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions specDefn subst body_uds fn rhs = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rules_for_me = idCoreRules fn - ; (rules, spec_defns, spec_uds) <- specCalls subst rules_for_me + ; (rules, spec_defns, spec_uds) <- specCalls subst rules_for_me calls_for_me fn rhs ; return ( fn `addIdSpecialisations` rules , spec_defns , body_uds_without_me `plusUDs` spec_uds) } - -- It's important that the `plusUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me --------------------------- specCalls :: Subst - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> Id -> CoreExpr - -> SpecM ([CoreRule], -- New RULES for the fn - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- New usage details from the specialised RHSs + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> Id -> CoreExpr + -> SpecM ([CoreRule], -- New RULES for the fn + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- New usage details from the specialised RHSs -- This function checks existing rules, and does not create -- duplicate ones. So the caller does not need to do this filtering. -- See 'already_covered' specCalls subst rules_for_me calls_for_me fn rhs - -- The first case is the interesting one + -- The first case is the interesting one | 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 + && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args + && notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $ do { stuff <- mapM spec_call calls_for_me ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) ; return (spec_rules, spec_defns, plusUDList spec_uds) } - | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") + | otherwise -- No calls or RHS doesn't fit our preconceptions + = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn $$ _trace_doc ) - -- Note [Specialisation shape] + -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) where @@ -1044,18 +1037,18 @@ specCalls subst rules_for_me calls_for_me fn rhs , ppr rhs_ids, ppr n_dicts , ppr (idInlineActivation fn) ] - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta + n_tyvars = length tyvars + n_dicts = length theta inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag is_local = isLocalId fn - -- Figure out whether the function has an INLINE pragma - -- See Note [Inline specialisations] + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule @@ -1063,135 +1056,135 @@ specCalls subst rules_for_me calls_for_me fn rhs rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body - -- Glue back on the non-dict lambdas + -- Glue back on the non-dict lambdas already_covered :: [CoreExpr] -> Bool - already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) realIdUnfolding - (substInScope subst) - fn args rules_for_me) + already_covered args -- Note [Specialisations already covered] + = isJust (lookupRule (const True) realIdUnfolding + (substInScope subst) + fn args rules_for_me) mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] - mk_ty_args [] poly_tvs + mk_ty_args [] poly_tvs = ASSERT( null poly_tvs ) [] mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs mk_ty_args (Just ty : call_ts) poly_tvs = Type ty : mk_ty_args call_ts poly_tvs mk_ty_args (Nothing : _) [] = panic "mk_ty_args" - + ---------------------------------------------------------- - -- Specialise to one particular call pattern + -- Specialise to one particular call pattern spec_call :: CallInfo -- Call instance - -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - CoreRule)) -- Info for the Id's SpecEnv + -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition + UsageDetails, -- Usage details from specialised body + CoreRule)) -- Info for the Id's SpecEnv spec_call (CallKey call_ts, (call_ds, _)) = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) - - -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs + + -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] - -- Construct the new binding - -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) - -- PLUS the usage-details - -- { d1' = dx1; d2' = dx2 } - -- where d1', d2' are cloned versions of d1,d2, with the type substitution - -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 - -- - -- 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 + -- Construct the new binding + -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) + -- PLUS the usage-details + -- { d1' = dx1; d2' = dx2 } + -- where d1', d2' are cloned versions of d1,d2, with the type substitution + -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 + -- + -- 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 do { let - -- poly_tyvars = [b] in the example above - -- spec_tyvars = [a,c] - -- ty_args = [t1,b,t3] - spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - spec_ty_args = map snd spec_tv_binds - subst1 = CoreSubst.extendTvSubstList subst spec_tv_binds - (rhs_subst, poly_tyvars) - = CoreSubst.substBndrs subst1 + -- poly_tyvars = [b] in the example above + -- spec_tyvars = [a,c] + -- ty_args = [t1,b,t3] + spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] + spec_ty_args = map snd spec_tv_binds + subst1 = CoreSubst.extendTvSubstList subst spec_tv_binds + (rhs_subst, poly_tyvars) + = CoreSubst.substBndrs subst1 [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] - ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids - -- Clone rhs_dicts, including instantiating their types - - ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ - (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) - ty_args = mk_ty_args call_ts poly_tyvars - inst_args = ty_args ++ map Var inst_dict_ids - - ; if already_covered inst_args then - return Nothing - else do - { -- Figure out the type of the specialised function - let body_ty = applyTypeToArgs rhs fn_type inst_args - (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted - | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs - = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) - | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkPiTypes lam_args body_ty - + ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids + -- Clone rhs_dicts, including instantiating their types + + ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ + (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) + ty_args = mk_ty_args call_ts poly_tyvars + inst_args = ty_args ++ map Var inst_dict_ids + + ; if already_covered inst_args then + return Nothing + else do + { -- Figure out the type of the specialised function + let body_ty = applyTypeToArgs rhs fn_type inst_args + (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted + | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs + = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) + | otherwise = (poly_tyvars, poly_tyvars) + spec_id_ty = mkPiTypes lam_args body_ty + ; spec_f <- newSpecIdSM fn spec_id_ty ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body) - ; let - -- The rule to put in the function's specialisation is: - -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b - rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args)) - spec_env_rule = mkRule True {- Auto generated -} is_local + ; let + -- The rule to put in the function's specialisation is: + -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b + rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args)) + spec_env_rule = mkRule True {- Auto generated -} is_local rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - (poly_tyvars ++ inst_dict_ids) - inst_args - (mkVarApps (Var spec_f) app_args) - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - final_uds = foldr consDictBind rhs_uds dx_binds - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - spec_inl_prag - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal - | otherwise - = case inl_prag of - InlinePragma { inl_inline = Inlinable } + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + (poly_tyvars ++ inst_dict_ids) + inst_args + (mkVarApps (Var spec_f) app_args) + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + final_uds = foldr consDictBind rhs_uds dx_binds + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + spec_inl_prag + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal + | otherwise + = case inl_prag of + InlinePragma { inl_inline = Inlinable } -> inl_prag { inl_inline = EmptyInlineSpec } - _ -> inl_prag + _ -> inl_prag - spec_unf + spec_unf = case inlinePragmaSpec spec_inl_prag of Inline -> mkInlineUnfolding (Just spec_arity) spec_rhs Inlinable -> mkInlinableUnfolding spec_rhs _ -> NoUnfolding - -------------------------------------- - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_f - spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_f + spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) `setInlinePragma` spec_inl_prag `setIdUnfolding` spec_unf - ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } + ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } where - my_zipEqual xs ys zs - | debugIsOn && not (equalLength xs ys && equalLength ys zs) + my_zipEqual xs ys zs + | debugIsOn && not (equalLength xs ys && equalLength ys zs) = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys - , ppr fn <+> ppr call_ts - , ppr (idType fn), ppr theta - , ppr n_dicts, ppr rhs_dict_ids - , ppr rhs]) - | otherwise = zip3 xs ys zs + , ppr fn <+> ppr call_ts + , ppr (idType fn), ppr theta + , ppr n_dicts, ppr rhs_dict_ids + , ppr rhs]) + | otherwise = zip3 xs ys zs bindAuxiliaryDicts - :: Subst - -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) - -> (Subst, -- Substitute for all orig_dicts - [CoreBind]) -- Auxiliary bindings + :: Subst + -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) + -> (Subst, -- Substitute for all orig_dicts + [CoreBind]) -- Auxiliary bindings -- Bind any dictionary arguments to fresh names, to preserve sharing -- Substitution already substitutes orig_dict -> inst_dict bindAuxiliaryDicts subst triples = go subst [] triples @@ -1200,29 +1193,29 @@ bindAuxiliaryDicts subst triples = go subst [] triples go subst binds ((d, dx_id, dx) : pairs) | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs -- No auxiliary binding necessary - -- Note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs + -- Note that we bind the *original* dict in the substitution, + -- overriding any d->dx_id binding put there by substBndrs | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx - subst_w_unf = extendIdSubst subst d (Var dx_id1) - -- Important! We're going to substitute dx_id1 for d - -- and we want it to look "interesting", else we won't gather *any* - -- consequential calls. E.g. - -- f d = ...g d.... - -- If we specialise f for a call (f (dfun dNumInt)), we'll get - -- a consequent call (g d') with an auxiliary definition - -- d' = df dNumInt - -- We want that consequent call to look interesting - -- - -- Again, note that we bind the *original* dict in the substitution, - -- overriding any d->dx_id binding put there by substBndrs + subst_w_unf = extendIdSubst subst d (Var dx_id1) + -- Important! We're going to substitute dx_id1 for d + -- and we want it to look "interesting", else we won't gather *any* + -- consequential calls. E.g. + -- f d = ...g d.... + -- If we specialise f for a call (f (dfun dNumInt)), we'll get + -- a consequent call (g d') with an auxiliary definition + -- d' = df dNumInt + -- We want that consequent call to look interesting + -- + -- Again, note that we bind the *original* dict in the substitution, + -- overriding any d->dx_id binding put there by substBndrs \end{code} Note [From non-recursive to recursive] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might +Even in the non-recursive case, if any dict-binds depend on 'fn' we might have built a recursive knot f a d x = <blah> @@ -1238,7 +1231,7 @@ The we generate Here the recursion is only through the RULE. - + Note [Specialisation of dictionary functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a nasty example that bit us badly: see Trac #3591 @@ -1255,7 +1248,7 @@ Here is a nasty example that bit us badly: see Trac #3591 d1 :: Eq [T] = $p1 d2 d3 :: C [T] = dfun T d1 -None of these definitions is recursive. What happened was that we +None of these definitions is recursive. What happened was that we generated a specialisation: RULE forall d. dfun T d = dT :: C [T] @@ -1279,8 +1272,8 @@ But look at this: class C a where { foo,bar :: [a] -> [a] } - instance C Int where - foo x = r_bar x + instance C Int where + foo x = r_bar x bar xs = reverse xs r_bar :: C a => [a] -> [a] @@ -1293,8 +1286,8 @@ That translates to: Rec { $fCInt :: C Int = MkC foo_help reverse foo_help (xs::[Int]) = r_bar Int $fCInt xs } -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, which mentions r_bar But we DO want to specialise r_bar at Int: @@ -1302,11 +1295,11 @@ But we DO want to specialise r_bar at Int: foo_help (xs::[Int]) = r_bar Int $fCInt xs r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int + RULE r_bar Int _ = r_bar_Int r_bar_Int xs = bar Int $fCInt (xs ++ xs) } - + Note that, because of its RULE, r_bar joins the recursive group. (In this case it'll unravel a short moment later.) @@ -1322,7 +1315,7 @@ Consider let rec { f x = ...g x'... ; g y = ...f y'.... } in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to +Here we specialise 'f' at Char; but that is very likely to lead to a specialisation of 'g' at Char. We must do the latter, else the whole point of specialisation is lost. @@ -1340,12 +1333,12 @@ So we use the following heuristic: the RHSs back in the bottom, as it were In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of +and we do just two sweeps. This should catch almost every case of monomorphic recursion -- the exception could be a very knotted-up recursion with multiple cycles tied up together. This plan is implemented in the Rec case of specBindItself. - + Note [Specialisations already covered] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously don't want to generate two specialisations for the same @@ -1378,13 +1371,13 @@ Consider: Suppose that auto-specialisation makes a specialised version of g::Int->Int That version won't appear in the LHS of the RULE for f. So if the specialisation rule fires too early, the rule for f may -never fire. +never fire. It might be possible to add new rules, to "complete" the rewrite system. Thus when adding - RULE forall d. g Int d = g_spec + RULE forall d. g Int d = g_spec also add - RULE f g_spec = 0 + RULE f g_spec = 0 But that's a bit complicated. For now we ask the programmer's help, by *copying the INLINE activation pragma* to the auto-specialised @@ -1400,23 +1393,23 @@ 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 => .... + f :: forall a. Eq a => .... then its body must look like - f = /\a. \d. ... + 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 this: - newtype Gen a = MkGen{ unGen :: Int -> a } + newtype Gen a = MkGen{ unGen :: Int -> a } - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) - oneof = choose (1::Int) + oneof = choose (1::Int) It's a silly exapmle, but we get - choose = /\a. g `cast` co + 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). @@ -1440,10 +1433,10 @@ 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 +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 +boring to trigger inlining), and it's certainly better to call the specialised version. Why (b)? See Trac #4874 for persuasive examples. Suppose we have @@ -1467,45 +1460,45 @@ INLINABLE. See Trac #4874. %************************************************************************ -%* * +%* * \subsubsection{UsageDetails and suchlike} -%* * +%* * %************************************************************************ \begin{code} -data UsageDetails +data UsageDetails = MkUD { - ud_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.) + ud_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.) - ud_calls :: !CallDetails + ud_calls :: !CallDetails - -- INVARIANT: suppose bs = bindersOf ud_binds - -- Then 'calls' may *mention* 'bs', + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', -- but there should be no calls *for* bs } instance Outputable UsageDetails where ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = ptext (sLit "MkUD") <+> braces (sep (punctuate comma - [ptext (sLit "binds") <+> equals <+> ppr dbs, - ptext (sLit "calls") <+> equals <+> ppr calls])) + = ptext (sLit "MkUD") <+> braces (sep (punctuate comma + [ptext (sLit "binds") <+> equals <+> ppr dbs, + ptext (sLit "calls") <+> equals <+> ppr calls])) type DictBind = (CoreBind, VarSet) - -- The set is the free vars of the binding - -- both tyvars and dicts + -- The set is the free vars of the binding + -- both tyvars and dicts type DictExpr = CoreExpr emptyUDs :: UsageDetails emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv } ------------------------------------------------------------- +------------------------------------------------------------ type CallDetails = IdEnv CallInfoSet -newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument +newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument -- CallInfo uses a Map, thereby ensuring that -- we record only one call instance for any key @@ -1513,9 +1506,9 @@ newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argu -- The list of types and dictionaries is guaranteed to -- match the type of f data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) - -- Range is dict args and the vars of the whole - -- call (including tyvars) - -- [*not* include the main id itself, of course] + -- Range is dict args and the vars of the whole + -- call (including tyvars) + -- [*not* include the main id itself, of course] type CallInfo = (CallKey, ([DictExpr], VarSet)) @@ -1533,11 +1526,11 @@ instance Eq CallKey where instance Ord CallKey where compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2 - where - cmp Nothing Nothing = EQ - cmp Nothing (Just _) = LT - cmp (Just _) Nothing = GT - cmp (Just t1) (Just t2) = cmpType t1 t2 + where + cmp Nothing Nothing = EQ + cmp Nothing (Just _) = LT + cmp (Just _) Nothing = GT + cmp (Just t1) (Just t2) = cmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 @@ -1551,39 +1544,39 @@ callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls callInfoFVs :: CallInfoSet -> VarSet callInfoFVs (CIS _ call_info) = Map.foldRight (\(_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info ------------------------------------------------------------- +------------------------------------------------------------ singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails -singleCall id tys dicts - = MkUD {ud_binds = emptyBag, - ud_calls = unitVarEnv id $ CIS id $ +singleCall id tys dicts + = MkUD {ud_binds = emptyBag, + ud_calls = unitVarEnv id $ CIS id $ Map.singleton (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. + -- 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. mkCallUDs :: Id -> [CoreExpr] -> UsageDetails -mkCallUDs f args +mkCallUDs f args | not (want_calls_for f) -- Imported from elsewhere - || null theta -- Not overloaded - || 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! + || null theta -- Not overloaded + || 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) - || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] + || not (any interestingDict dicts) -- Note [Interesting dictionary arguments] -- See also Note [Specialisations already covered] = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs -- Not overloaded, or no specialisation wanted + emptyUDs -- Not overloaded, or no specialisation wanted | otherwise = -- pprTrace "mkCallUDs: keeping" _trace_doc @@ -1592,16 +1585,16 @@ mkCallUDs f args _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map interestingDict dicts)] (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyVarsOfTypes theta - n_tyvars = length tyvars - n_dicts = length theta + constrained_tyvars = tyVarsOfTypes 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 + + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) \end{code} @@ -1609,32 +1602,32 @@ mkCallUDs f args Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this - \a.\d:Eq a. let f = ... in ...(f d)... + \a.\d:Eq a. let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound. We simply get junk specialisations. -What is "interesting"? Just that it has *some* structure. +What is "interesting"? Just that it has *some* structure. \begin{code} interestingDict :: CoreExpr -> Bool -- A dictionary argument is interesting if it has *some* structure interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v -interestingDict (Type _) = False + || isDataConWorkId v +interestingDict (Type _) = False interestingDict (Coercion _) = False interestingDict (App fn (Type _)) = interestingDict fn interestingDict (App fn (Coercion _)) = interestingDict fn interestingDict (Tick _ a) = interestingDict a -interestingDict (Cast e _) = interestingDict e +interestingDict (Cast e _) = interestingDict e interestingDict _ = True \end{code} \begin{code} plusUDs :: UsageDetails -> UsageDetails -> UsageDetails plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 , ud_calls = calls1 `unionCalls` calls2 } plusUDList :: [UsageDetails] -> UsageDetails @@ -1649,18 +1642,18 @@ mkDB bind = (bind, bind_fvs bind) bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs - where - bndrs = map fst prs - rhs_fvs = unionVarSets (map pair_fvs prs) +bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs + where + bndrs = map fst prs + rhs_fvs = unionVarSets (map pair_fvs prs) pair_fvs :: (Id, CoreExpr) -> VarSet 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 + -- 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 flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] flattenDictBinds dbs pairs @@ -1672,7 +1665,7 @@ flattenDictBinds dbs pairs snocDictBinds :: UsageDetails -> [CoreBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` + = uds { ud_binds = ud_binds uds `unionBags` foldr (consBag . mkDB) emptyBag dbs } consDictBind :: CoreBind -> UsageDetails -> UsageDetails @@ -1708,8 +1701,8 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) -- Used at a lambda or case binder; just dump anything mentioning the binder @@ -1726,24 +1719,24 @@ dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, + -- text "Dep set =" <+> ppr dep_set, -- text "Calls for me =" <+> ppr calls_for_me]) $ (uds_without_me, calls_for_me) where uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn } calls_for_me = case lookupVarEnv orig_calls fn of - Nothing -> [] - Just (CIS _ calls) -> filter_dfuns (Map.toList calls) + Nothing -> [] + Just (CIS _ calls) -> filter_dfuns (Map.toList calls) dep_set = foldlBag go (unitVarSet fn) orig_dbs go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set = extendVarSetList dep_set (bindersOf db) | otherwise = dep_set - -- Note [Specialisation of dictionary functions] + -- Note [Specialisation of dictionary functions] filter_dfuns | isDFunId fn = filter ok_call | otherwise = \cs -> cs @@ -1754,21 +1747,21 @@ splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) -- Returns (free_dbs, dump_dbs, dump_set) splitDictBinds dbs bndr_set = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl not foldr; - -- we're accumulating the set of dumped ids in dump_set + -- Important that it's foldl not foldr; + -- we're accumulating the set of dumped ids in dump_set where split_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)) + | 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) + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) ---------------------- deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs +-- Remove calls *mentioning* bs deleteCallsMentioning bs calls = mapVarEnv filter_calls calls where @@ -1783,9 +1776,9 @@ deleteCallsFor bs calls = delVarEnvList calls bs %************************************************************************ -%* * +%* * \subsubsection{Boring helper functions} -%* * +%* * %************************************************************************ \begin{code} @@ -1817,42 +1810,42 @@ cloneBindSM subst (Rec pairs) = do newDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr]) -- Make up completely fresh binders for the dictionaries -- Their bindings are going to float outwards -newDictBndrs subst bndrs +newDictBndrs subst bndrs = do { bndrs' <- mapM new bndrs - ; let subst' = extendIdSubstList subst + ; let subst' = extendIdSubstList subst [(d, Var d') | (d,d') <- bndrs `zip` bndrs'] ; return (subst', bndrs' ) } where new b = do { uniq <- getUniqueM - ; let n = idName b + ; let n = idName b ty' = CoreSubst.substTy subst (idType b) ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> SpecM Id -- Give the new Id a similar occurrence name to the old one newSpecIdSM old_id new_ty - = do { uniq <- getUniqueM - ; let name = idName old_id - new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) ; return new_id } \end{code} - Old (but interesting) stuff about unboxed bindings - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What should we do when a value is specialised to a *strict* unboxed value? - map_*_* f (x:xs) = let h = f x - t = map f xs - in h:t + 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 + 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 @@ -1865,10 +1858,10 @@ 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 + 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. @@ -1881,20 +1874,20 @@ 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_*_* 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 + 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. |