intermediate_iface decls
-- Warn about orphans
- ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
- | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
- | otherwise = emptyBag
+ ; let warn_orphs = dopt Opt_WarnOrphans dflags
+ warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
+ orph_warnings --- Laziness means no work done unless -fwarn-orphans
+ | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+ | otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
- , isNothing (ifRuleOrph r) ]
+ , isNothing (ifRuleOrph r)
+ , if ifRuleAuto r then warn_auto_orphs
+ else warn_orphs ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
- = ASSERT( isExternalName name )
+ = ASSERT2( isExternalName name, ppr name )
let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
= IfaceId { ifName = getOccName id,
ifType = toIfaceType (idType id),
ifIdDetails = toIfaceIdDetails (idDetails id),
- ifIdInfo = info }
- where
- info = case toIfaceIdInfo (idInfo id) of
- [] -> NoInfo
- items -> HasInfo items
+ ifIdInfo = toIfaceIdInfo (idInfo id) }
tyThingToIfaceDecl (AClass clas)
= IfaceClass { ifCtxt = toIfaceContext sc_theta,
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
- prag_info
- where
- -- Stripped-down version of tcIfaceIdInfo
- -- Change this if you want to export more IdInfo for
- -- non-top-level Ids. Don't forget to change
- -- CoreTidy.tidyLetBndr too!
- --
- -- See Note [IdInfo on nested let-bindings] in IfaceSyn
- id_info = idInfo id
- inline_prag = inlinePragInfo id_info
- prag_info | isDefaultInlinePragma inline_prag = NoInfo
- | otherwise = HasInfo [HsInline inline_prag]
+ (toIfaceIdInfo (idInfo id))
+ -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr
+ -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId -- Unexpected
-toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
- = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
- inline_hsinfo, unfold_hsinfo]
- -- NB: strictness must be before unfolding
+ = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
+ inline_hsinfo, unfold_hsinfo] of
+ [] -> NoInfo
+ infos -> HasInfo infos
+ -- NB: strictness must appear in the list before unfolding
-- See TcIface.tcUnfolding
where
------------ Arity --------------
--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
- , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+ , uf_src = src, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
- InlineRule {}
+ InlineStable
-> case guidance of
- UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
- _other -> pprPanic "toIfUnfolding" (ppr unf)
- InlineWrapper w -> IfWrapper arity (idName w)
- InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
- InlineRhs -> IfCoreUnfold (toIfaceExpr rhs)
+ UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+ _other -> IfCoreUnfold True if_rhs
+ InlineWrapper w | isExternalName n -> IfExtWrapper arity n
+ | otherwise -> IfLclWrapper arity (getFS n)
+ where
+ n = idName w
+ InlineCompulsory -> IfCompulsory if_rhs
+ InlineRhs -> IfCoreUnfold False if_rhs
-- Yes, even if guidance is UnfNever, expose the unfolding
-- If we didn't want to expose the unfolding, TidyPgm would
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
+ where
+ if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs })
+ ru_args = args, ru_rhs = rhs,
+ ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
+ ifRuleAuto = auto,
ifRuleOrph = orph }
where
-- For type args we must remove synonyms from the outermost
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
- ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr