Commit c080f727 authored by nfrisby's avatar nfrisby

simplified the .hi format and added the -flate-dmd-anal flag (fixes #7782)

cf http://ghc.haskell.org/trac/ghc/wiki/LateDmd
parent 33c880b4
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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)
......
......@@ -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>")
......
......@@ -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.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ),
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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.
......
......@@ -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}
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