Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
b39ab7d5
Commit
b39ab7d5
authored
Jun 12, 2012
by
Ian Lynagh
Browse files
Pass DynFlags down to showSDocDebug
parent
ab50c9c5
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/codeGen/CgTicky.hs
View file @
b39ab7d5
...
...
@@ -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
...
...
compiler/codeGen/StgCmmTicky.hs
View file @
b39ab7d5
...
...
@@ -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
...
...
compiler/iface/TcIface.lhs
View file @
b39ab7d5
...
...
@@ -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
...
...
compiler/simplCore/SimplCore.lhs
View file @
b39ab7d5
...
...
@@ -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
...
...
compiler/stranal/WorkWrap.lhs
View file @
b39ab7d5
...
...
@@ -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]
...
...
compiler/stranal/WwLib.lhs
View file @
b39ab7d5
...
...
@@ -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)]
...
...
compiler/utils/Outputable.lhs
View file @
b39ab7d5
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment