Commit 869984cd authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Fix dependencies among specialisations for imported Ids

This was a subtle one (Trac #4903).  See
  Note [Glom the bindings if imported functions are specialised]
in Speclialise.

Fundamentally, a specialised binding for an imported Id was being
declared non-recursive, whereas in fact it can become recursive
via a RULE.  Once it's specified non-recurive the OccAnal pass
treats that as gospel -- and that in turn led to infinite inlining.

Easily fixed by glomming all the specialised bindings in a Rec;
now the OccAnal will sort them out correctly.
parent 6740a5dc
......@@ -572,8 +572,12 @@ specProgram guts
-- 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
......@@ -595,6 +599,7 @@ specImports :: VarSet -- Don't specialise these ones
-> 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
......@@ -613,8 +618,13 @@ specImport :: VarSet -- Don't specialise these
-> 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"
......@@ -629,6 +639,7 @@ specImport done rb fn calls_for_fn
; 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)
......@@ -642,8 +653,35 @@ specImport done rb fn calls_for_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
......@@ -963,7 +1001,7 @@ specCalls :: Subst
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
......@@ -985,12 +1023,16 @@ 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
......@@ -1097,8 +1139,8 @@ specCalls subst rules_for_me calls_for_me fn rhs
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
......@@ -1521,13 +1563,15 @@ mkCallUDs f args
|| 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment