Commit 9a81ddfb authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Serialise nested unfoldings across module boundaries

As Roman reported in #4428, nested let-bindings weren't
being recorded with their unfoldings.  Needless to say,
fixing this had more knock-on effects than I expected.
parent 2cda6f9f
......@@ -278,7 +278,7 @@ cpeBind top_lvl env (Rec pairs)
; 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))) }
......@@ -310,9 +310,13 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
; 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
......
......@@ -8,7 +8,7 @@ The code for *top-level* bindings is in TidyPgm.
\begin{code}
module CoreTidy (
tidyExpr, tidyVarOcc, tidyRule, tidyRules
tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
) where
#include "HsVersions.h"
......@@ -24,8 +24,8 @@ import UniqFM
import Name hiding (tidyNameOcc)
import SrcLoc
import Maybes
import Data.List
import Outputable
\end{code}
......@@ -41,11 +41,13 @@ tidyBind :: TidyEnv
-> (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'))
......@@ -129,12 +131,17 @@ tidyBndr env var
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
......@@ -156,12 +163,13 @@ tidyLetBndr env (id,rhs)
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)
......@@ -185,6 +193,24 @@ tidyIdBndr env@(tidy_env, var_env) 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]
......
......@@ -1209,15 +1209,19 @@ instance Binary IfaceUnfolding where
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
......@@ -1232,8 +1236,11 @@ instance Binary IfaceUnfolding where
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)
......
......@@ -137,9 +137,9 @@ data IfaceConDecl
-- 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
......@@ -150,7 +150,7 @@ data IfaceInst
-- 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
}
......@@ -160,7 +160,7 @@ data IfaceRule
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,
......@@ -222,20 +222,21 @@ data IfaceUnfolding
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
......@@ -246,13 +247,13 @@ data IfaceExpr
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
......@@ -263,7 +264,7 @@ data IfaceBinding
-- 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]
......@@ -280,10 +281,8 @@ that came up was a NOINLINE pragma on a let-binding inside an INLINE
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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -640,11 +639,11 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
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)
......@@ -695,7 +694,9 @@ instance Outputable IfaceUnfolding where
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)
......@@ -819,7 +820,8 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet
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
......
......@@ -7,7 +7,9 @@ This module defines interface types and binders
\begin{code}
module IfaceType (
IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfExtName, IfLclName,
IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
......@@ -41,19 +43,24 @@ import FastString
%************************************************************************
\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
......@@ -62,14 +69,14 @@ data IfaceType
| 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
......@@ -78,7 +85,7 @@ data IfaceTyCon -- Abbreviations for common tycons with known names
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc
ifaceTyConName :: IfaceTyCon -> Name
ifaceTyConName :: IfaceTyCon -> IfExtName
ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
......@@ -173,7 +180,7 @@ instance Outputable IfaceBndr where
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
......@@ -284,11 +291,11 @@ pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\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
......
......@@ -439,7 +439,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
| 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)
......@@ -1322,11 +1322,7 @@ tyThingToIfaceDecl (AnId id)
= 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,
......@@ -1482,18 +1478,9 @@ famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
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
......@@ -1504,11 +1491,13 @@ toIfaceIdDetails (RecSelId { sel_naughty = n
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 --------------
......@@ -1547,7 +1536,10 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = 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
......
......@@ -39,8 +39,8 @@ import TyCon
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
......@@ -1038,8 +1038,23 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
(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
......@@ -1056,15 +1071,7 @@ tcUnfolding name ty info (IfWrapper arity wkr)
-- 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
......@@ -1078,22 +1085,28 @@ tcPragExpr name expr
-- 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}
......@@ -1229,17 +1242,9 @@ tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
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
......
......@@ -1065,8 +1065,12 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
--------- 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
......@@ -1089,30 +1093,6 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
-- 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}
%************************************************************************
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment