X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=c192b3f60afcc6c110a3032b24230876da77df68;hp=9494c1b1443bfbfe7f0873a764e9914039af1ea4;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=66dfd5c5947c79eabd7e3bdf6aa6e9b5b506564b diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 9494c1b..c192b3f 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 @@ -671,11 +709,12 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs) +specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs) specExpr subst (Var v) = return (specVar subst v, emptyUDs) specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr subst (Cast e co) = do (e', uds) <- specExpr subst e - return ((Cast e' (CoreSubst.substTy subst co)), uds) + return ((Cast e' (CoreSubst.substCo subst co)), uds) specExpr subst (Note note body) = do (body', uds) <- specExpr subst body return (Note (specNote subst note) body', uds) @@ -963,7 +1002,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 +1024,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 +1140,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 @@ -1476,7 +1519,7 @@ instance Ord CallKey where cmp Nothing Nothing = EQ cmp Nothing (Just _) = LT cmp (Just _) Nothing = GT - cmp (Just t1) (Just t2) = tcCmpType t1 t2 + cmp (Just t1) (Just t2) = cmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 @@ -1521,13 +1564,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 @@ -1559,7 +1604,9 @@ interestingDict :: CoreExpr -> Bool interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) || isDataConWorkId v interestingDict (Type _) = False +interestingDict (Coercion _) = False interestingDict (App fn (Type _)) = interestingDict fn +interestingDict (App fn (Coercion _)) = interestingDict fn interestingDict (Note _ a) = interestingDict a interestingDict (Cast e _) = interestingDict e interestingDict _ = True