From: simonpj@microsoft.com Date: Wed, 26 Jan 2011 17:21:12 +0000 (+0000) Subject: Fix dependencies among specialisations for imported Ids X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=869984cd0306c18dcd103b9ef7dd315573dc3c6d 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. --- diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 9494c1b..415378a 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -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