summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Cmm')
-rw-r--r--compiler/GHC/Cmm/CLabel.hs4
-rw-r--r--compiler/GHC/Cmm/Dataflow/Label.hs6
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs49
-rw-r--r--compiler/GHC/Cmm/Info/Build.hs107
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs2
-rw-r--r--compiler/GHC/Cmm/Lint.hs32
-rw-r--r--compiler/GHC/Cmm/Parser.y15
-rw-r--r--compiler/GHC/Cmm/Pipeline.hs14
-rw-r--r--compiler/GHC/Cmm/Ppr.hs119
-rw-r--r--compiler/GHC/Cmm/Ppr/Decl.hs80
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs24
-rw-r--r--compiler/GHC/Cmm/ProcPoint.hs2
12 files changed, 232 insertions, 222 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c8f39b80ef..924991794f 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -1210,8 +1210,8 @@ The info table label and the local block label are both local labels
and are not externally visible.
-}
-instance Outputable CLabel where
- ppr lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) (targetPlatform dflags) lbl)
+instance OutputableP CLabel where
+ pdoc platform lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) platform lbl)
pprCLabel :: Backend -> Platform -> CLabel -> SDoc
pprCLabel bcknd platform lbl =
diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs
index a63cc63ed8..e01f301627 100644
--- a/compiler/GHC/Cmm/Dataflow/Label.hs
+++ b/compiler/GHC/Cmm/Dataflow/Label.hs
@@ -43,6 +43,9 @@ instance Uniquable Label where
instance Outputable Label where
ppr label = ppr (getUnique label)
+instance OutputableP Label where
+ pdoc _ l = ppr l
+
-----------------------------------------------------------------------------
-- LabelSet
@@ -128,6 +131,9 @@ instance Outputable LabelSet where
instance Outputable a => Outputable (LabelMap a) where
ppr = ppr . mapToList
+instance OutputableP a => OutputableP (LabelMap a) where
+ pdoc platform = pdoc platform . mapToList
+
instance TrieMap LabelMap where
type Key LabelMap = Label
emptyTM = mapEmpty
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 2d8ec5f2b3..927003b16f 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -72,19 +72,20 @@ data DebugBlock =
, dblBlocks :: ![DebugBlock] -- ^ Nested blocks
}
-instance Outputable DebugBlock where
- ppr blk = (if | dblProcedure blk == dblLabel blk
+instance OutputableP DebugBlock where
+ pdoc platform blk =
+ (if | dblProcedure blk == dblLabel blk
-> text "proc"
| dblHasInfoTbl blk
-> text "pp-blk"
| otherwise
-> text "blk") <+>
- ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
+ ppr (dblLabel blk) <+> parens (pdoc platform (dblCLabel blk)) <+>
(maybe empty ppr (dblSourceTick blk)) <+>
(maybe (text "removed") ((text "pos " <>) . ppr)
(dblPosition blk)) <+>
- (ppr (dblUnwind blk)) $+$
- (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))
+ (pdoc platform (dblUnwind blk)) $+$
+ (if null (dblBlocks blk) then empty else nest 4 (pdoc platform (dblBlocks blk)))
-- | Intermediate data structure holding debug-relevant context information
-- about a block.
@@ -489,12 +490,12 @@ LOC this information will end up in is Y.
-- | A label associated with an 'UnwindTable'
data UnwindPoint = UnwindPoint !CLabel !UnwindTable
-instance Outputable UnwindPoint where
- ppr (UnwindPoint lbl uws) =
- braces $ ppr lbl<>colon
+instance OutputableP UnwindPoint where
+ pdoc platform (UnwindPoint lbl uws) =
+ braces $ pdoc platform lbl <> colon
<+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
where
- pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+ pprUw (g, expr) = ppr g <> char '=' <> pdoc platform expr
-- | Maps registers to expressions that yield their "old" values
-- further up the stack. Most interesting for the stack pointer @Sp@,
@@ -513,19 +514,19 @@ data UnwindExpr = UwConst !Int -- ^ literal value
| UwTimes UnwindExpr UnwindExpr
deriving (Eq)
-instance Outputable UnwindExpr where
- pprPrec _ (UwConst i) = ppr i
- pprPrec _ (UwReg g 0) = ppr g
- pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
- pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e
- pprPrec _ (UwLabel l) = pprPrec 3 l
- pprPrec p (UwPlus e0 e1) | p <= 0
- = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
- pprPrec p (UwMinus e0 e1) | p <= 0
- = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
- pprPrec p (UwTimes e0 e1) | p <= 1
- = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
- pprPrec _ other = parens (pprPrec 0 other)
+instance OutputableP UnwindExpr where
+ pdocPrec _ _ (UwConst i) = ppr i
+ pdocPrec _ _ (UwReg g 0) = ppr g
+ pdocPrec p platform (UwReg g x) = pdocPrec p platform (UwPlus (UwReg g 0) (UwConst x))
+ pdocPrec _ platform (UwDeref e) = char '*' <> pdocPrec 3 platform e
+ pdocPrec _ platform (UwLabel l) = pdocPrec 3 platform l
+ pdocPrec p platform (UwPlus e0 e1) | p <= 0
+ = pdocPrec 0 platform e0 <> char '+' <> pdocPrec 0 platform e1
+ pdocPrec p platform (UwMinus e0 e1) | p <= 0
+ = pdocPrec 1 platform e0 <> char '-' <> pdocPrec 1 platform e1
+ pdocPrec p platform (UwTimes e0 e1) | p <= 1
+ = pdocPrec 2 platform e0 <> char '*' <> pdocPrec 2 platform e1
+ pdocPrec _ platform other = parens (pdocPrec 0 platform other)
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
@@ -549,5 +550,5 @@ toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
(pprExpr platform e)
-toUnwindExpr _ e
- = pprPanic "Unsupported unwind expression!" (ppr e)
+toUnwindExpr platform e
+ = pprPanic "Unsupported unwind expression!" (pdoc platform e)
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index efb5f80802..0497f18937 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
- ScopedTypeVariables, OverloadedStrings #-}
+ ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
module GHC.Cmm.Info.Build
( CAFSet, CAFEnv, cafAnal, cafAnalData
@@ -455,7 +455,7 @@ non-CAFFY.
-- map them to SRTEntry later, which ranges over labels that do exist.
--
newtype CAFLabel = CAFLabel CLabel
- deriving (Eq,Ord,Outputable)
+ deriving (Eq,Ord,OutputableP)
type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
@@ -466,7 +466,7 @@ mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)
-- This is a label that we can put in an SRT. It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
newtype SRTEntry = SRTEntry CLabel
- deriving (Eq, Ord, Outputable)
+ deriving (Eq, Ord, OutputableP)
-- ---------------------------------------------------------------------
-- CAF analysis
@@ -571,12 +571,12 @@ cafTransfers platform contLbls entry topLbl
_ ->
set
in
- srtTrace "cafTransfers" (text "block:" <+> ppr block $$
- text "contLbls:" <+> ppr contLbls $$
- text "entry:" <+> ppr entry $$
- text "topLbl:" <+> ppr topLbl $$
- text "cafs in exit:" <+> ppr joined $$
- text "result:" <+> ppr result) $
+ srtTrace "cafTransfers" (text "block:" <+> pdoc platform block $$
+ text "contLbls:" <+> ppr contLbls $$
+ text "entry:" <+> ppr entry $$
+ text "topLbl:" <+> pdoc platform topLbl $$
+ text "cafs in exit:" <+> pdoc platform joined $$
+ text "result:" <+> pdoc platform result) $
mapSingleton (entryLabel eNode) result
@@ -597,12 +597,12 @@ data ModuleSRTInfo = ModuleSRTInfo
, moduleSRTMap :: SRTMap
}
-instance Outputable ModuleSRTInfo where
- ppr ModuleSRTInfo{..} =
+instance OutputableP ModuleSRTInfo where
+ pdoc platform ModuleSRTInfo{..} =
text "ModuleSRTInfo {" $$
- (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$
- text "flatSRTs =" <+> ppr flatSRTs $$
- text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}'
+ (nest 4 $ text "dedupSRTs =" <+> pdoc platform dedupSRTs $$
+ text "flatSRTs =" <+> pdoc platform flatSRTs $$
+ text "moduleSRTMap =" <+> pdoc platform moduleSRTMap) $$ char '}'
emptySRT :: Module -> ModuleSRTInfo
emptySRT mod =
@@ -635,9 +635,10 @@ data SomeLabel
| DeclLabel CLabel
deriving (Eq, Ord)
-instance Outputable SomeLabel where
- ppr (BlockLabel l) = text "b:" <+> ppr l
- ppr (DeclLabel l) = text "s:" <+> ppr l
+instance OutputableP SomeLabel where
+ pdoc platform = \case
+ BlockLabel l -> text "b:" <+> pdoc platform l
+ DeclLabel l -> text "s:" <+> pdoc platform l
getBlockLabel :: SomeLabel -> Maybe Label
getBlockLabel (BlockLabel l) = Just l
@@ -672,9 +673,9 @@ depAnalSRTs
-> [CmmDecl]
-> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
depAnalSRTs platform cafEnv cafEnv_static decls =
- srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$
- text "nodes:" <+> ppr (map node_payload nodes) $$
- text "graph:" <+> ppr graph) graph
+ srtTrace "depAnalSRTs" (text "decls:" <+> pdoc platform decls $$
+ text "nodes:" <+> pdoc platform (map node_payload nodes) $$
+ text "graph:" <+> pdoc platform graph) graph
where
labelledBlocks :: [(SomeLabel, CAFLabel)]
labelledBlocks = concatMap (getLabelledBlocks platform) decls
@@ -749,7 +750,7 @@ srtMapNonCAFs srtMap =
-- | resolve a CAFLabel to its SRTEntry using the SRTMap
resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF platform srtMap lbl@(CAFLabel l) =
- srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret
+ srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret
where
ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap
@@ -777,7 +778,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do
\(set, decl) ->
case decl of
CmmProc{} ->
- pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl)
+ pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
CmmData _ static ->
case static of
CmmStatics lbl _ _ _ -> (lbl, set)
@@ -806,11 +807,11 @@ doSRTs dflags moduleSRTInfo procs data_ = do
cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
cafsWithSRTs = getCAFs platform cafEnv decls
- srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$
- text "procs:" <+> ppr procs $$
- text "static_data_env:" <+> ppr static_data_env $$
- text "sccs:" <+> ppr sccs $$
- text "cafsWithSRTs:" <+> ppr cafsWithSRTs)
+ srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$
+ text "procs:" <+> pdoc platform procs $$
+ text "static_data_env:" <+> pdoc platform static_data_env $$
+ text "sccs:" <+> pdoc platform sccs $$
+ text "cafsWithSRTs:" <+> pdoc platform cafsWithSRTs)
-- On each strongly-connected group of decls, construct the SRT
-- closures and the SRT fields for info tables.
@@ -860,7 +861,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do
-- Not an IdLabel, ignore
srtMap
CmmProc{} ->
- pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl))
+ pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
(moduleSRTMap moduleSRTInfo') data_
return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
@@ -966,18 +967,18 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
filtered0 = Set.fromList resolved `Set.difference` allBelow
srtTraceM "oneSRT:"
- (text "srtMap:" <+> ppr srtMap $$
- text "nonRec:" <+> ppr nonRec $$
- text "lbls:" <+> ppr lbls $$
- text "caf_lbls:" <+> ppr caf_lbls $$
- text "static_data:" <+> ppr static_data $$
- text "cafs:" <+> ppr cafs $$
- text "blockids:" <+> ppr blockids $$
- text "maybeFunClosure:" <+> ppr maybeFunClosure $$
- text "otherFunLabels:" <+> ppr otherFunLabels $$
- text "resolved:" <+> ppr resolved $$
- text "allBelow:" <+> ppr allBelow $$
- text "filtered0:" <+> ppr filtered0)
+ (text "srtMap:" <+> pdoc platform srtMap $$
+ text "nonRec:" <+> pdoc platform nonRec $$
+ text "lbls:" <+> pdoc platform lbls $$
+ text "caf_lbls:" <+> pdoc platform caf_lbls $$
+ text "static_data:" <+> pdoc platform static_data $$
+ text "cafs:" <+> pdoc platform cafs $$
+ text "blockids:" <+> ppr blockids $$
+ text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$
+ text "otherFunLabels:" <+> pdoc platform otherFunLabels $$
+ text "resolved:" <+> pdoc platform resolved $$
+ text "allBelow:" <+> pdoc platform allBelow $$
+ text "filtered0:" <+> pdoc platform filtered0)
let
isStaticFun = isJust maybeFunClosure
@@ -989,7 +990,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap srtEntry =
srtTrace "updateSRTMap"
- (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+>
+ (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>
"isStaticFun:" <+> ppr isStaticFun) $
when (not isCAF && (not isStaticFun || isNothing srtEntry)) $
modify' $ \state ->
@@ -1012,7 +1013,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls
if Set.null filtered0 then do
- srtTraceM "oneSRT: empty" (ppr caf_lbls)
+ srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)
updateSRTMap Nothing
return ([], [], [], False)
else do
@@ -1021,8 +1022,8 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
let allBelow_funs =
Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
let filtered = filtered0 `Set.union` allBelow_funs
- srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$
- text "allBelow_funs:" <+> ppr allBelow_funs)
+ srtTraceM "oneSRT" (text "filtered:" <+> pdoc platform filtered $$
+ text "allBelow_funs:" <+> pdoc platform allBelow_funs)
case Set.toList filtered of
[] -> pprPanic "oneSRT" empty -- unreachable
@@ -1054,8 +1055,8 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
[ (b, if b == staticFunBlock then lbl else staticFunLbl)
| b <- blockids ]
Nothing -> do
- srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$
- text "one:" <+> ppr one)
+ srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
+ text "one:" <+> pdoc platform one)
updateSRTMap (Just one)
return ([], map (,lbl) blockids, [], True)
@@ -1067,7 +1068,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
-- Implements the [Common] optimisation.
case Map.lookup filtered (dedupSRTs topSRT) of
Just srtEntry@(SRTEntry srtLbl) -> do
- srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl)
+ srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)
updateSRTMap (Just srtEntry)
return ([], map (,srtLbl) blockids, [], True)
Nothing -> do
@@ -1087,11 +1088,11 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
modify' (\state -> state{ dedupSRTs = newDedupSRTs,
flatSRTs = newFlatSRTs })
- srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$
- text "filtered:" <+> ppr filtered $$
- text "srtEntry:" <+> ppr srtEntry $$
- text "newDedupSRTs:" <+> ppr newDedupSRTs $$
- text "newFlatSRTs:" <+> ppr newFlatSRTs)
+ srtTraceM "oneSRT: new" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
+ text "filtered:" <+> pdoc platform filtered $$
+ text "srtEntry:" <+> pdoc platform srtEntry $$
+ text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$
+ text "newFlatSRTs:" <+> pdoc platform newFlatSRTs)
let SRTEntry lbl = srtEntry
return (decls, map (,lbl) blockids, funSRTs, True)
@@ -1179,7 +1180,7 @@ updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
-- if we don't add SRT entries to this closure, then we
-- want to set the srt field in its info table as usual
(info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
- Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+ Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
(info_tbl { cit_rep = new_rep }, res)
where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 19358d350d..5b393de902 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -1023,7 +1023,7 @@ setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)
get_liveness :: BlockId -> Liveness
get_liveness lbl
= case mapLookup lbl stackmaps of
- Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
+ Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> pdoc platform info_tbls)
Just sm -> stackMapToLiveness platform sm
setInfoTableStackMap _ _ d = d
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index 2eccf50d0e..da9ff30d85 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -37,25 +37,27 @@ import Control.Monad (ap, unless)
-- -----------------------------------------------------------------------------
-- Exported entry points:
-cmmLint :: (Outputable d, Outputable h)
+cmmLint :: (OutputableP d, OutputableP h)
=> Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
-runCmmLint :: Outputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint :: OutputableP a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint platform l p =
case unCL (l p) platform of
Left err -> Just (vcat [text "Cmm lint error:",
nest 2 err,
text "Program was:",
- nest 2 (ppr p)])
+ nest 2 (pdoc platform p)])
Right _ -> Nothing
lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
lintCmmDecl (CmmProc _ lbl _ g)
- = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
+ = do
+ platform <- getPlatform
+ addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g
lintCmmDecl (CmmData {})
= return ()
@@ -188,7 +190,7 @@ lintCmmLast labels node = case node of
if (erep `cmmEqType_ignoring_ptrhood` bWord platform)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
- ppr e <> text " :: " <> ppr erep)
+ pdoc platform e <> text " :: " <> ppr erep)
CmmCall { cml_target = target, cml_cont = cont } -> do
_ <- lintCmmExpr target
@@ -222,21 +224,21 @@ lintTarget (PrimTarget {}) = return ()
-- | As noted in Note [Register parameter passing], the arguments and
-- 'ForeignTarget' of a foreign call mustn't mention
-- caller-saved registers.
-mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)
+mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP a)
=> SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs what thing = do
platform <- getPlatform
let badRegs = filter (callerSaves platform)
$ foldRegsUsed platform (flip (:)) [] thing
unless (null badRegs)
- $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)
+ $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing)
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
-checkCond _ expr
+checkCond platform expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
- (ppr expr))
+ (pdoc platform expr))
-- -----------------------------------------------------------------------------
-- CmmLint monad
@@ -270,15 +272,19 @@ addLintInfo info thing = CmmLint $ \platform ->
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
- = cmmLintErr (text "in MachOp application: " $$
- nest 2 (ppr expr) $$
+ = do
+ platform <- getPlatform
+ cmmLintErr (text "in MachOp application: " $$
+ nest 2 (pdoc platform expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
- = cmmLintErr (text "in assignment: " $$
- nest 2 (vcat [ppr stmt,
+ = do
+ platform <- getPlatform
+ cmmLintErr (text "in assignment: " $$
+ nest 2 (vcat [pdoc platform stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index b2c107d429..3771a0e82c 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -442,8 +442,9 @@ cmmproc :: { CmmParse () }
getCodeScoped $ loopDecls $ do {
(entry_ret_label, info, stk_formals) <- $1;
dflags <- getDynFlags;
+ platform <- getPlatform;
formals <- sequence (fromMaybe [] $3);
- withName (showSDoc dflags (ppr entry_ret_label))
+ withName (showSDoc dflags (pdoc platform entry_ret_label))
$4;
return (entry_ret_label, info, stk_formals, formals) }
let do_layout = isJust $3
@@ -996,8 +997,8 @@ machOps = listToUFM $
( "i2f64", flip MO_SF_Conv W64 )
]
-callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
-callishMachOps = listToUFM $
+callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
+callishMachOps platform = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (MO_ReadBarrier,)),
( "write_barrier", (MO_WriteBarrier,)),
@@ -1049,7 +1050,7 @@ callishMachOps = listToUFM $
args' = init args
align = case last args of
CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
- e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (ppr e)
+ e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e)
-- The alignment of memcpy-ish operations must be a
-- compile-time constant. We verify this here, passing it around
-- in the MO_* constructor. In order to do this, however, we
@@ -1166,7 +1167,7 @@ reserveStackFrame psize preg body = do
let size = case constantFoldExpr platform esize of
CmmLit (CmmInt n _) -> n
_other -> pprPanic "CmmParse: not a compile-time integer: "
- (ppr esize)
+ (pdoc platform esize)
let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size
emitAssign reg (CmmStackSlot Old frame)
withUpdFrameOff frame body
@@ -1269,7 +1270,9 @@ primCall
-> [CmmParse CmmExpr]
-> PD (CmmParse ())
primCall results_code name args_code
- = case lookupUFM callishMachOps name of
+ = do
+ platform <- PD.getPlatform
+ case lookupUFM (callishMachOps platform) name of
Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
Just f -> return $ do
results <- sequence results_code
diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index f213a28cfe..b3f9606512 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -45,12 +45,13 @@ cmmPipeline
cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
+ platform = targetPlatform dflags
tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog
let (procs, data_) = partitionEithers tops
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_
- dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)
+ dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
return (srtInfo, cmms)
@@ -99,7 +100,7 @@ cpsTop dflags proc =
pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet platform call_pps g
dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
- FormatCMM (ppr l $$ ppr pp $$ ppr g)
+ FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
return pp
else
return call_pps
@@ -119,7 +120,7 @@ cpsTop dflags proc =
------------- CAF analysis ----------------------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
- dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)
+ dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
g <- if splitting_proc_points
then do
@@ -157,7 +158,7 @@ cpsTop dflags proc =
dump = dumpGraph dflags
dumps flag name
- = mapM_ (dumpWith dflags flag name FormatCMM . ppr)
+ = mapM_ (dumpWith dflags flag name FormatCMM . pdoc platform)
condPass flag pass g dumpflag dumpname =
if gopt flag dflags
@@ -353,9 +354,10 @@ runUniqSM m = do
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
when (gopt Opt_DoCmmLinting dflags) $ do_lint g
- dumpWith dflags flag name FormatCMM (ppr g)
+ dumpWith dflags flag name FormatCMM (pdoc platform g)
where
- do_lint g = case cmmLintGraph (targetPlatform dflags) g of
+ platform = targetPlatform dflags
+ do_lint g = case cmmLintGraph platform g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
}
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index f451550ed1..b791b78d70 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -43,7 +43,6 @@ where
import GHC.Prelude hiding (succ)
import GHC.Platform
-import GHC.Driver.Session (targetPlatform)
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
@@ -64,13 +63,12 @@ import GHC.Cmm.Dataflow.Graph
instance Outputable CmmStackInfo where
ppr = pprStackInfo
-instance Outputable CmmTopInfo where
- ppr = pprTopInfo
+instance OutputableP CmmTopInfo where
+ pdoc = pprTopInfo
-instance Outputable (CmmNode e x) where
- ppr e = sdocWithDynFlags $ \dflags ->
- pprNode (targetPlatform dflags) e
+instance OutputableP (CmmNode e x) where
+ pdoc = pprNode
instance Outputable Convention where
ppr = pprConvention
@@ -78,26 +76,26 @@ instance Outputable Convention where
instance Outputable ForeignConvention where
ppr = pprForeignConvention
-instance Outputable ForeignTarget where
- ppr = pprForeignTarget
+instance OutputableP ForeignTarget where
+ pdoc = pprForeignTarget
instance Outputable CmmReturnInfo where
ppr = pprReturnInfo
-instance Outputable (Block CmmNode C C) where
- ppr = pprBlock
-instance Outputable (Block CmmNode C O) where
- ppr = pprBlock
-instance Outputable (Block CmmNode O C) where
- ppr = pprBlock
-instance Outputable (Block CmmNode O O) where
- ppr = pprBlock
+instance OutputableP (Block CmmNode C C) where
+ pdoc = pprBlock
+instance OutputableP (Block CmmNode C O) where
+ pdoc = pprBlock
+instance OutputableP (Block CmmNode O C) where
+ pdoc = pprBlock
+instance OutputableP (Block CmmNode O O) where
+ pdoc = pprBlock
-instance Outputable (Graph CmmNode e x) where
- ppr = pprGraph
+instance OutputableP (Graph CmmNode e x) where
+ pdoc = pprGraph
-instance Outputable CmmGraph where
- ppr = pprCmmGraph
+instance OutputableP CmmGraph where
+ pdoc = pprCmmGraph
----------------------------------------------------------
-- Outputting types Cmm contains
@@ -106,40 +104,41 @@ pprStackInfo :: CmmStackInfo -> SDoc
pprStackInfo (StackInfo {arg_space=arg_space}) =
text "arg_space: " <> ppr arg_space
-pprTopInfo :: CmmTopInfo -> SDoc
-pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
- vcat [text "info_tbls: " <> ppr info_tbl,
+pprTopInfo :: Platform -> CmmTopInfo -> SDoc
+pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+ vcat [text "info_tbls: " <> pdoc platform info_tbl,
text "stack_info: " <> ppr stack_info]
----------------------------------------------------------
-- Outputting blocks and graphs
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
- => Block CmmNode e x -> IndexedCO e SDoc SDoc
-pprBlock block
- = foldBlockNodesB3 ( ($$) . ppr
- , ($$) . (nest 4) . ppr
- , ($$) . (nest 4) . ppr
+ => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock platform block
+ = foldBlockNodesB3 ( ($$) . pdoc platform
+ , ($$) . (nest 4) . pdoc platform
+ , ($$) . (nest 4) . pdoc platform
)
block
empty
-pprGraph :: Graph CmmNode e x -> SDoc
-pprGraph GNil = empty
-pprGraph (GUnit block) = ppr block
-pprGraph (GMany entry body exit)
- = text "{"
- $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
- $$ text "}"
- where pprMaybeO :: Outputable (Block CmmNode e x)
- => MaybeO ex (Block CmmNode e x) -> SDoc
- pprMaybeO NothingO = empty
- pprMaybeO (JustO block) = ppr block
-
-pprCmmGraph :: CmmGraph -> SDoc
-pprCmmGraph g
+pprGraph :: Platform -> Graph CmmNode e x -> SDoc
+pprGraph platform = \case
+ GNil -> empty
+ GUnit block -> pdoc platform block
+ GMany entry body exit ->
+ text "{"
+ $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)
+ $$ text "}"
+ where pprMaybeO :: OutputableP (Block CmmNode e x)
+ => MaybeO ex (Block CmmNode e x) -> SDoc
+ pprMaybeO NothingO = empty
+ pprMaybeO (JustO block) = pdoc platform block
+
+pprCmmGraph :: Platform -> CmmGraph -> SDoc
+pprCmmGraph platform g
= text "{" <> text "offset"
- $$ nest 2 (vcat $ map ppr blocks)
+ $$ nest 2 (vcat $ map (pdoc platform) blocks)
$$ text "}"
where blocks = revPostorder g
-- revPostorder has the side-effect of discarding unreachable code,
@@ -164,17 +163,17 @@ pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo CmmMayReturn = empty
pprReturnInfo CmmNeverReturns = text "never returns"
-pprForeignTarget :: ForeignTarget -> SDoc
-pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+pprForeignTarget :: Platform -> ForeignTarget -> SDoc
+pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn
where
ppr_target :: CmmExpr -> SDoc
- ppr_target t@(CmmLit _) = ppr t
- ppr_target fn' = parens (ppr fn')
+ ppr_target t@(CmmLit _) = pdoc platform t
+ ppr_target fn' = parens (pdoc platform fn')
-pprForeignTarget (PrimTarget op)
+pprForeignTarget platform (PrimTarget op)
-- HACK: We're just using a ForeignLabel to get this printed, the label
-- might not really be foreign.
- = ppr
+ = pdoc platform
(CmmLabel (mkForeignLabel
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction))
@@ -203,13 +202,13 @@ pprNode platform node = pp_node <+> pp_debug
-- unwind reg = expr;
CmmUnwind regs ->
text "unwind "
- <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+ <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi
-- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+ CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi
-- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ CmmStore lv expr -> rep <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
where
rep = ppr ( cmmExprType platform expr )
@@ -219,7 +218,7 @@ pprNode platform node = pp_node <+> pp_debug
hsep [ ppUnless (null results) $
parens (commafy $ map ppr results) <+> equals,
text "call",
- ppr target <> parens (commafy $ map ppr args) <> semi]
+ pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]
-- goto label;
CmmBranch ident -> text "goto" <+> ppr ident <> semi
@@ -227,7 +226,7 @@ pprNode platform node = pp_node <+> pp_debug
-- if (expr) goto t; else goto f;
CmmCondBranch expr t f l ->
hsep [ text "if"
- , parens(ppr expr)
+ , parens (pdoc platform expr)
, case l of
Nothing -> empty
Just b -> parens (text "likely:" <+> ppr b)
@@ -241,8 +240,8 @@ pprNode platform node = pp_node <+> pp_debug
hang (hsep [ text "switch"
, range
, if isTrivialCmmExpr expr
- then ppr expr
- else parens (ppr expr)
+ then pdoc platform expr
+ else parens (pdoc platform expr)
, text "{"
])
4 (vcat (map ppCase cases) $$ def) $$ rbrace
@@ -271,8 +270,8 @@ pprNode platform node = pp_node <+> pp_debug
text "res: " <> ppr res <> comma <+>
text "upd: " <> ppr updfr_off
, semi ]
- where pprFun f@(CmmLit _) = ppr f
- pprFun f = parens (ppr f)
+ where pprFun f@(CmmLit _) = pdoc platform f
+ pprFun f = parens (pdoc platform f)
returns
| Just r <- k = text "returns to" <+> ppr r <> comma
@@ -281,9 +280,9 @@ pprNode platform node = pp_node <+> pp_debug
CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
hcat $ if i then [text "interruptible", space] else [] ++
[ text "foreign call", space
- , ppr t, text "(...)", space
+ , pdoc platform t, text "(...)", space
, text "returns to" <+> ppr s
- <+> text "args:" <+> parens (ppr as)
+ <+> text "args:" <+> parens (pdoc platform as)
<+> text "ress:" <+> parens (ppr rs)
, text "ret_args:" <+> ppr a
, text "ret_off:" <+> ppr u
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index 94216a537b..b65cb9bd0b 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -36,7 +36,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Cmm.Ppr.Decl
- ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
+ ( pprCmms, pprCmmGroup, pprSection, pprStatic
)
where
@@ -46,62 +46,54 @@ import GHC.Platform
import GHC.Cmm.Ppr.Expr
import GHC.Cmm
-import GHC.Driver.Ppr
-import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Data.FastString
import Data.List
-import System.IO
import qualified Data.ByteString as BS
-pprCmms :: (Outputable info, Outputable g)
- => [GenCmmGroup RawCmmStatics info g] -> SDoc
-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+pprCmms :: (OutputableP info, OutputableP g)
+ => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
where
separator = space $$ text "-------------------" $$ space
-writeCmms :: (Outputable info, Outputable g)
- => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
-writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
-
-----------------------------------------------------------------------------
-instance (Outputable d, Outputable info, Outputable i)
- => Outputable (GenCmmDecl d info i) where
- ppr t = pprTop t
+instance (OutputableP d, OutputableP info, OutputableP i)
+ => OutputableP (GenCmmDecl d info i) where
+ pdoc = pprTop
-instance Outputable (GenCmmStatics a) where
- ppr = pprStatics
+instance OutputableP (GenCmmStatics a) where
+ pdoc = pprStatics
-instance Outputable CmmStatic where
- ppr e = sdocWithDynFlags $ \dflags ->
- pprStatic (targetPlatform dflags) e
+instance OutputableP CmmStatic where
+ pdoc = pprStatic
-instance Outputable CmmInfoTable where
- ppr = pprInfoTable
+instance OutputableP CmmInfoTable where
+ pdoc = pprInfoTable
-----------------------------------------------------------------------------
-pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
- => GenCmmGroup d info g -> SDoc
-pprCmmGroup tops
- = vcat $ intersperse blankLine $ map pprTop tops
+pprCmmGroup :: (OutputableP d, OutputableP info, OutputableP g)
+ => Platform -> GenCmmGroup d info g -> SDoc
+pprCmmGroup platform tops
+ = vcat $ intersperse blankLine $ map (pprTop platform) tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable d, Outputable info, Outputable i)
- => GenCmmDecl d info i -> SDoc
+pprTop :: (OutputableP d, OutputableP info, OutputableP i)
+ => Platform -> GenCmmDecl d info i -> SDoc
-pprTop (CmmProc info lbl live graph)
+pprTop platform (CmmProc info lbl live graph)
- = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
- , nest 8 $ lbrace <+> ppr info $$ rbrace
- , nest 4 $ ppr graph
+ = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
+ , nest 8 $ lbrace <+> pdoc platform info $$ rbrace
+ , nest 4 $ pdoc platform graph
, rbrace ]
-- --------------------------------------------------------------------------
@@ -109,25 +101,25 @@ pprTop (CmmProc info lbl live graph)
--
-- section "data" { ... }
--
-pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (ppr ds))
+pprTop platform (CmmData section ds) =
+ (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))
$$ rbrace
-- --------------------------------------------------------------------------
-- Info tables.
-pprInfoTable :: CmmInfoTable -> SDoc
-pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+pprInfoTable :: Platform -> CmmInfoTable -> SDoc
+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, cit_prof = prof_info
, cit_srt = srt })
- = vcat [ text "label: " <> ppr lbl
+ = vcat [ text "label: " <> pdoc platform lbl
, text "rep: " <> ppr rep
, case prof_info of
NoProfilingInfo -> empty
ProfilingInfo ct cd ->
vcat [ text "type: " <> text (show (BS.unpack ct))
, text "desc: " <> text (show (BS.unpack cd)) ]
- , text "srt: " <> ppr srt ]
+ , text "srt: " <> pdoc platform srt ]
instance Outputable ForeignHint where
ppr NoHint = empty
@@ -142,10 +134,10 @@ instance Outputable ForeignHint where
-- following C--
--
-pprStatics :: GenCmmStatics a -> SDoc
-pprStatics (CmmStatics lbl itbl ccs payload) =
- ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload
-pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+pprStatics :: Platform -> GenCmmStatics a -> SDoc
+pprStatics platform (CmmStatics lbl itbl ccs payload) =
+ pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload
+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)
pprStatic :: Platform -> CmmStatic -> SDoc
pprStatic platform s = case s of
@@ -157,9 +149,9 @@ pprStatic platform s = case s of
-- --------------------------------------------------------------------------
-- data sections
--
-pprSection :: Section -> SDoc
-pprSection (Section t suffix) =
- section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
+pprSection :: Platform -> Section -> SDoc
+pprSection platform (Section t suffix) =
+ section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)
where
section = text "section"
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index 4bb8021541..5b1d01b00a 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -41,7 +41,6 @@ where
import GHC.Prelude
-import GHC.Driver.Session (targetPlatform)
import GHC.Driver.Ppr
import GHC.Platform
@@ -54,16 +53,14 @@ import Numeric ( fromRat )
-----------------------------------------------------------------------------
-instance Outputable CmmExpr where
- ppr e = sdocWithDynFlags $ \dflags ->
- pprExpr (targetPlatform dflags) e
+instance OutputableP CmmExpr where
+ pdoc = pprExpr
instance Outputable CmmReg where
ppr e = pprReg e
-instance Outputable CmmLit where
- ppr l = sdocWithDynFlags $ \dflags ->
- pprLit (targetPlatform dflags) l
+instance OutputableP CmmLit where
+ pdoc = pprLit
instance Outputable LocalReg where
ppr e = pprLocalReg e
@@ -74,6 +71,9 @@ instance Outputable Area where
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
+instance OutputableP GlobalReg where
+ pdoc _ = ppr
+
-- --------------------------------------------------------------------------
-- Expressions
--
@@ -147,7 +147,7 @@ pprExpr9 :: Platform -> CmmExpr -> SDoc
pprExpr9 platform e =
case e of
CmmLit lit -> pprLit1 platform lit
- CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
+ CmmLoad expr rep -> ppr rep <> brackets (pdoc platform expr)
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
@@ -204,10 +204,10 @@ pprLit platform lit = case lit of
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
- CmmLabel clbl -> ppr clbl
- CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
- CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
- <> ppr clbl2 <> ppr_offset i
+ CmmLabel clbl -> pdoc platform clbl
+ CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'
+ <> pdoc platform clbl2 <> ppr_offset i
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs
index 1a0c4708da..23dbc282d9 100644
--- a/compiler/GHC/Cmm/ProcPoint.hs
+++ b/compiler/GHC/Cmm/ProcPoint.hs
@@ -206,7 +206,7 @@ extendPPSet platform g blocks procPoints =
newPoint = listToMaybe newPoints
ppSuccessor b =
let nreached id = case mapLookup id env `orElse`
- pprPanic "no ppt" (ppr id <+> ppr b) of
+ pprPanic "no ppt" (ppr id <+> pdoc platform b) of
ProcPoint -> 1
ReachedBy ps -> setSize ps
block_procpoints = nreached (entryLabel b)
View Lorry Controller Status