-- Specialise imported functions
; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds
- ; return (guts { mg_binds = spec_binds ++ binds'
- , mg_rules = local_rules ++ new_rules }) }
+ ; let final_binds | null spec_binds = binds'
+ | otherwise = Rec (flattenBinds spec_binds) : binds'
+ -- 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
-> UsageDetails -- Calls for imported things, and floating bindings
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings and floating bindings
+-- See Note [Specialise imported INLINABLE things]
specImports done rb uds
= do { let import_calls = varEnvElts (ud_calls uds)
; (rules, spec_binds) <- go rb import_calls
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings
specImport done rb fn calls_for_fn
- | not (fn `elemVarSet` done)
- , isInlinablePragma (idInlinePragma 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
+
+ | 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"
; 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
+ -- See Note [Glom the bindings if imported functions are specialised]
-- Now specialise any cascaded calls
; (rules2, spec_binds2) <- specImports (extendVarSet done fn)
return ([], [])
\end{code}
-Avoiding recursive specialisation
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Specialise imported INLINABLE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We specialise INLINABLE things but not INLINE things. The latter
+should be inlined bodily, so not much point in specialising them.
+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
+ f :: Eq a => a -> a
+ f = /\a \d x. ...(f a d)...
+In the module being compiled we have
+ g x = f (x::Int)
+Now we'll make a specialised function
+ f_spec :: Int -> Int
+ f_spec = \x -> ...(f Int dInt)...
+ {-# RULE f Int _ = f_spec #-}
+ g = \x. f Int dInt x
+Note that f_spec doesn't look recursive
+After rewriting with the RULE, we get
+ f_spec = \x -> ...(f_spec)...
+BUT since f_spec was non-recursive before it'll *stay* non-recursive.
+The occurrence analyser never turns a NonRec into a Rec. So we must
+make sure that f_spec is recursive. Easiest thing is to make all
+the specialisations for imported bindings recursive.
+
+
+Note [Avoiding recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
'f's RHS. So we want to specialise g,h. But we don't want to
specialise f any more! It's possible that f's RHS might have a
UsageDetails) -- New usage details from the specialised RHSs
-- This function checks existing rules, and does not create
--- duplicate ones. So the caller does not nneed to do this filtering.
+-- 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
; 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") <+> ppr fn )
+ = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
+ <+> ppr fn $$ _trace_doc )
-- Note [Specialisation shape]
-- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
return ([], [], emptyUDs)
-
where
+ _trace_doc = vcat [ ppr rhs_tyvars, ppr n_tyvars
+ , 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
spec_inl_prag
= case inl_prag of
InlinePragma { inl_inline = Inlinable }
- -> inl_prag { inl_inline = NoInline }
- _ -> inl_prag
+ -> inl_prag { inl_inline = EmptyInlineSpec }
+ _ -> inl_prag
spec_unf
= case inlinePragmaSpec spec_inl_prag of
|| not ( dicts `lengthIs` n_dicts)
|| not (any interestingDict dicts) -- Note [Interesting dictionary arguments]
-- See also Note [Specialisations already covered]
- = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
+ = -- pprTrace "mkCallUDs: discarding" _trace_doc
emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
- = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
+ = -- pprTrace "mkCallUDs: keeping" _trace_doc
singleCall f spec_tys dicts
where
+ _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
+ , ppr (map interestingDict dicts)]
(tyvars, theta, _) = tcSplitSigmaTy (idType f)
constrained_tyvars = tyVarsOfTheta theta
n_tyvars = length tyvars
projects / ghc-hetmet.git / blobdiff