Commit b39ab7d5 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Pass DynFlags down to showSDocDebug

parent ab50c9c5
......@@ -91,7 +91,8 @@ emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
emitTickyCounter cl_info args on_stk
= ifTicky $
do { mod_name <- getModuleName
; fun_descr_lit <- newStringCLit (fun_descr mod_name)
; dflags <- getDynFlags
; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name)
; arg_descr_lit <- newStringCLit arg_descr
; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
-- krc: note that all the fields are I32 now; some were I16 before,
......@@ -110,15 +111,15 @@ emitTickyCounter cl_info args on_stk
name = closureName cl_info
ticky_ctr_label = mkRednCountsLabel name NoCafRefs
arg_descr = map (showTypeCategory . idType) args
fun_descr mod_name = ppr_for_ticky_name mod_name name
fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name
-- When printing the name of a thing in a ticky file, we want to
-- give the module name even for *local* things. We print
-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
ppr_for_ticky_name :: Module -> Name -> String
ppr_for_ticky_name mod_name name
| isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug (ppr name)
ppr_for_ticky_name :: DynFlags -> Module -> Name -> String
ppr_for_ticky_name dflags mod_name name
| isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug dflags (ppr name)
-- -----------------------------------------------------------------------------
-- Ticky stack frames
......
......@@ -100,7 +100,7 @@ emitTickyCounter cl_info args
; let platform = targetPlatform dflags
ticky_ctr_label = closureRednCountsLabel platform cl_info
arg_descr = map (showTypeCategory . idType) args
fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info)
fun_descr mod_name = ppr_for_ticky_name dflags mod_name (closureName cl_info)
; fun_descr_lit <- newStringCLit (fun_descr mod_name)
; arg_descr_lit <- newStringCLit arg_descr
; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
......@@ -120,10 +120,10 @@ emitTickyCounter cl_info args
-- When printing the name of a thing in a ticky file, we want to
-- give the module name even for *local* things. We print
-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
ppr_for_ticky_name :: Module -> Name -> String
ppr_for_ticky_name mod_name name
| isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug (ppr name)
ppr_for_ticky_name :: DynFlags -> Module -> Name -> String
ppr_for_ticky_name dflags mod_name name
| isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug dflags (ppr name)
-- -----------------------------------------------------------------------------
-- Ticky stack frames
......
......@@ -1244,15 +1244,16 @@ 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 wkr_id us) }
Just wkr_id -> make_inline_rule dflags wkr_id us) }
where
doc = text "Worker for" <+> ppr name
make_inline_rule wkr_id us
make_inline_rule dflags wkr_id us
= mkWwInlineRule wkr_id
(initUs_ us (mkWrapper ty strict_sig) wkr_id)
(initUs_ us (mkWrapper dflags ty strict_sig) wkr_id)
arity
-- Again we rely here on strictness info always appearing
......
......@@ -390,8 +390,8 @@ doCorePass _ CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
doCorePass _ CoreDoStrictness = {-# SCC "Stranal" #-}
doPassDM dmdAnalPgm
doCorePass _ CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPassU wwTopBinds
doCorePass dflags CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPassU (wwTopBinds dflags)
doCorePass dflags CoreDoSpecialising = {-# SCC "Specialise" #-}
specProgram dflags
......
......@@ -24,6 +24,7 @@ import IdInfo
import Demand
import UniqSupply
import BasicTypes
import DynFlags
import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
import WwLib
......@@ -61,11 +62,11 @@ info for exported values).
\end{enumerate}
\begin{code}
wwTopBinds :: UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds :: DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds us top_binds
wwTopBinds dflags us top_binds
= initUs_ us $ do
top_binds' <- mapM wwBind top_binds
top_binds' <- mapM (wwBind dflags) top_binds
return (concat top_binds')
\end{code}
......@@ -79,23 +80,24 @@ wwTopBinds us top_binds
turn. Non-recursive case first, then recursive...
\begin{code}
wwBind :: CoreBind
wwBind :: DynFlags
-> CoreBind
-> UniqSM [CoreBind] -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
wwBind (NonRec binder rhs) = do
new_rhs <- wwExpr rhs
new_pairs <- tryWW NonRecursive binder new_rhs
wwBind dflags (NonRec binder rhs) = do
new_rhs <- wwExpr dflags rhs
new_pairs <- tryWW dflags NonRecursive binder new_rhs
return [NonRec b e | (b,e) <- new_pairs]
-- Generated bindings must be non-recursive
-- because the original binding was.
wwBind (Rec pairs)
wwBind dflags (Rec pairs)
= return . Rec <$> concatMapM do_one pairs
where
do_one (binder, rhs) = do new_rhs <- wwExpr rhs
tryWW Recursive binder new_rhs
do_one (binder, rhs) = do new_rhs <- wwExpr dflags rhs
tryWW dflags Recursive binder new_rhs
\end{code}
@wwExpr@ basically just walks the tree, looking for appropriate
......@@ -104,36 +106,36 @@ matching by looking for strict arguments of the correct type.
@wwExpr@ is a version that just returns the ``Plain'' Tree.
\begin{code}
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr :: DynFlags -> CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type {}) = return e
wwExpr e@(Coercion {}) = return e
wwExpr e@(Lit {}) = return e
wwExpr e@(Var {}) = return e
wwExpr _ e@(Type {}) = return e
wwExpr _ e@(Coercion {}) = return e
wwExpr _ e@(Lit {}) = return e
wwExpr _ e@(Var {}) = return e
wwExpr (Lam binder expr)
= Lam binder <$> wwExpr expr
wwExpr dflags (Lam binder expr)
= Lam binder <$> wwExpr dflags expr
wwExpr (App f a)
= App <$> wwExpr f <*> wwExpr a
wwExpr dflags (App f a)
= App <$> wwExpr dflags f <*> wwExpr dflags a
wwExpr (Tick note expr)
= Tick note <$> wwExpr expr
wwExpr dflags (Tick note expr)
= Tick note <$> wwExpr dflags expr
wwExpr (Cast expr co) = do
new_expr <- wwExpr expr
wwExpr dflags (Cast expr co) = do
new_expr <- wwExpr dflags expr
return (Cast new_expr co)
wwExpr (Let bind expr)
= mkLets <$> wwBind bind <*> wwExpr expr
wwExpr dflags (Let bind expr)
= mkLets <$> wwBind dflags bind <*> wwExpr dflags expr
wwExpr (Case expr binder ty alts) = do
new_expr <- wwExpr expr
wwExpr dflags (Case expr binder ty alts) = do
new_expr <- wwExpr dflags expr
new_alts <- mapM ww_alt alts
return (Case new_expr binder ty new_alts)
where
ww_alt (con, binders, rhs) = do
new_rhs <- wwExpr rhs
new_rhs <- wwExpr dflags rhs
return (con, binders, new_rhs)
\end{code}
......@@ -237,7 +239,8 @@ so that it becomes active in an importing module at the same time that
it appears in the first place in the defining module.
\begin{code}
tryWW :: RecFlag
tryWW :: DynFlags
-> RecFlag
-> Id -- The fn binder
-> CoreExpr -- The bound rhs; its innards
-- are already ww'd
......@@ -246,7 +249,7 @@ tryWW :: RecFlag
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- wrapper.
tryWW is_rec fn_id rhs
tryWW dflags is_rec fn_id rhs
| isNeverActive inline_act
-- No point in worker/wrappering if the thing is never inlined!
-- Because the no-inline prag will prevent the wrapper ever
......@@ -259,11 +262,11 @@ tryWW is_rec fn_id rhs
-- See Note [Thunk splitting]
= ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
checkSize new_fn_id rhs $
splitThunk new_fn_id rhs
splitThunk dflags new_fn_id rhs
| is_fun && worthSplittingFun wrap_dmds res_info
= checkSize new_fn_id rhs $
splitFun new_fn_id fn_info wrap_dmds res_info rhs
splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
| otherwise
= return [ (new_fn_id, rhs) ]
......@@ -312,13 +315,13 @@ checkSize fn_id rhs thing_inside
inline_rule = mkInlineUnfolding Nothing rhs
---------------------
splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
-> UniqSM [(Id, CoreExpr)]
splitFun fn_id fn_info wrap_dmds res_info rhs
splitFun dflags fn_id fn_info wrap_dmds res_info rhs
= WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
(do {
-- The arity should match the signature
(work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
(work_demands, wrap_fn, work_fn) <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
; work_uniq <- getUniqueM
; let
work_rhs = work_fn rhs
......@@ -439,9 +442,9 @@ then the splitting will go deeper too.
-- --> x = let x = e in
-- case x of (a,b) -> let x = (a,b) in x
splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
splitThunk fn_id rhs = do
(_, wrap_fn, work_fn) <- mkWWstr [fn_id]
splitThunk :: DynFlags -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
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}
......@@ -501,12 +504,13 @@ unboxed thing to f, and have it reboxed in the error cases....]
the function and the name of its worker, and we want to make its body (the wrapper).
\begin{code}
mkWrapper :: Type -- Wrapper type
mkWrapper :: DynFlags
-> Type -- Wrapper type
-> StrictSig -- Wrapper strictness info
-> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
(_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
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]
......
......@@ -37,6 +37,7 @@ import UniqSupply
import Unique
import Util ( zipWithEqual )
import Outputable
import DynFlags
import FastString
\end{code}
......@@ -109,7 +110,8 @@ the unusable strictness-info into the interfaces.
@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
\begin{code}
mkWwBodies :: Type -- Type of original function
mkWwBodies :: DynFlags
-> Type -- Type of original function
-> [Demand] -- Strictness of original function
-> DmdResult -- Info about function result
-> [Bool] -- One-shot-ness of the function
......@@ -128,10 +130,10 @@ mkWwBodies :: Type -- Type of original function
-- let x = (a,b) in
-- E
mkWwBodies fun_ty demands res_info one_shots
mkWwBodies dflags fun_ty demands res_info one_shots
= do { let arg_info = demands `zip` (one_shots ++ repeat False)
; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args
; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
-- Do CPR w/w. See Note [Always do CPR w/w]
; (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info
......@@ -320,7 +322,8 @@ That's why we carry the TvSubst through mkWWargs
%************************************************************************
\begin{code}
mkWWstr :: [Var] -- Wrapper args; have their demand info on them
mkWWstr :: DynFlags
-> [Var] -- Wrapper args; have their demand info on them
-- *Includes type variables*
-> UniqSM ([Var], -- Worker args
CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
......@@ -330,12 +333,12 @@ mkWWstr :: [Var] -- Wrapper args; have their demand info on them
CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
-- and lacking its lambdas.
-- This fn does the reboxing
mkWWstr []
mkWWstr _ []
= return ([], nop_fn, nop_fn)
mkWWstr (arg : args) = do
(args1, wrap_fn1, work_fn1) <- mkWWstr_one arg
(args2, wrap_fn2, work_fn2) <- mkWWstr args
mkWWstr dflags (arg : args) = do
(args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
(args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
----------------------
......@@ -344,8 +347,8 @@ mkWWstr (arg : args) = do
-- brings into scope work_args (via cases)
-- * work_fn assumes work_args are in scope, a
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one arg
mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags arg
| isTyVar arg
= return ([arg], nop_fn, nop_fn)
......@@ -355,7 +358,7 @@ mkWWstr_one arg
-- Absent case. We can't always handle absence for arbitrary
-- unlifted types, so we need to choose just the cases we can
-- (that's what mk_absent_let does)
Abs | Just work_fn <- mk_absent_let arg
Abs | Just work_fn <- mk_absent_let dflags arg
-> return ([], nop_fn, work_fn)
-- Unpack case
......@@ -369,7 +372,7 @@ mkWWstr_one arg
unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
rebox_fn = Let (NonRec arg con_app)
con_app = mkProductBox unpk_args (idType arg)
(worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds
(worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
-- Don't pass the arg, rebox instead
......@@ -533,8 +536,8 @@ every primitive type, so the function is partial.
using a literal will do.]
\begin{code}
mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let arg
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let dflags arg
| not (isUnLiftedType arg_ty)
= Just (Let (NonRec arg abs_rhs))
| Just tc <- tyConAppTyCon_maybe arg_ty
......@@ -548,7 +551,7 @@ mk_absent_let arg
where
arg_ty = idType arg
abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
msg = showSDocDebug (ppr arg <+> ppr (idType arg))
msg = showSDocDebug dflags (ppr arg <+> ppr (idType arg))
mk_seq_case :: Id -> CoreExpr -> CoreExpr
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
......
......@@ -396,8 +396,8 @@ showSDocDumpOneLine :: SDoc -> String
showSDocDumpOneLine d
= Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDebug :: SDoc -> String
showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug _ d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags = showSDoc dflags . ppr
......
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