From 9a81ddfb43b96cfeae2236c9616ca3552250b235 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 25 Oct 2010 15:28:17 +0000 Subject: [PATCH] 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. --- compiler/coreSyn/CorePrep.lhs | 10 ++++-- compiler/coreSyn/CoreTidy.lhs | 50 ++++++++++++++++++++------- compiler/iface/BinIface.hs | 17 +++++++--- compiler/iface/IfaceSyn.lhs | 44 ++++++++++++------------ compiler/iface/IfaceType.lhs | 29 ++++++++++------ compiler/iface/MkIface.lhs | 38 +++++++++------------ compiler/iface/TcIface.lhs | 75 ++++++++++++++++++++++------------------- compiler/main/TidyPgm.lhs | 30 +++-------------- 8 files changed, 158 insertions(+), 135 deletions(-) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 4db4c53..8b0499c 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -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 diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index c928be4..e3bc72a 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -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] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index f7a9aa2..7c84778 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3d40b38..f86f4b9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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 "") 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 diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 47772d7..c97e16e 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index a8ea826..0d59216 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index ba1da60..c39b713 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8025f20..4ab553d 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -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} %************************************************************************ -- 1.7.10.4