-specBind rhs_subst bind body_uds = do
- (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_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.
- 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
- -> return ([bind'], all_uds)
-
- (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out
- -> return ([], 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
-
- 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 = do
- ((bndr',rhs'), spec_defns, spec_uds) <- specDefn rhs_subst call_info (bndr,rhs)
- let
- 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
- return (new_bind, spec_uds)
-
-specBindItself rhs_subst (Rec pairs) call_info = do
- stuff <- mapM (specDefn rhs_subst call_info) pairs
- 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')
- return (new_bind, spec_uds)
-
-
-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
+-- Returned UsageDetails:
+-- No calls for binders of this bind
+specBind rhs_subst (NonRec fn rhs) body_uds
+ = do { (rhs', rhs_uds) <- specExpr rhs_subst rhs
+ ; (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
+
+ 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]
+
+ (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)
+ else
+ -- 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
+ -- Note [Specialising a recursive group]
+ = 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
+
+ ; (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
+ (bndrs2, spec_defns2, uds2)
+ <- specDefns rhs_subst uds1 (bndrs1 `zip` rhss)
+ ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
+
+ ; 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)
+ else
+ 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
+
+-- Specialise a list of bindings (the contents of a Rec), but flowing usages
+-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... }
+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation
+-- in turn generates a specialised call for 'f', we catch that in this one sweep.
+-- But not vice versa (it's a fixpoint problem).
+
+specDefns _subst uds []
+ = return ([], [], uds)
+specDefns subst uds ((bndr,rhs):pairs)
+ = do { (bndrs1, spec_defns1, uds1) <- specDefns subst uds pairs
+ ; (bndr1, spec_defns2, uds2) <- specDefn subst uds1 bndr rhs
+ ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
+
+---------------------------
+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