Commit 8685576a authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Pass DynFlags down to showSDocDump

To help with this, we now also pass DynFlags around inside the SpecM
monad.
parent a6ec9493
......@@ -79,7 +79,8 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
; srt_info <- getSRTInfo srt
; mod_name <- getModuleName
; let descr = closureDescription mod_name name
; dflags <- getDynFlags
; let descr = closureDescription dflags mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
closure_label = mkLocalClosureLabel name (idCafInfo id)
cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
......@@ -288,8 +289,9 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
; mod_name <- getModuleName
; c_srt <- getSRTInfo srt
; dflags <- getDynFlags
; let name = idName bndr
descr = closureDescription mod_name name
descr = closureDescription dflags mod_name name
fv_details :: [(NonVoid Id, VirtualHpOffset)]
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets (isLFThunk lf_info)
......@@ -336,10 +338,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
= do -- AHA! A STANDARD-FORM THUNK
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
; dflags <- getDynFlags
; let (tot_wds, ptr_wds, payload_w_offsets)
= mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
descr = closureDescription mod_name (idName bndr)
descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo False -- Not static
bndr lf_info tot_wds ptr_wds
NoC_SRT -- No SRT for a std-form closure
......@@ -685,13 +688,14 @@ link_caf _is_upd = do
-- name of the data constructor itself. Otherwise it is determined by
-- @closureDescription@ from the let binding information.
closureDescription :: Module -- Module
closureDescription :: DynFlags
-> Module -- Module
-> Name -- Id of closure binding
-> String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
closureDescription mod_name name
= showSDocDump (char '<' <>
closureDescription dflags mod_name name
= showSDocDump dflags (char '<' <>
(if isExternalName name
then ppr name -- ppr will include the module name prefix
else pprModule mod_name <> char '.' <> ppr name) <>
......
......@@ -896,7 +896,7 @@ tryUnfolding dflags id lone_variable
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
| dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
= pprTrace ("Considering inlining: " ++ showSDocDump (ppr id))
= pprTrace ("Considering inlining: " ++ showSDocDump dflags (ppr id))
(vcat [text "arg infos" <+> ppr arg_infos,
text "uf arity" <+> ppr uf_arity,
text "interesting continuation" <+> ppr cont_info,
......
......@@ -363,54 +363,54 @@ runCorePasses passes guts
do_pass guts pass
= do { dflags <- getDynFlags
; liftIO $ showPass dflags pass
; guts' <- doCorePass pass guts
; guts' <- doCorePass dflags pass guts
; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
; return guts' }
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
simplifyPgm pass
doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass _ pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
simplifyPgm pass
doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
doPass cseProgram
doCorePass _ CoreCSE = {-# SCC "CommonSubExpr" #-}
doPass cseProgram
doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
doPassD liberateCase
doCorePass _ CoreLiberateCase = {-# SCC "LiberateCase" #-}
doPassD liberateCase
doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
doPass floatInwards
doCorePass _ CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
doPass floatInwards
doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
doPassDUM (floatOutwards f)
doCorePass _ (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
doPassDUM (floatOutwards f)
doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
doPassU doStaticArgs
doCorePass _ CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
doPassU doStaticArgs
doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
doPassDM dmdAnalPgm
doCorePass _ CoreDoStrictness = {-# SCC "Stranal" #-}
doPassDM dmdAnalPgm
doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPassU wwTopBinds
doCorePass _ CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
doPassU wwTopBinds
doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
specProgram
doCorePass dflags CoreDoSpecialising = {-# SCC "Specialise" #-}
specProgram dflags
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
specConstrProgram
doCorePass _ CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
specConstrProgram
doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-}
vectorise
doCorePass _ CoreDoVectorisation = {-# SCC "Vectorise" #-}
vectorise
doCorePass CoreDoPrintCore = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = runCorePasses passes
doCorePass _ CoreDoPrintCore = observe printCore
doCorePass _ (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat
doCorePass _ CoreDoNothing = return
doCorePass _ (CoreDoPasses passes) = runCorePasses passes
#ifdef GHCI
doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
doCorePass _ (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
#endif
doCorePass pass = pprPanic "doCorePass" (ppr pass)
doCorePass _ pass = pprPanic "doCorePass" (ppr pass)
\end{code}
%************************************************************************
......
......@@ -1425,7 +1425,7 @@ completeCall env var cont
pprDefiniteTrace "Inlining done:" (ppr var) stuff
else stuff
| otherwise
= pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var))
= pprDefiniteTrace ("Inlining done: " ++ showSDocDump dflags (ppr var))
(vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr cont])
stuff
......
......@@ -20,17 +20,20 @@ import CoreSyn
import Rules
import CoreUtils ( exprIsTrivial, applyTypeToArgs )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars )
import UniqSupply ( UniqSM, initUs_, MonadUnique(..) )
import UniqSupply
import Name
import MkId ( voidArgId, realWorldPrimId )
import Maybes ( catMaybes, isJust )
import BasicTypes
import HscTypes
import Bag
import DynFlags
import Util
import Outputable
import FastString
import State
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
......@@ -561,17 +564,17 @@ Hence, the invariant is this:
%************************************************************************
\begin{code}
specProgram :: ModGuts -> CoreM ModGuts
specProgram guts
specProgram :: DynFlags -> ModGuts -> CoreM ModGuts
specProgram dflags guts
= do { hpt_rules <- getRuleBase
; let local_rules = mg_rules guts
rule_base = extendRuleBaseList hpt_rules (mg_rules guts)
-- Specialise the bindings of this module
; (binds', uds) <- runSpecM (go (mg_binds guts))
; (binds', uds) <- runSpecM dflags (go (mg_binds guts))
-- Specialise imported functions
; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds
; (new_rules, spec_binds) <- specImports dflags emptyVarSet rule_base uds
; let final_binds | null spec_binds = binds'
| otherwise = Rec (flattenBinds spec_binds) : binds'
......@@ -593,7 +596,8 @@ specProgram guts
(bind', uds') <- specBind top_subst bind uds
return (bind' ++ binds', uds')
specImports :: VarSet -- Don't specialise these ones
specImports :: DynFlags
-> VarSet -- Don't specialise these ones
-- See Note [Avoiding recursive specialisation]
-> RuleBase -- Rules from this module and the home package
-- (but not external packages, which can change)
......@@ -601,24 +605,25 @@ specImports :: VarSet -- Don't specialise these ones
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings and floating bindings
-- See Note [Specialise imported INLINABLE things]
specImports done rb uds
specImports dflags done rb uds
= do { let import_calls = varEnvElts (ud_calls uds)
; (rules, spec_binds) <- go rb import_calls
; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
where
go _ [] = return ([], [])
go rb (CIS fn calls_for_fn : other_calls)
= do { (rules1, spec_binds1) <- specImport done rb fn (Map.toList calls_for_fn)
= do { (rules1, spec_binds1) <- specImport dflags done rb fn (Map.toList calls_for_fn)
; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
specImport :: VarSet -- Don't specialise these
specImport :: DynFlags
-> VarSet -- Don't specialise these
-- See Note [Avoiding recursive specialisation]
-> RuleBase -- Rules from this module
-> Id -> [CallInfo] -- Imported function and calls for it
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings
specImport done rb fn calls_for_fn
specImport dflags done rb fn calls_for_fn
| fn `elemVarSet` done
= return ([], []) -- No warning. This actually happens all the time
-- when specialising a recursive function, becuase
......@@ -635,7 +640,7 @@ specImport done rb fn calls_for_fn
; let full_rb = unionRuleBase rb (eps_rule_base eps)
rules_for_fn = getRules full_rb fn
; (rules1, spec_pairs, uds) <- runSpecM $
; (rules1, spec_pairs, uds) <- runSpecM dflags $
specCalls emptySubst rules_for_fn calls_for_fn fn rhs
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
-- After the rules kick in we may get recursion, but
......@@ -643,9 +648,9 @@ specImport done rb fn calls_for_fn
-- See Note [Glom the bindings if imported functions are specialised]
-- Now specialise any cascaded calls
; (rules2, spec_binds2) <- specImports (extendVarSet done fn)
(extendRuleBaseList rb rules1)
uds
; (rules2, spec_binds2) <- specImports dflags (extendVarSet done fn)
(extendRuleBaseList rb rules1)
uds
; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
......@@ -1127,10 +1132,11 @@ specCalls subst rules_for_me calls_for_me fn rhs
; spec_f <- newSpecIdSM fn spec_id_ty
; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
; dflags <- getDynFlags
; let
-- The rule to put in the function's specialisation is:
-- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b
rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args))
rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> ppr spec_ty_args))
spec_env_rule = mkRule True {- Auto generated -} is_local
rule_name
inl_act -- Note [Auto-specialisation and RULES]
......@@ -1782,11 +1788,39 @@ deleteCallsFor bs calls = delVarEnvList calls bs
%************************************************************************
\begin{code}
type SpecM a = UniqSM a
runSpecM:: SpecM a -> CoreM a
runSpecM spec = do { us <- getUniqueSupplyM
; return (initUs_ us spec) }
newtype SpecM a = SpecM (State SpecState a)
data SpecState = SpecState {
spec_uniq_supply :: UniqSupply,
spec_dflags :: DynFlags
}
instance Monad SpecM where
SpecM x >>= f = SpecM $ do y <- x
case f y of
SpecM z ->
z
return x = SpecM $ return x
fail str = SpecM $ fail str
instance MonadUnique SpecM where
getUniqueSupplyM
= SpecM $ do st <- get
let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
put $ st { spec_uniq_supply = us2 }
return us1
instance HasDynFlags SpecM where
getDynFlags = SpecM $ liftM spec_dflags get
runSpecM :: DynFlags -> SpecM a -> CoreM a
runSpecM dflags (SpecM spec)
= do us <- getUniqueSupplyM
let initialState = SpecState {
spec_uniq_supply = us,
spec_dflags = dflags
}
return $ evalState spec initialState
mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM _ [] = return ([], emptyUDs)
......
......@@ -388,8 +388,8 @@ showSDocUnqual _ d
showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
showSDocDump :: SDoc -> String
showSDocDump d
showSDocDump :: DynFlags -> SDoc -> String
showSDocDump _ d
= Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
showSDocDumpOneLine :: SDoc -> String
......
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