X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=2ec9de97a0068681314ab900c7ddfe297787e82b;hp=689dd4b1e87eef7b4dc2d503dba61ff32c909302;hb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42;hpb=72462499b891d5779c19f3bda03f96e24f9554ae diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 689dd4b..2ec9de9 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -40,6 +40,7 @@ import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) import Var ( TyVar ) +import BasicTypes ( nonRuleLoopBreaker ) import qualified Var import VarEnv import Name @@ -989,12 +990,15 @@ tcIdInfo ignore_prags name ty info tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf - ; return (info `setUnfoldingInfoLazily` unf) } + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding name ty info if_unf + ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} @@ -1005,14 +1009,11 @@ tcUnfolding name _ _ (IfCoreUnfold if_expr) Nothing -> NoUnfolding Just expr -> mkTopUnfolding expr) } -tcUnfolding name _ _ (IfInlineRule arity sat if_expr) +tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr) = do { mb_expr <- tcPragExpr name if_expr ; return (case mb_expr of Nothing -> NoUnfolding - Just expr -> mkInlineRule inl_info expr arity) } - where - inl_info | sat = InlSat - | otherwise = InlUnSat + Just expr -> mkInlineRule unsat_ok expr arity) } tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) @@ -1030,7 +1031,7 @@ tcUnfolding name ty info (IfWrapper arity wkr) -- We are relying here on strictness info always appearing -- before worker info, fingers crossed .... - strict_sig = case newStrictnessInfo info of + strict_sig = case strictnessInfo info of Just sig -> sig Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) @@ -1215,7 +1216,7 @@ tcIfaceLetBndr (IfLetBndr fs ty info) tc_info [] = vanillaIdInfo tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p tc_info (HsArity a : i) = tc_info i `setArityInfo` a - tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s + tc_info (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" (ppr other) (tc_info i)