summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/CoreSubst.lhs29
-rw-r--r--compiler/coreSyn/CoreSyn.lhs16
-rw-r--r--compiler/coreSyn/CoreTidy.lhs7
-rw-r--r--compiler/coreSyn/CoreUnfold.lhs6
-rw-r--r--compiler/coreSyn/PprCore.lhs2
-rw-r--r--compiler/iface/BinIface.hs2
-rw-r--r--compiler/iface/IfaceSyn.lhs35
-rw-r--r--compiler/iface/MkIface.lhs7
-rw-r--r--compiler/iface/TcIface.lhs74
-rw-r--r--compiler/main/DynFlags.hs5
-rw-r--r--compiler/main/TidyPgm.lhs5
-rw-r--r--compiler/simplCore/OccurAnal.lhs2
-rw-r--r--compiler/simplCore/SimplCore.lhs11
-rw-r--r--compiler/simplCore/Simplify.lhs8
-rw-r--r--compiler/stranal/WorkWrap.lhs32
15 files changed, 91 insertions, 150 deletions
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 25a751b423..2e6d907b51 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -22,7 +22,7 @@ module CoreSubst (
deShadowBinds, substSpec, substRulesForImportedIds,
substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
+ lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
substTickish,
-- ** Operations on substitutions
@@ -665,36 +665,13 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
| not (isStableSource src) -- Zap an unstable unfolding, to save substitution work
= NoUnfolding
| otherwise -- But keep a stable one!
- = seqExpr new_tmpl `seq`
- new_src `seq`
- unf { uf_tmpl = new_tmpl, uf_src = new_src }
+ = seqExpr new_tmpl `seq`
+ unf { uf_tmpl = new_tmpl }
where
new_tmpl = substExpr (text "subst-unf") subst tmpl
- new_src = substUnfoldingSource subst src
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
--------------------
-substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
-substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
- | Just wkr_expr <- lookupVarEnv ids wkr
- = case wkr_expr of
- Var w1 -> InlineWrapper w1
- _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
- -- <+> ifPprDebug (equals <+> ppr wkr_expr) )
- -- Note [Worker inlining]
- InlineStable -- It's not a wrapper any more, but still inline it!
-
- | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
- | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
- -- This can legitimately happen. The worker has been inlined and
- -- dropped as dead code, because we don't treat the UnfoldingSource
- -- as an "occurrence".
- -- Note [Worker inlining]
- InlineStable
-
-substUnfoldingSource _ src = src
-
------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index ede3a4052b..dd7307d190 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -739,12 +739,12 @@ data UnfoldingSource
-- (see MkId.lhs, calls to mkCompulsoryUnfolding).
-- Inline absolutely always, however boring the context.
- | InlineWrapper Id -- This unfolding is a the wrapper in a
- -- worker/wrapper split from the strictness analyser
- -- The Id is the worker-id
- -- Used to abbreviate the uf_tmpl in interface files
- -- which don't need to contain the RHS;
- -- it can be derived from the strictness info
+ | InlineWrapper -- This unfolding is the wrapper in a
+ -- worker/wrapper split from the strictness
+ -- analyser
+ --
+ -- cf some history in TcIface's Note [wrappers
+ -- in interface files]
@@ -844,9 +844,9 @@ isStableSource :: UnfoldingSource -> Bool
-- Keep the unfolding template
isStableSource InlineCompulsory = True
isStableSource InlineStable = True
-isStableSource (InlineWrapper {}) = True
+isStableSource InlineWrapper = True
isStableSource InlineRhs = False
-
+
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 8d45fbb9b4..f0c947246a 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -215,15 +215,10 @@ 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 }
+ = unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo
| 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/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 83a40d299a..bbf9e0eb40 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -101,9 +101,9 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
= DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops }
-mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
-mkWwInlineRule id expr arity
- = mkCoreUnfolding (InlineWrapper id) True
+mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
+mkWwInlineRule expr arity
+ = mkCoreUnfolding InlineWrapper True
(simpleOptExpr expr) arity
(UnfWhen unSaturatedOk boringCxtNotOk)
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 0a6914e0b8..64e7d63590 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -422,7 +422,7 @@ instance Outputable UnfoldingGuidance where
instance Outputable UnfoldingSource where
ppr InlineCompulsory = ptext (sLit "Compulsory")
- ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
+ ppr InlineWrapper = ptext (sLit "Wrapper")
ppr InlineStable = ptext (sLit "InlineStable")
ppr InlineRhs = ptext (sLit "<vanilla>")
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index b0bb88789d..c4c1bcd69e 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -414,5 +414,3 @@ getWayDescr dflags
where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
-
-
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 497c3ae525..8dc4188bb9 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -583,9 +583,7 @@ data IfaceUnfolding
Bool -- OK to inline even if context is boring
IfaceExpr
- | 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.
+ | IfWrapper IfaceExpr -- cf TcIface's Note [wrappers in interface files]
| IfDFunUnfold [IfaceBndr] [IfaceExpr]
@@ -600,20 +598,15 @@ instance Binary IfaceUnfolding where
put_ bh b
put_ bh c
put_ bh d
- put_ bh (IfLclWrapper a n) = do
+ put_ bh (IfWrapper e) = do
putByte bh 2
- put_ bh a
- put_ bh n
- put_ bh (IfExtWrapper a n) = do
- putByte bh 3
- put_ bh a
- put_ bh n
+ put_ bh e
put_ bh (IfDFunUnfold as bs) = do
- putByte bh 4
+ putByte bh 3
put_ bh as
put_ bh bs
put_ bh (IfCompulsory e) = do
- putByte bh 5
+ putByte bh 4
put_ bh e
get bh = do
h <- getByte bh
@@ -626,13 +619,9 @@ instance Binary IfaceUnfolding where
c <- get bh
d <- get bh
return (IfInlineRule a b c d)
- 2 -> do a <- get bh
- n <- get bh
- return (IfLclWrapper a n)
- 3 -> do a <- get bh
- n <- get bh
- return (IfExtWrapper a n)
- 4 -> do as <- get bh
+ 2 -> do e <- get bh
+ return (IfWrapper e)
+ 3 -> do as <- get bh
bs <- get bh
return (IfDFunUnfold as bs)
_ -> do e <- get bh
@@ -1299,10 +1288,7 @@ instance Outputable IfaceUnfolding where
ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule")
<+> ppr (a,uok,bok),
pprParendIfaceExpr e]
- ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
- <+> parens (ptext (sLit "arity") <+> int a)
- ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext):") <+> ppr wkr
- <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (IfWrapper e) = ptext (sLit "Wrapper:") <+> parens (ppr e)
ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot)
2 (sep (map pprParendIfaceExpr es))
@@ -1460,8 +1446,7 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet
freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
-freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
+freeNamesIfUnfold (IfWrapper e) = freeNamesIfExpr e
freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es
freeNamesIfExpr :: IfaceExpr -> NameSet
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 765bee2d6d..d3b56d1f7b 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1723,7 +1723,7 @@ toIfaceIdInfo id_info
inline_hsinfo, unfold_hsinfo] of
[] -> NoInfo
infos -> HasInfo infos
- -- NB: strictness must appear in the list before unfolding
+ -- NB: strictness and arity must appear in the list before unfolding
-- See TcIface.tcUnfolding
where
------------ Arity --------------
@@ -1762,10 +1762,7 @@ 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 | isExternalName n -> IfExtWrapper arity n
- | otherwise -> IfLclWrapper arity (getFS n)
- where
- n = idName w
+ InlineWrapper -> IfWrapper if_rhs
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 ae517ec0ab..dffd69b9ed 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -34,7 +34,6 @@ import CoreSyn
import CoreUtils
import CoreUnfold
import CoreLint
-import WorkWrap ( mkWrapper )
import MkCore ( castBottomExpr )
import Id
import MkId
@@ -46,7 +45,7 @@ import DataCon
import PrelNames
import TysWiredIn
import TysPrim ( superKindTyConName )
-import BasicTypes ( Arity, strongLoopBreaker )
+import BasicTypes ( strongLoopBreaker )
import Literal
import qualified Var
import VarEnv
@@ -55,7 +54,7 @@ import Name
import NameEnv
import NameSet
import OccurAnal ( occurAnalyseExpr )
-import Demand ( isBottomingSig )
+import Demand
import Module
import UniqFM
import UniqSupply
@@ -1205,6 +1204,25 @@ do_one (IfaceRec pairs) thing_inside
%* *
%************************************************************************
+Note [wrappers in interface files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have a nice clever scheme in interface files for
+wrappers. A wrapper's unfolding can be reconstructed from its worker's
+id and its strictness. This decreased .hi file size (sometimes
+significantly, for modules like GHC.Classes with many high-arity w/w
+splits) and had a slight corresponding effect on compile times.
+
+However, when we added the second demand analysis, this scheme lead to
+some Core lint errors. The second analysis could change the strictness
+signatures, which sometimes resulted in a wrapper's regenerated
+unfolding applying the wrapper to too many arguments.
+
+Instead of repairing the clever .hi scheme, we abandoned it in favor
+of simplicity. The .hi sizes are usually insignificant (excluding the
++1M for base libraries), and compile time barely increases (~+1% for
+nofib). The nicer upshot is that unfolding sources no longer include
+an Id, so, eg, substitutions need not traverse them any longer.
+
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
@@ -1247,17 +1265,18 @@ tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
; mb_expr <- tcPragExpr name if_expr
- ; let unf_src = if stable then InlineStable else InlineRhs
- ; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkUnfolding dflags unf_src
- True {- Top level -}
- is_bottoming
- expr) }
+ ; let unf_src | stable = InlineStable
+ | otherwise = InlineRhs
+ ; return $ case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding dflags unf_src
+ True {- Top level -}
+ (isBottomingSig strict_sig)
+ expr
+ }
where
-- Strictness should occur before unfolding!
- is_bottoming = isBottomingSig $ strictnessInfo info
-
+ strict_sig = strictnessInfo info
tcUnfolding name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
@@ -1282,30 +1301,15 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
doc = text "Class ops for dfun" <+> ppr name
(_, _, cls, _) = tcSplitDFunTy dfun_ty
-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
- ; dflags <- getDynFlags
- ; return (case mb_wkr_id of
- Nothing -> noUnfolding
- Just wkr_id -> make_inline_rule dflags wkr_id us) }
+tcUnfolding name _ info (IfWrapper if_expr)
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return $ case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkWwInlineRule expr arity -- see Note [wrappers in interface files]
+ }
where
- doc = text "Worker for" <+> ppr name
-
- make_inline_rule dflags wkr_id us
- = mkWwInlineRule wkr_id
- (initUs_ us (mkWrapper dflags ty strict_sig) wkr_id)
- arity
- -- Again we rely here on strictness info
- -- always appearing before unfolding
- strict_sig = strictnessInfo info
+ -- Arity should occur before unfolding!
+ arity = arityInfo info
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4175dc9afb..e8efca2488 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -277,6 +277,7 @@ data GeneralFlag
-- optimisation opts
| Opt_Strictness
+ | Opt_LateDmdAnal
| Opt_KillAbsence
| Opt_KillOneShot
| Opt_FullLaziness
@@ -590,6 +591,7 @@ data DynFlags = DynFlags {
liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
+
historySize :: Int,
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
@@ -1256,6 +1258,7 @@ defaultDynFlags mySettings =
specConstrRecursive = 3,
liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
+
historySize = 20,
strictnessBefore = [],
@@ -2309,6 +2312,7 @@ dynamic_flags = [
, Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
, Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n }))
, Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing }))
+
, Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n }))
, Flag "funfolding-creation-threshold" (intSuffix (\n d -> d {ufCreationThreshold = n}))
@@ -2513,6 +2517,7 @@ fFlags = [
( "error-spans", Opt_ErrorSpans, nop ),
( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ),
( "strictness", Opt_Strictness, nop ),
+ ( "late-dmd-anal", Opt_LateDmdAnal, nop ),
( "specialise", Opt_Specialise, nop ),
( "float-in", Opt_FloatIn, nop ),
( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ),
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index be4c683276..7b3695dbed 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -815,12 +815,7 @@ dffvLetBndr vanilla_unfold id
= case src of
InlineRhs | vanilla_unfold -> dffvExpr rhs
| otherwise -> return ()
- InlineWrapper v -> insert v
_ -> dffvExpr rhs
- -- For a wrapper, externalise the wrapper id rather than the
- -- fvs of the rhs. The two usually come down to the same thing
- -- but I've seen cases where we had a wrapper id $w but a
- -- rhs where $w had been inlined; see Trac #3922
go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= extendScopeList bndrs $ mapM_ dffvExpr args
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 13e468f685..52c564507a 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -880,7 +880,7 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
| Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
= case inl_source of
- InlineWrapper {} -> 10 -- Note [INLINE pragmas]
+ InlineWrapper -> 10 -- Note [INLINE pragmas]
_other -> 3 -- Data structures are more important than this
-- so that dictionary/method recursion unravels
-- Note that this case hits all InlineRule things, so we
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 62e167a79e..a3101f715e 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -121,6 +121,7 @@ getCoreToDo dflags
cse = gopt Opt_CSE dflags
spec_constr = gopt Opt_SpecConstr dflags
liberate_case = gopt Opt_LiberateCase dflags
+ late_dmd_anal = gopt Opt_LateDmdAnal dflags
static_args = gopt Opt_StaticArgumentTransformation dflags
rules_on = gopt Opt_EnableRewriteRules dflags
eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
@@ -294,7 +295,15 @@ getCoreToDo dflags
maybe_rule_check (Phase 0),
-- Final clean-up simplification:
- simpl_phase 0 ["final"] max_iter
+ simpl_phase 0 ["final"] max_iter,
+
+ runWhen late_dmd_anal $ CoreDoPasses [
+ CoreDoStrictness,
+ CoreDoWorkerWrapper,
+ simpl_phase 0 ["post-late-ww"] max_iter
+ ],
+
+ maybe_rule_check (Phase 0)
]
\end{code}
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f0f894d744..d006f7f6eb 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -30,7 +30,6 @@ import Demand ( StrictSig(..), dmdTypeDepth )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold
import CoreUtils
-import qualified CoreSubst
import CoreArity
import Rules ( lookupRule, getRules )
import TysPrim ( realWorldStatePrimTy )
@@ -737,8 +736,7 @@ simplUnfolding env top_lvl id _
, uf_src = src, uf_guidance = guide })
| isStableSource src
= do { expr' <- simplExpr rule_env expr
- ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
- is_top_lvl = isTopLevel top_lvl
+ ; let is_top_lvl = isTopLevel top_lvl
; case guide of
UnfWhen sat_ok _ -- Happens for INLINE things
-> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
@@ -747,14 +745,14 @@ simplUnfolding env top_lvl id _
-- for dfuns for single-method classes; see
-- Note [Single-method classes] in TcInstDcls.
-- A test case is Trac #4138
- in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
+ in return (mkCoreUnfolding src is_top_lvl expr' arity guide')
-- See Note [Top-level flag on inline rules] in CoreUnfold
_other -- Happens for INLINABLE things
-> let bottoming = isBottomingId id
in bottoming `seq` -- See Note [Force bottoming field]
do dflags <- getDynFlags
- return (mkUnfolding dflags src' is_top_lvl bottoming expr')
+ return (mkUnfolding dflags src is_top_lvl bottoming expr')
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index e697dfe1ff..cc4010503b 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -11,7 +11,7 @@
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
-module WorkWrap ( wwTopBinds, mkWrapper ) where
+module WorkWrap ( wwTopBinds ) where
import CoreSyn
import CoreUnfold ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule )
@@ -19,7 +19,6 @@ import CoreUtils ( exprType, exprIsHNF )
import CoreArity ( exprArity )
import Var
import Id
-import Type ( Type )
import IdInfo
import UniqSupply
import BasicTypes
@@ -358,7 +357,7 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
-- The inl_inline is bound to be False, else we would not be
-- making a wrapper
- wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
+ wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity
`setInlinePragma` wrap_prag
`setIdOccInfo` NoOccInfo
-- Zap any loop-breaker-ness, to avoid bleating from Lint
@@ -390,6 +389,9 @@ get_one_shots (Lam b e)
| otherwise = get_one_shots e
get_one_shots (Tick _ e) = get_one_shots e
get_one_shots _ = noOneShotInfo
+
+noOneShotInfo :: [Bool]
+noOneShotInfo = repeat False
\end{code}
Note [Thunk splitting]
@@ -446,27 +448,3 @@ splitThunk dflags fn_id rhs = do
(_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The worker wrapper core}
-%* *
-%************************************************************************
-
-@mkWrapper@ is called when importing a function. We have the type of
-the function and the name of its worker, and we want to make its body (the wrapper).
-
-\begin{code}
-mkWrapper :: DynFlags
- -> Type -- Wrapper type
- -> StrictSig -- Wrapper strictness info
- -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
-
-mkWrapper dflags fun_ty (StrictSig (DmdType _ demands res_info)) = do
- (_, wrap_fn, _) <- mkWwBodies dflags fun_ty demands res_info noOneShotInfo
- return wrap_fn
-
-noOneShotInfo :: [Bool]
-noOneShotInfo = repeat False
-\end{code}
View Lorry Controller Status