Commit ca48076a authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Introduce OutputableP

Some types need a Platform value to be pretty-printed: CLabel, Cmm
types, instructions, etc.

Before this patch they had an Outputable instance and the Platform value
was obtained via sdocWithDynFlags. It meant that the *renderer* of the
SDoc was responsible of passing the appropriate Platform value (e.g. via
the DynFlags given to showSDoc).  It put the burden of passing the
Platform value on the renderer while the generator of the SDoc knows the
Platform it is generating the SDoc for and there is no point passing a
different Platform at rendering time.

With this patch, we introduce a new OutputableP class:

   class OutputableP a where
      pdoc :: Platform -> a -> SDoc

With this class we still have some polymorphism as we have with `ppr`
(i.e. we can use `pdoc` on a variety of types instead of having a
dedicated `pprXXX` function for each XXX type).

One step closer removing `sdocWithDynFlags` (#10143) and supporting
several platforms (#14335).
parent 9dec8600
......@@ -266,9 +266,16 @@ newtype ListGraph i
instance Outputable instr => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance OutputableP instr => OutputableP (ListGraph instr) where
pdoc platform g = ppr (fmap (pdoc platform) g)
instance Outputable instr => Outputable (GenBasicBlock instr) where
ppr = pprBBlock
instance OutputableP instr => OutputableP (GenBasicBlock instr) where
pdoc platform block = ppr (fmap (pdoc platform) block)
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
......
......@@ -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 =
......
......@@ -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
......
......@@ -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)
{-# 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
......
......@@ -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
......
......@@ -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]))
......
......@@ -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
......
......@@ -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
}
......
......@@ -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