; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
; let (floats_s, bndrs2, rhss2) = unzip3 stuff
- all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+ all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
(concatFloats floats_s)
; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
unitFloat (FloatLet (Rec all_pairs))) }
; let float = mkFloat False False v rhs2
; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
- -- Record if the binder is evaluated
+ -- Record if the binder is evaluated
+ -- and otherwise trim off the unfolding altogether
+ -- It's not used by the code generator; getting rid of it reduces
+ -- heap usage and, since we may be changing uniques, we'd have
+ -- to substitute to keep it right
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
- | otherwise = bndr
+ | otherwise = bndr `setIdUnfolding` noUnfolding
; return (floats3, bndr', rhs') }
where
\begin{code}
module CoreTidy (
- tidyExpr, tidyVarOcc, tidyRule, tidyRules
+ tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
) where
#include "HsVersions.h"
import Name hiding (tidyNameOcc)
import SrcLoc
import Maybes
-
import Data.List
+import Outputable
\end{code}
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
- = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
+ = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') ->
(env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
- = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
+ = let
+ (env', bndrs') = mapAccumL (tidyLetBndr env') env prs
+ in
map (tidyExpr env') (map snd prs) =: \ rhss' ->
(env', Rec (zip bndrs' rhss'))
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
-tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
+tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings
+ -> TidyEnv -- The one to extend
+ -> (Id, CoreExpr) -> (TidyEnv, Var)
-- Used for local (non-top-level) let(rec)s
-tidyLetBndr env (id,rhs)
- = ((tidy_env,new_var_env), final_id)
+tidyLetBndr rec_tidy_env env (id,rhs)
+ = ((tidy_occ_env,new_var_env), final_id)
where
- ((tidy_env,var_env), new_id) = tidyIdBndr env id
+ ((tidy_occ_env,var_env), new_id) = tidyIdBndr env id
+ new_var_env = extendVarEnv var_env id final_id
+ -- Override the env we get back from tidyId with the
+ -- new IdInfo so it gets propagated to the usage sites.
-- We need to keep around any interesting strictness and
-- demand info because later on we may need to use it when
new_info = idInfo new_id
`setArityInfo` exprArity rhs
`setStrictnessInfo` strictnessInfo idinfo
- `setDemandInfo` demandInfo idinfo
+ `setDemandInfo` demandInfo idinfo
`setInlinePragInfo` inlinePragInfo idinfo
+ `setUnfoldingInfo` new_unf
- -- Override the env we get back from tidyId with the new IdInfo
- -- so it gets propagated to the usage sites.
- new_var_env = extendVarEnv var_env id final_id
+ new_unf | isStableUnfolding unf = tidyUnfolding rec_tidy_env unf (panic "tidy_unf")
+ | otherwise = noUnfolding
+ unf = unfoldingInfo idinfo
-- Non-top-level variables
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
in
((tidy_env', var_env'), id')
}
+
+------------ Unfolding --------------
+tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
+tidyUnfolding tidy_env (DFunUnfolding ar con ids) _
+ = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env
+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
+ unf_from_rhs
+ | isStableSource src
+ = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo
+ uf_src = tidySrc tidy_env src }
+ | otherwise
+ = unf_from_rhs
+tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon
+
+tidySrc :: TidyEnv -> UnfoldingSource -> UnfoldingSource
+tidySrc tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
+tidySrc _ inl_info = inl_info
\end{code}
Note [Tidy IdInfo]
put_ bh b
put_ bh c
put_ bh d
- put_ bh (IfWrapper a n) = do
+ put_ bh (IfLclWrapper a n) = do
putByte bh 2
put_ bh a
put_ bh n
- put_ bh (IfDFunUnfold as) = do
+ put_ bh (IfExtWrapper a n) = do
putByte bh 3
+ put_ bh a
+ put_ bh n
+ put_ bh (IfDFunUnfold as) = do
+ putByte bh 4
put_ bh as
put_ bh (IfCompulsory e) = do
- putByte bh 4
+ putByte bh 5
put_ bh e
get bh = do
h <- getByte bh
return (IfInlineRule a b c d)
2 -> do a <- get bh
n <- get bh
- return (IfWrapper a n)
- 3 -> do as <- get bh
+ return (IfLclWrapper a n)
+ 3 -> do a <- get bh
+ n <- get bh
+ return (IfExtWrapper a n)
+ 4 -> do as <- get bh
return (IfDFunUnfold as)
_ -> do e <- get bh
return (IfCompulsory e)
-- or 1-1 corresp with arg tys
data IfaceInst
- = IfaceInst { ifInstCls :: Name, -- See comments with
+ = IfaceInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: Name, -- The dfun
+ ifDFun :: IfExtName, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
ifInstOrph :: Maybe OccName } -- See Note [Orphans]
-- There's always a separate IfaceDecl for the DFun, which gives
-- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
- = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
+ = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon
, ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
, ifFamInstTyCon :: IfaceTyCon -- Instance decl
}
ifRuleName :: RuleName,
ifActivation :: Activation,
ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: Name, -- Head of lhs
+ ifRuleHead :: IfExtName, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
ifRuleAuto :: Bool,
Bool -- OK to inline even if context is boring
IfaceExpr
- | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker
- -- can simplify to a function in another module.
+ | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
+ | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
+ -- another module.
| IfDFunUnfold [IfaceExpr]
--------------------------------
data IfaceExpr
- = IfaceLcl FastString
- | IfaceExt Name
+ = IfaceLcl IfLclName
+ | IfaceExt IfExtName
| IfaceType IfaceType
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
data IfaceNote = IfaceSCC CostCentre
| IfaceCoreNote String
-type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
- -- Note: FastString, not IfaceBndr (and same with the case binder)
+type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
+ -- Note: IfLclName, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt Name
+ | IfaceDataAlt IfExtName
| IfaceTupleAlt Boxity
| IfaceLitAlt Literal
-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
-- See Note [IdInfo on nested let-bindings]
-data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
\end{code}
Note [Expose recursive functions]
function. The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.
-So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
-Currently we only actually retain InlinePragInfo, but in principle we could
-add strictness etc.
-
+In general we retain all info that is left by CoreTidy.tidyLetBndr, since
+that is what is seen by importing module with --make
Note [Orphans]: the ifInstOrph and ifRuleOrph fields
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
-ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
+ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
arrow <+> pprIfaceExpr noParens rhs]
-ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
+ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
pprParendIfaceExpr e]
- ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr
+ ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
+ <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfDFunUnfold ns) = ptext (sLit "DFun:")
<+> brackets (pprWithCommas pprParendIfaceExpr ns)
freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v
+freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
+freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
freeNamesIfExpr :: IfaceExpr -> NameSet
\begin{code}
module IfaceType (
- IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+ IfExtName, IfLclName,
+
+ IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
%************************************************************************
\begin{code}
+type IfLclName = FastString -- A local name in iface syntax
+
+type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn
+ -- (However Internal or System Names never should)
+
data IfaceBndr -- Local (non-top-level) binders
= IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
| IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
-type IfaceIdBndr = (FastString, IfaceType)
-type IfaceTvBndr = (FastString, IfaceKind)
+type IfaceIdBndr = (IfLclName, IfaceType)
+type IfaceTvBndr = (IfLclName, IfaceKind)
-------------------------------
type IfaceKind = IfaceType
type IfaceCoercion = IfaceType
data IfaceType
- = IfaceTyVar FastString -- Type variable only, not tycon
+ = IfaceTyVar IfLclName -- Type variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfacePredTy IfacePredType
| IfaceFunTy IfaceType IfaceType
data IfacePredType -- NewTypes are handled as ordinary TyConApps
- = IfaceClassP Name [IfaceType]
+ = IfaceClassP IfExtName [IfaceType]
| IfaceIParam (IPName OccName) IfaceType
| IfaceEqPred IfaceType IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyCon -- Abbreviations for common tycons with known names
- = IfaceTc Name -- The common case
+ = IfaceTc IfExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc Boxity Arity
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc
-ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName :: IfaceTyCon -> IfExtName
ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
pprIfaceBndrs :: [IfaceBndr] -> SDoc
pprIfaceBndrs bs = sep (map ppr bs)
-pprIfaceIdBndr :: (FastString, IfaceType) -> SDoc
+pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
\begin{code}
----------------
-toIfaceTvBndr :: TyVar -> (FastString, IfaceType)
+toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType)
toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))
-toIfaceIdBndr :: Id -> (FastString, IfaceType)
+toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
-toIfaceTvBndrs :: [TyVar] -> [(FastString, IfaceType)]
+toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)]
toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
toIfaceBndr :: Var -> IfaceBndr
| 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 --------------
-> case guidance of
UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
- InlineWrapper w -> IfWrapper arity (idName w)
+ 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
import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
-import Var ( TyVar )
-import BasicTypes ( nonRuleLoopBreaker )
+import Var ( Var, TyVar )
+import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
import Name
(UnfWhen unsat_ok boring_ok))
}
-tcUnfolding name ty info (IfWrapper arity wkr)
- = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+ = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+ ; return (case mb_ops1 of
+ Nothing -> noUnfolding
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
+ where
+ doc = text "Class ops for dfun" <+> ppr name
+
+tcUnfolding name ty info (IfExtWrapper arity wkr)
+ = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
+tcUnfolding name ty info (IfLclWrapper arity wkr)
+ = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr)
+
+-------------
+tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
+tcIfaceWrapper name ty info arity get_worker
+ = do { mb_wkr_id <- forkM_maybe doc get_worker
; us <- newUniqueSupply
; return (case mb_wkr_id of
Nothing -> noUnfolding
-- before unfolding
strict_sig = case strictnessInfo info of
Just sig -> sig
- Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
-
-tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
- = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
- ; return (case mb_ops1 of
- Nothing -> noUnfolding
- Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
- where
- doc = text "Class ops for dfun" <+> ppr name
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr name)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
-- Check for type consistency in the unfolding
ifDOptM Opt_DoCoreLinting $ do
- in_scope <- get_in_scope_ids
+ in_scope <- get_in_scope
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> return ()
- Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
-
+ Just fail_msg -> do { mod <- getIfModule
+ ; pprPanic "Iface Lint failure"
+ (vcat [ ptext (sLit "In interface for") <+> ppr mod
+ , hang doc 2 fail_msg ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
- get_in_scope_ids -- Urgh; but just for linting
- = setLclEnv () $
- do { env <- getGblEnv
- ; case if_rec_types env of {
- Nothing -> return [] ;
- Just (_, get_env) -> do
- { type_env <- get_env
- ; return (typeEnvIds type_env) }}}
+
+ get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+ get_in_scope
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; setLclEnv () $ do
+ { case if_rec_types gbl_env of {
+ Nothing -> return [] ;
+ Just (_, get_env) -> do
+ { type_env <- get_env
+ ; return (varEnvElts (if_tv_env lcl_env) ++
+ varEnvElts (if_id_env lcl_env) ++
+ typeEnvIds type_env) }}}}
\end{code}
tcIfaceLetBndr (IfLetBndr fs ty info)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
- ; case info of
- NoInfo -> return (mkLocalId name ty')
- HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) }
- where
- -- Similar to tcIdInfo, but much simpler
- 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 `setStrictnessInfo` Just s
- tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo"
- (ppr other) (tc_info i)
+ ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+ name ty' info
+ ; return (mkLocalIdWithInfo name ty' id_info) }
-----------------------
newExtCoreBndr :: IfaceLetBndr -> IfL Id
--------- Unfolding ------------
unf_info = unfoldingInfo idinfo
- unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info
+ unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise = noUnfolding
+ unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
+ is_bot = case final_sig of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
-- NB: do *not* expose the worker if show_unfold is off,
-- because that means this thing is a loop breaker or
-- marked NOINLINE or something like that
-- it to the top level. So it seems more robust just to
-- fix it here.
arity = exprArity orig_rhs
-
-
-
------------- Unfolding --------------
-tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
- = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
-tidyUnfolding tidy_env tidy_rhs strict_sig
- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
- | isStableSource src
- = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo
- uf_src = tidyInl tidy_env src }
- | otherwise
- = mkTopUnfolding is_bot tidy_rhs
- where
- is_bot = case strict_sig of
- Just sig -> isBottomingSig sig
- Nothing -> False
-
-tidyUnfolding _ _ _ unf = unf
-
-tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource
-tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
-tidyInl _ inl_info = inl_info
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff