-- 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
---------------- 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)
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
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
|| 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
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