import LoadIface
import Id
import IdInfo
-import NewDemand
+import Demand
import Annotations
import CoreSyn
import CoreFVs
, let out = localOccs $ freeNamesDeclABI abi
]
- name_module n = ASSERT( isExternalName n ) nameModule n
+ name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
. filter ((== this_mod) . name_module)
. nameSetToList
= mkWarnMsg silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
- silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
+ silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
-- We don't have a decent SrcSpan for a Rule, not even the CoreRule
-- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
------------ Strictness --------------
-- No point in explicitly exporting TopSig
- strict_hsinfo = case newStrictnessInfo id_info of
+ strict_hsinfo = case strictnessInfo id_info of
Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
_other -> Nothing
------------ Unfolding --------------
- unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info)
+ unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
+ loop_breaker = isNonRuleLoopBreaker (occInfo id_info)
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
| otherwise = Just (HsInline inline_prag)
--------------------------
-toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
- = case guidance of
- InlineRule { ug_ir_info = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs)))
- InlineRule { ug_ir_info = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
- InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
- UnfoldNever -> Nothing
- UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
- UnfoldAlways -> panic "toIfUnfolding:UnfoldAlways"
- -- Never happens because we never have
- -- bindings for unfold-always things
-toIfUnfolding (DFunUnfolding _con ops)
- = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
+toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+ , uf_src = src, uf_guidance = guidance })
+ = case src of
+ InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w)))
+ InlineRule {} -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs)))
+ _other -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr 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
+ sat = case guidance of
+ UnfWhen unsat_ok _ -> unsat_ok
+ _other -> needSaturated
+
+toIfUnfolding lb (DFunUnfolding _con ops)
+ = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
-toIfUnfolding _
+
+toIfUnfolding _ _
= Nothing
--------------------------