diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-09-02 19:42:01 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-17 20:04:08 -0400 |
| commit | ca48076ae866665913b9c81cbc0c76f0afef7a00 (patch) | |
| tree | 52ad46e313b99fc564bd77de2efeb0bfb8babb47 | |
| parent | 9dec8600ad4734607bea2b4dc3b40a5af788996b (diff) | |
| download | haskell-ca48076ae866665913b9c81cbc0c76f0afef7a00.tar.gz | |
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).
42 files changed, 777 insertions, 700 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index d93b885e9e..a5b3b35b8b 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -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)) 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) diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 4f19085ac9..108df2b600 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -150,7 +150,7 @@ nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqS nativeCodeGen dflags this_mod modLoc h us cmms = let config = initNCGConfig dflags platform = ncgPlatform config - nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr) + nCG' :: ( OutputableP statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms in case platformArch platform of @@ -214,7 +214,7 @@ unwinding table). See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} -nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr) +nativeCodeGen' :: (OutputableP statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -293,7 +293,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" FormatText -cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr) +cmmNativeGenStream :: (OutputableP statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -332,9 +332,10 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs + platform = targetPlatform dflags unless (null ldbgs) $ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText - (vcat $ map ppr ldbgs) + (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } @@ -348,7 +349,7 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest. - (Outputable statics, Outputable jumpDest, Instruction instr) + (OutputableP statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -391,7 +392,8 @@ cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks - {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) () + let platform = targetPlatform dflags + {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) () let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else [] @@ -425,7 +427,7 @@ emitNativeCode dflags config h sdoc = do -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: forall statics instr jumpDest. (Instruction instr, Outputable statics, Outputable jumpDest) + :: forall statics instr jumpDest. (Instruction instr, OutputableP statics, Outputable jumpDest) => DynFlags -> Module -> ModLocation -> NcgImpl statics instr jumpDest @@ -450,7 +452,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count let weights = ncgCfgWeights config let proc_name = case cmm of - (CmmProc _ entry_label _ _) -> ppr entry_label + (CmmProc _ entry_label _ _) -> pdoc platform entry_label _ -> text "DataChunk" -- rewrite assignments to global regs @@ -465,10 +467,10 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM - (pprCmmGroup [opt_cmm]) + (pprCmmGroup platform [opt_cmm]) let cmmCfg = {-# SCC "getCFG" #-} - getCfgProc weights opt_cmm + getCfgProc platform weights opt_cmm -- generate native code from cmm let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs index e054e488b6..cc38256d85 100644 --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -45,6 +45,7 @@ where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm as Cmm @@ -583,12 +584,12 @@ addNodesBetween weights m updates = -} -- | Generate weights for a Cmm proc based on some simple heuristics. -getCfgProc :: Weights -> RawCmmDecl -> CFG -getCfgProc _ (CmmData {}) = mapEmpty -getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph +getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG +getCfgProc _ _ (CmmData {}) = mapEmpty +getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph -getCfg :: Weights -> CmmGraph -> CFG -getCfg weights graph = +getCfg :: Platform -> Weights -> CmmGraph -> CFG +getCfg platform weights graph = foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks where Weights @@ -647,7 +648,7 @@ getCfg weights graph = other -> panic "Foo" $ ASSERT2(False, ppr "Unknown successor cause:" <> - (ppr branch <+> text "=>" <> ppr (G.successors other))) + (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other where bid = G.entryLabel block diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index c179b2f1d2..b247741600 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -73,7 +73,7 @@ dwarfGen config modLoc us blocks = do , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit - , compileUnitFooter unitU + , compileUnitFooter platform unitU ] -- .debug_line section: Generated mainly by the assembler, but we @@ -109,9 +109,9 @@ mkDwarfARange proc = DwarfARange start end compileUnitHeader :: Platform -> Unique -> SDoc compileUnitHeader platform unitU = let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field - length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel + length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel <> text "-4" -- length of initialLength field - in vcat [ ppr cuLabel <> colon + in vcat [ pdoc platform cuLabel <> colon , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) @@ -120,10 +120,10 @@ compileUnitHeader platform unitU = ] -- | Compilation unit footer, mainly establishing size of debug sections -compileUnitFooter :: Unique -> SDoc -compileUnitFooter unitU = +compileUnitFooter :: Platform -> Unique -> SDoc +compileUnitFooter platform unitU = let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU - in ppr cuEndLabel <> colon + in pdoc platform cuEndLabel <> colon -- | Splits the blocks by procedures. In the result all nested blocks -- will come from the same procedure as the top-level block. See diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index 8efdbab7fb..e0d2549dc9 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -174,19 +174,19 @@ pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowL $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir - $$ pprWord platform (ppr lowLabel) - $$ pprWord platform (ppr highLabel) + $$ pprWord platform (pdoc platform lowLabel) + $$ pprWord platform (pdoc platform highLabel) $$ if haveSrc then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = - ppr (mkAsmTempDieLabel label) <> colon + pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev abbrev $$ pprString name $$ pprLabelString platform label $$ pprFlag (externallyVisibleCLabel label) - $$ pprWord platform (ppr label) - $$ pprWord platform (ppr $ mkAsmTempEndLabel label) + $$ pprWord platform (pdoc platform label) + $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel label) $$ pprByte 1 $$ pprByte dW_OP_call_frame_cfa $$ parentValue @@ -194,17 +194,17 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel) + pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel) pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = - ppr (mkAsmTempDieLabel label) <> colon + pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = - ppr (mkAsmTempDieLabel label) <> colon + pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlock $$ pprLabelString platform label - $$ pprWord platform (ppr marker) - $$ pprWord platform (ppr $ mkAsmTempEndLabel marker) + $$ pprWord platform (pdoc platform marker) + $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = pprAbbrev DwAbbrGhcSrcNote $$ pprString' (ftext $ srcSpanFile ss) @@ -240,7 +240,7 @@ pprDwarfARanges platform arngs unitU = initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2 - $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU) + $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) (ptext dwarfInfoLabel) $$ pprByte (fromIntegral wordSize) $$ pprByte 0 @@ -252,10 +252,10 @@ pprDwarfARanges platform arngs unitU = $$ pprWord platform (char '0') pprDwarfARange :: Platform -> DwarfARange -> SDoc -pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length +pprDwarfARange platform arng = pprWord platform (pdoc platform $ dwArngStartLabel arng) $$ pprWord platform length where - length = ppr (dwArngEndLabel arng) - <> char '-' <> ppr (dwArngStartLabel arng) + length = pdoc platform (dwArngEndLabel arng) + <> char '-' <> pdoc platform (dwArngStartLabel arng) -- | Information about unwind instructions for a procedure. This -- corresponds to a "Common Information Entry" (CIE) in DWARF. @@ -286,8 +286,8 @@ data DwarfFrameBlock -- in the block } -instance Outputable DwarfFrameBlock where - ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds +instance OutputableP DwarfFrameBlock where + pdoc platform (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc platform unwinds -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame @@ -296,7 +296,7 @@ pprDwarfFrame :: Platform -> DwarfFrame -> SDoc pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") cieEndLabel = mkAsmTempEndLabel cieLabel - length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel + length = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel spReg = dwarfGlobalRegNo platform Sp retReg = dwarfReturnRegNo platform wordSize = platformWordSizeInBytes platform @@ -309,9 +309,9 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 _ -> empty - in vcat [ ppr cieLabel <> colon + in vcat [ pdoc platform cieLabel <> colon , pprData4' length -- Length of CIE - , ppr cieStartLabel <> colon + , pdoc platform cieStartLabel <> colon , pprData4' (text "-1") -- Common Information Entry marker (-1 = 0xf..f) , pprByte 3 -- CIE version (we require DWARF 3) @@ -339,7 +339,7 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCiePro , pprLEBWord 0 ] $$ wordAlign platform $$ - ppr cieEndLabel <> colon $$ + pdoc platform cieEndLabel <> colon $$ -- Procedure unwind tables vcat (map (pprFrameProc platform cieLabel cieInit) procs) @@ -353,18 +353,18 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) procEnd = mkAsmTempEndLabel procLbl ifInfo str = if hasInfo then text str else empty -- see [Note: Info Offset] - in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon - , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) - , ppr fdeLabel <> colon - , pprData4' (ppr frameLbl <> char '-' <> + in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon + , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel) + , pdoc platform fdeLabel <> colon + , pprData4' (pdoc platform frameLbl <> char '-' <> ptext dwarfFrameLabel) -- Reference to CIE - , pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer - , pprWord platform (ppr procEnd <> char '-' <> - ppr procLbl <> ifInfo "+1") -- Block byte length + , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer + , pprWord platform (pdoc platform procEnd <> char '-' <> + pdoc platform procLbl <> ifInfo "+1") -- Block byte length ] $$ vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ wordAlign platform $$ - ppr fdeEndLabel <> colon + pdoc platform fdeEndLabel <> colon -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small @@ -396,7 +396,7 @@ pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = then (empty, oldUws) else let -- see [Note: Info Offset] needsOffset = firstDecl && hasInfo - lblDoc = ppr lbl <> + lblDoc = pdoc platform lbl <> if needsOffset then text "-1" else empty doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ vcat (map (uncurry $ pprSetUnwind platform) changed) @@ -499,7 +499,7 @@ pprUnwindExpr platform spIsCFA expr pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref - pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (ppr l) + pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pdoc platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 601714cf84..b4f9c98260 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language @@ -59,19 +61,19 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = -- special case for code without info table: pprSectionAlign config (Section Text lbl) $$ (case platformArch platform of - ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl - ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl + ArchPPC_64 ELF_V1 -> pprFunctionDescriptor platform lbl + ArchPPC_64 ELF_V2 -> pprFunctionPrologue platform lbl _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' + then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -80,9 +82,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = then -- See Note [Subsections Via Symbols] in X86/Ppr.hs text "\t.long " - <+> ppr info_lbl + <+> pdoc platform info_lbl <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) + <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl @@ -93,37 +95,37 @@ pprSizeDecl platform lbl then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl else empty where - prettyLbl = ppr lbl + prettyLbl = pdoc platform lbl codeLbl | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl | otherwise = prettyLbl -pprFunctionDescriptor :: CLabel -> SDoc -pprFunctionDescriptor lab = pprGloblDecl lab +pprFunctionDescriptor :: Platform -> CLabel -> SDoc +pprFunctionDescriptor platform lab = pprGloblDecl platform lab $$ text "\t.section \".opd\", \"aw\"" $$ text "\t.align 3" - $$ ppr lab <> char ':' + $$ pdoc platform lab <> char ':' $$ text "\t.quad ." - <> ppr lab + <> pdoc platform lab <> text ",.TOC.@tocbase,0" $$ text "\t.previous" $$ text "\t.type" - <+> ppr lab + <+> pdoc platform lab <> text ", @function" - $$ char '.' <> ppr lab <> char ':' + $$ char '.' <> pdoc platform lab <> char ':' -pprFunctionPrologue :: CLabel ->SDoc -pprFunctionPrologue lab = pprGloblDecl lab +pprFunctionPrologue :: Platform -> CLabel ->SDoc +pprFunctionPrologue platform lab = pprGloblDecl platform lab $$ text ".type " - <> ppr lab + <> pdoc platform lab <> text ", @function" - $$ ppr lab <> char ':' + $$ pdoc platform lab <> char ':' $$ text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha" $$ text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> ppr lab - <> text ",.-" <> ppr lab + $$ text "\t.localentry\t" <> pdoc platform lab + <> text ",.-" <> pdoc platform lab pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc @@ -132,7 +134,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' else empty ) where @@ -149,15 +151,15 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') + = pprGloblDecl platform alias + $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc @@ -167,23 +169,23 @@ pprData platform d = case d of CmmUninitialised bytes -> text ".space " <> int bytes CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl + | otherwise = text ".globl " <> pdoc platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> - ppr lbl <> text ", @object" + pdoc platform lbl <> text ", @object" else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = - pprGloblDecl lbl + pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (ppr lbl <> char ':') + $$ (pdoc platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' @@ -230,57 +232,42 @@ pprCond c GU -> sLit "gt"; LEU -> sLit "le"; }) -pprImm :: Imm -> SDoc - -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s -pprImm (ImmFloat f) = float $ fromRational f -pprImm (ImmDouble d) = double $ fromRational d - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - -pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i))) -pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16)) - where - lo16 = fromInteger (i .&. 0xffff) :: Int16 - -pprImm (LO i) - = pprImm i <> text "@l" - -pprImm (HI i) - = pprImm i <> text "@h" - -pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i))) -pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16) - where - ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 - hi16 = (i `shiftR` 16) - lo16 = i .&. 0xffff - -pprImm (HA i) - = pprImm i <> text "@ha" - -pprImm (HIGHERA i) - = pprImm i <> text "@highera" - -pprImm (HIGHESTA i) - = pprImm i <> text "@highesta" - - -pprAddr :: AddrMode -> SDoc -pprAddr (AddrRegReg r1 r2) - = pprReg r1 <> char ',' <+> pprReg r2 -pprAddr (AddrRegImm r1 (ImmInt i)) - = hcat [ int i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 (ImmInteger i)) - = hcat [ integer i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 imm) - = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] +pprImm :: Platform -> Imm -> SDoc +pprImm platform = \case + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> pdoc platform l + ImmIndex l i -> pdoc platform l <> char '+' <> int i + ImmLit s -> s + ImmFloat f -> float $ fromRational f + ImmDouble d -> double $ fromRational d + ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b + ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen + LO (ImmInt i) -> pprImm platform (LO (ImmInteger (toInteger i))) + LO (ImmInteger i) -> pprImm platform (ImmInteger (toInteger lo16)) + where + lo16 = fromInteger (i .&. 0xffff) :: Int16 + + LO i -> pprImm platform i <> text "@l" + HI i -> pprImm platform i <> text "@h" + HA (ImmInt i) -> pprImm platform (HA (ImmInteger (toInteger i))) + HA (ImmInteger i) -> pprImm platform (ImmInteger ha16) + where + ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 + hi16 = (i `shiftR` 16) + lo16 = i .&. 0xffff + + HA i -> pprImm platform i <> text "@ha" + HIGHERA i -> pprImm platform i <> text "@highera" + HIGHESTA i -> pprImm platform i <> text "@highesta" + + +pprAddr :: Platform -> AddrMode -> SDoc +pprAddr platform = \case + AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2 + AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 (ImmInteger i) -> hcat [ integer i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] pprSectionAlign :: NCGConfig -> Section -> SDoc @@ -321,11 +308,11 @@ pprDataItem platform lit imm = litToImm lit archPPC_64 = not $ target32Bit platform - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] ppr_item II64 _ - | archPPC_64 = [text "\t.quad\t" <> pprImm imm] + | archPPC_64 = [text "\t.quad\t" <> pprImm platform imm] ppr_item II64 (CmmInt x _) | not archPPC_64 = @@ -336,8 +323,8 @@ pprDataItem platform lit <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm] - ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm] + ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm] + ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] ppr_item _ _ = panic "PPC.Ppr.pprDataItem: no match" @@ -401,7 +388,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] LDFAR fmt reg (AddrRegImm source off) @@ -423,7 +410,7 @@ pprInstr platform instr = case instr of text "arx\t", pprReg reg1, text ", ", - pprAddr addr + pprAddr platform addr ] LA fmt reg addr @@ -443,7 +430,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] ST fmt reg addr @@ -456,7 +443,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] STFAR fmt reg (AddrRegImm source off) @@ -478,7 +465,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] STC fmt reg1 addr @@ -491,7 +478,7 @@ pprInstr platform instr = case instr of text "cx.\t", pprReg reg1, text ", ", - pprAddr addr + pprAddr platform addr ] LIS reg imm @@ -501,7 +488,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprImm imm + pprImm platform imm ] LI reg imm @@ -511,7 +498,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprImm imm + pprImm platform imm ] MR reg1 reg2 @@ -534,7 +521,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -552,7 +539,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -570,7 +557,7 @@ pprInstr platform instr = case instr of pprCond cond, pprPrediction prediction, char '\t', - ppr lbl + pdoc platform lbl ] where lbl = mkLocalBlockLabel (getUnique blockid) pprPrediction p = case p of @@ -588,7 +575,7 @@ pprInstr platform instr = case instr of ], hcat [ text "\tb\t", - ppr lbl + pdoc platform lbl ] ] where lbl = mkLocalBlockLabel (getUnique blockid) @@ -605,7 +592,7 @@ pprInstr platform instr = case instr of char '\t', text "b", char '\t', - ppr lbl + pdoc platform lbl ] MTCTR reg @@ -636,12 +623,12 @@ pprInstr platform instr = case instr of -- they'd technically be more like 'ForeignLabel's. hcat [ text "\tbl\t.", - ppr lbl + pdoc platform lbl ] _ -> hcat [ text "\tbl\t", - ppr lbl + pdoc platform lbl ] BCTRL _ @@ -651,7 +638,7 @@ pprInstr platform instr = case instr of ] ADD reg1 reg2 ri - -> pprLogic (sLit "add") reg1 reg2 ri + -> pprLogic platform (sLit "add") reg1 reg2 ri ADDIS reg1 reg2 imm -> hcat [ @@ -662,26 +649,26 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] ADDO reg1 reg2 reg3 - -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3) ADDC reg1 reg2 reg3 - -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) ADDE reg1 reg2 reg3 - -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3) ADDZE reg1 reg2 -> pprUnary (sLit "addze") reg1 reg2 SUBF reg1 reg2 reg3 - -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3) SUBFO reg1 reg2 reg3 - -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri -> hcat [ @@ -695,14 +682,14 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] SUBFE reg1 reg2 reg3 - -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3) MULL fmt reg1 reg2 ri - -> pprMul fmt reg1 reg2 ri + -> pprMul platform fmt reg1 reg2 ri MULLO fmt reg1 reg2 reg3 -> hcat [ @@ -777,23 +764,23 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] AND reg1 reg2 ri - -> pprLogic (sLit "and") reg1 reg2 ri + -> pprLogic platform (sLit "and") reg1 reg2 ri ANDC reg1 reg2 reg3 - -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3) NAND reg1 reg2 reg3 - -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3) OR reg1 reg2 ri - -> pprLogic (sLit "or") reg1 reg2 ri + -> pprLogic platform (sLit "or") reg1 reg2 ri XOR reg1 reg2 ri - -> pprLogic (sLit "xor") reg1 reg2 ri + -> pprLogic platform (sLit "xor") reg1 reg2 ri ORIS reg1 reg2 imm -> hcat [ @@ -804,7 +791,7 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] XORIS reg1 reg2 imm @@ -816,7 +803,7 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] EXTS fmt reg1 reg2 @@ -875,21 +862,21 @@ pprInstr platform instr = case instr of II32 -> "slw" II64 -> "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SR fmt reg1 reg2 ri -> let op = case fmt of II32 -> "srw" II64 -> "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SRA fmt reg1 reg2 ri -> let op = case fmt of II32 -> "sraw" II64 -> "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me -> hcat [ @@ -1019,8 +1006,8 @@ pprInstr platform instr = case instr of NOP -> text "\tnop" -pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc -pprLogic op reg1 reg2 ri = hcat [ +pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc +pprLogic platform op reg1 reg2 ri = hcat [ char '\t', ptext op, case ri of @@ -1031,12 +1018,12 @@ pprLogic op reg1 reg2 ri = hcat [ text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] -pprMul :: Format -> Reg -> Reg -> RI -> SDoc -pprMul fmt reg1 reg2 ri = hcat [ +pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc +pprMul platform fmt reg1 reg2 ri = hcat [ char '\t', text "mull", case ri of @@ -1050,7 +1037,7 @@ pprMul fmt reg1 reg2 ri = hcat [ text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] @@ -1096,9 +1083,9 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [ pprReg reg3 ] -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r +pprRI :: Platform -> RI -> SDoc +pprRI _ (RIReg r) = pprReg r +pprRI platform (RIImm r) = pprImm platform r pprFFormat :: Format -> SDoc diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index 085c2d8867..da99a0db07 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -196,7 +196,7 @@ pprGNUSectionHeader config sep t suffix = platform = ncgPlatform config splitSections = ncgSplitSections config subsection - | splitSections = sep <> ppr suffix + | splitSections = sep <> pdoc platform suffix | otherwise = empty header = case t of Text -> sLit ".text" diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs index f31e84a5ff..0207487f20 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -46,7 +46,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable statics, Instruction instr) + :: (OutputableP statics, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots. @@ -91,7 +91,7 @@ regAlloc config regsFree slotsFree slotsCount code cfg regAlloc_spin :: forall instr statics. (Instruction instr, - Outputable statics) + OutputableP statics) => NCGConfig -> Int -- ^ Number of solver iterations we've already performed. -> Color.Triv VirtualReg RegClass RealReg @@ -388,7 +388,7 @@ graphAddCoalesce (r1, r2) graph -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable statics, Instruction instr) + :: (OutputableP statics, Instruction instr) => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs index 4e325e8778..0bfba3dbc7 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -113,13 +113,13 @@ data RegAllocStats statics instr deriving (Functor) -instance (Outputable statics, Outputable instr) +instance (OutputableP statics, OutputableP instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pdoc (raPlatform s) (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph @@ -134,7 +134,7 @@ instance (Outputable statics, Outputable instr) text "# Spill" $$ text "# Code with liveness information." - $$ ppr (raCode s) + $$ pdoc (raPlatform s) (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -148,14 +148,14 @@ instance (Outputable statics, Outputable instr) $$ text "" $$ text "# Code with spills inserted." - $$ ppr (raSpilled s) + $$ pdoc (raPlatform s) (raSpilled s) ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ ppr (raCode s) + $$ pdoc (raPlatform s) (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." @@ -174,19 +174,19 @@ instance (Outputable statics, Outputable instr) else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pdoc (raPlatform s) (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pdoc (raPlatform s) (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pdoc (raPlatform s) (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pdoc (raPlatform s) (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index 09db54fa76..3c2603b507 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -249,15 +249,19 @@ instance Outputable instr | otherwise = name <> (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) -instance Outputable LiveInfo where - ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) - = (ppr mb_static) +instance OutputableP instr => OutputableP (LiveInstr instr) where + pdoc platform i = ppr (fmap (pdoc platform) i) + +instance OutputableP LiveInfo where + pdoc platform (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) + = (pdoc platform mb_static) $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + -- | map a function across all the basic blocks in this code -- mapBlockTop @@ -503,7 +507,7 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive - :: (Outputable statics, Instruction instr) + :: (OutputableP statics, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr @@ -511,7 +515,7 @@ stripLive stripLive config live = stripCmm live - where stripCmm :: (Outputable statics, Instruction instr) + where stripCmm :: (OutputableP statics, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) @@ -532,14 +536,13 @@ stripLive config live -- | Pretty-print a `LiveCmmDecl` -pprLiveCmmDecl :: (Outputable statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc -pprLiveCmmDecl platform d = ppr (mapLiveCmmDecl (pprInstr platform) d) +pprLiveCmmDecl :: (OutputableP statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc +pprLiveCmmDecl platform d = pdoc platform (mapLiveCmmDecl (pprInstr platform) d) -- | Map over instruction type in `LiveCmmDecl` mapLiveCmmDecl - :: Outputable statics - => (instr -> b) + :: (instr -> b) -> LiveCmmDecl statics instr -> LiveCmmDecl statics b mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc diff --git a/compiler/GHC/CmmToAsm/SPARC.hs b/compiler/GHC/CmmToAsm/SPARC.hs index fe6c824a09..7d9a671932 100644 --- a/compiler/GHC/CmmToAsm/SPARC.hs +++ b/compiler/GHC/CmmToAsm/SPARC.hs @@ -68,7 +68,7 @@ instance Instruction SPARC.Instr where mkRegRegMoveInstr = SPARC.mkRegRegMoveInstr takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr mkJumpInstr = SPARC.mkJumpInstr - pprInstr = const SPARC.pprInstr + pprInstr = SPARC.pprInstr mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index 82da39d893..13a9ef4f9e 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -90,6 +90,7 @@ basicBlockCodeGen block = do let (_, nodes, tail) = blockSplit block id = entryLabel block stmts = blockToList nodes + platform <- getPlatform mid_instrs <- stmtsToInstrs stmts tail_instrs <- stmtToInstrs tail let instrs = mid_instrs `appOL` tail_instrs @@ -108,7 +109,7 @@ basicBlockCodeGen block = do -- do intra-block sanity checking blocksChecked - = map (checkBlock block) + = map (checkBlock platform block) $ BasicBlock id top : other_blocks return (blocksChecked, statics) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs index 42d71a022c..3ddc23a568 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs @@ -56,9 +56,13 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) + _ -> do + platform <- getPlatform + pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y])) -getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) +getCondCode other = do + platform <- getPlatform + pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs index ac5ff79579..f4c1f6db88 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -209,4 +209,6 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (ppr expr) + = do + platform <- getPlatform + pprPanic "iselExpr64(sparc)" (pdoc platform expr) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs index 4bbb3e3823..2284c4cb81 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs @@ -7,6 +7,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Sanity ( where import GHC.Prelude +import GHC.Platform import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances @@ -20,11 +21,12 @@ import GHC.Utils.Panic -- | Enforce intra-block invariants. -- -checkBlock :: CmmBlock +checkBlock :: Platform + -> CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -32,9 +34,9 @@ checkBlock cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pdoc platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pdoc platform block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 1c4e9f51b7..88444cce89 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -77,7 +78,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = Just (CmmStaticsRaw info_lbl _) -> (if platformHasSubsectionsViaSymbols platform then pprSectionAlign config dspSection $$ - ppr (mkDeadStripPreventer info_lbl) <> char ':' + pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock platform top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -86,9 +87,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = then -- See Note [Subsections Via Symbols] in X86/Ppr.hs text "\t.long " - <+> ppr info_lbl + <+> pdoc platform info_lbl <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) + <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) dspSection :: Section @@ -99,7 +100,7 @@ pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SD pprBasicBlock platform info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel platform (blockLbl blockid) $$ - vcat (map pprInstr instrs) + vcat (map (pprInstr platform) instrs) where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty @@ -111,15 +112,15 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs) pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') + = pprGloblDecl platform alias + $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc @@ -129,28 +130,28 @@ pprData platform d = case d of CmmUninitialised bytes -> text ".skip " <> int bytes CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".global " <> ppr lbl + | otherwise = text ".global " <> pdoc platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", @object") + then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object") else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = - pprGloblDecl lbl + pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (ppr lbl <> char ':') + $$ (pdoc platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = pprInstr instr +instance OutputableP Instr where + pdoc = pprInstr -- | Pretty print a register. @@ -273,8 +274,8 @@ pprCond c -- | Pretty print an address mode. -pprAddr :: AddrMode -> SDoc -pprAddr am +pprAddr :: Platform -> AddrMode -> SDoc +pprAddr platform am = case am of AddrRegReg r1 (RegReal (RealRegSingle 0)) -> pprReg r1 @@ -297,30 +298,30 @@ pprAddr am pp_sign = if i > 0 then char '+' else empty AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm imm ] + -> hcat [ pprReg r1, char '+', pprImm platform imm ] -- | Pretty print an immediate value. -pprImm :: Imm -> SDoc -pprImm imm +pprImm :: Platform -> Imm -> SDoc +pprImm platform imm = case imm of ImmInt i -> int i ImmInteger i -> integer i - ImmCLbl l -> ppr l - ImmIndex l i -> ppr l <> char '+' <> int i + ImmCLbl l -> pdoc platform l + ImmIndex l i -> pdoc platform l <> char '+' <> int i ImmLit s -> s ImmConstantSum a b - -> pprImm a <> char '+' <> pprImm b + -> pprImm platform a <> char '+' <> pprImm platform b ImmConstantDiff a b - -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen + -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen LO i - -> hcat [ text "%lo(", pprImm i, rparen ] + -> hcat [ text "%lo(", pprImm platform i, rparen ] HI i - -> hcat [ text "%hi(", pprImm i, rparen ] + -> hcat [ text "%hi(", pprImm platform i, rparen ] -- these should have been converted to bytes and placed -- in the data section. @@ -360,19 +361,19 @@ pprDataItem platform lit where imm = litToImm lit - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] - ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" floatToBytes :: Float -> [Int] @@ -393,202 +394,195 @@ castFloatToWord8Array = U.castSTUArray -- | Pretty print an instruction. -pprInstr :: Instr -> SDoc +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform = \case + COMMENT _ -> empty -- nuke comments. + DELTA d -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) --- nuke comments. -pprInstr (COMMENT _) - = empty + -- Newblocks and LData should have been slurped out before producing the .s file. + NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK" + LDATA _ _ -> panic "PprMach.pprInstr: LDATA" -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - --- Newblocks and LData should have been slurped out before producing the .s file. -pprInstr (NEWBLOCK _) - = panic "X86.Ppr.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - --- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand -pprInstr (LD FF64 _ reg) + -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand + LD FF64 _ reg | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" + -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" -pprInstr (LD format addr reg) - = hcat [ + LD format addr reg + -> hcat [ text "\tld", pprFormat format, char '\t', lbrack, - pprAddr addr, + pprAddr platform addr, pp_rbracket_comma, pprReg reg ] --- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand -pprInstr (ST FF64 reg _) + -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand + ST FF64 reg _ | RegReal (RealRegSingle{}) <- reg - = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" + -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" --- no distinction is made between signed and unsigned bytes on stores for the --- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), --- so we call a special-purpose pprFormat for ST.. -pprInstr (ST format reg addr) - = hcat [ + -- no distinction is made between signed and unsigned bytes on stores for the + -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), + -- so we call a special-purpose pprFormat for ST.. + ST format reg addr + -> hcat [ text "\tst", pprStFormat format, char '\t', pprReg reg, pp_comma_lbracket, - pprAddr addr, + pprAddr platform addr, rbrack ] -pprInstr (ADD x cc reg1 ri reg2) + ADD x cc reg1 ri reg2 | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] + -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise - = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 + -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 -pprInstr (SUB x cc reg1 ri reg2) + SUB x cc reg1 ri reg2 | not x && cc && reg2 == g0 - = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ] + -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ] | not x && not cc && riZero ri - = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] + -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise - = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 + -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 -pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 + AND b reg1 ri reg2 -> pprRegRIReg platform (sLit "and") b reg1 ri reg2 -pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 + ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2 -pprInstr (OR b reg1 ri reg2) + OR b reg1 ri reg2 | not b && reg1 == g0 - = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ] - in case ri of + -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ] + in case ri of RIReg rrr | rrr == reg2 -> empty _ -> doit | otherwise - = pprRegRIReg (sLit "or") b reg1 ri reg2 + -> pprRegRIReg platform (sLit "or") b reg1 ri reg2 -pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 + ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2 -pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 -pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 + XOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor") b reg1 ri reg2 + XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2 -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 + SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2 + SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2 + SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2 -pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd -pprInstr (WRY reg1 reg2) - = text "\twr\t" + RDY rd -> text "\trd\t%y," <> pprReg rd + WRY reg1 reg2 + -> text "\twr\t" <> pprReg reg1 <> char ',' <> pprReg reg2 <> char ',' <> text "%y" -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 -pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 -pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 -pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 - -pprInstr (SETHI imm reg) - = hcat [ - text "\tsethi\t", - pprImm imm, - comma, - pprReg reg - ] - -pprInstr NOP - = text "\tnop" - -pprInstr (FABS format reg1 reg2) - = pprFormatRegReg (sLit "fabs") format reg1 reg2 - -pprInstr (FADD format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 - -pprInstr (FCMP e format reg1 reg2) - = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") - format reg1 reg2 - -pprInstr (FDIV format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 - -pprInstr (FMOV format reg1 reg2) - = pprFormatRegReg (sLit "fmov") format reg1 reg2 - -pprInstr (FMUL format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 - -pprInstr (FNEG format reg1 reg2) - = pprFormatRegReg (sLit "fneg") format reg1 reg2 - -pprInstr (FSQRT format reg1 reg2) - = pprFormatRegReg (sLit "fsqrt") format reg1 reg2 - -pprInstr (FSUB format reg1 reg2 reg3) - = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 - -pprInstr (FxTOy format1 format2 reg1 reg2) - = hcat [ - text "\tf", - ptext - (case format1 of - II32 -> sLit "ito" - FF32 -> sLit "sto" - FF64 -> sLit "dto" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - ptext - (case format2 of - II32 -> sLit "i\t" - II64 -> sLit "x\t" - FF32 -> sLit "s\t" - FF64 -> sLit "d\t" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - pprReg reg1, comma, pprReg reg2 - ] - - -pprInstr (BI cond b blockid) - = hcat [ - text "\tb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (blockLbl blockid) - ] - -pprInstr (BF cond b blockid) - = hcat [ - text "\tfb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - ppr (blockLbl blockid) - ] - -pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr -pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) - -pprInstr (CALL (Left imm) n _) - = hcat [ text "\tcall\t", pprImm imm, comma, int n ] - -pprInstr (CALL (Right reg) n _) - = hcat [ text "\tcall\t", pprReg reg, comma, int n ] + SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul") b reg1 ri reg2 + UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul") b reg1 ri reg2 + SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2 + UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv") b reg1 ri reg2 + + SETHI imm reg + -> hcat [ + text "\tsethi\t", + pprImm platform imm, + comma, + pprReg reg + ] + + NOP -> text "\tnop" + + FABS format reg1 reg2 + -> pprFormatRegReg (sLit "fabs") format reg1 reg2 + + FADD format reg1 reg2 reg3 + -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 + + FCMP e format reg1 reg2 + -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp") + format reg1 reg2 + + FDIV format reg1 reg2 reg3 + -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 + + FMOV format reg1 reg2 + -> pprFormatRegReg (sLit "fmov") format reg1 reg2 + + FMUL format reg1 reg2 reg3 + -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 + + FNEG format reg1 reg2 + -> pprFormatRegReg (sLit "fneg") format reg1 reg2 + + FSQRT format reg1 reg2 + -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2 + + FSUB format reg1 reg2 reg3 + -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 + + FxTOy format1 format2 reg1 reg2 + -> hcat [ + text "\tf", + ptext + (case format1 of + II32 -> sLit "ito" + FF32 -> sLit "sto" + FF64 -> sLit "dto" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + ptext + (case format2 of + II32 -> sLit "i\t" + II64 -> sLit "x\t" + FF32 -> sLit "s\t" + FF64 -> sLit "d\t" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + pprReg reg1, comma, pprReg reg2 + ] + + + BI cond b blockid + -> hcat [ + text "\tb", pprCond cond, + if b then pp_comma_a else empty, + char '\t', + pdoc platform (blockLbl blockid) + ] + + BF cond b blockid + -> hcat [ + text "\tfb", pprCond cond, + if b then pp_comma_a else empty, + char '\t', + pdoc platform (blockLbl blockid) + ] + + JMP addr -> text "\tjmp\t" <> pprAddr platform addr + JMP_TBL op _ _ -> pprInstr platform (JMP op) + + CALL (Left imm) n _ + -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ] + + CALL (Right reg) n _ + -> hcat [ text "\tcall\t", pprReg reg, comma, int n ] -- | Pretty print a RI -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r +pprRI :: Platform -> RI -> SDoc +pprRI platform = \case + RIReg r -> pprReg r + RIImm r -> pprImm platform r -- | Pretty print a two reg instruction. @@ -627,15 +621,15 @@ pprFormatRegRegReg name format reg1 reg2 reg3 -- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc -pprRegRIReg name b reg1 ri reg2 +pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc +pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t', ptext name, if b then text "cc\t" else char '\t', pprReg reg1, comma, - pprRI ri, + pprRI platform ri, comma, pprReg reg2 ] diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 31b111eab6..6a64a88651 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -620,7 +620,9 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do ) iselExpr64 expr - = pprPanic "iselExpr64(i386)" (ppr expr) + = do + platform <- getPlatform + pprPanic "iselExpr64(i386)" (pdoc platform expr) -------------------------------------------------------------------------------- @@ -1178,9 +1180,9 @@ getRegister' platform _ (CmmLit lit) code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) return (Any format code) -getRegister' _ _ other +getRegister' platform _ other | isVecExpr other = needLlvm - | otherwise = pprPanic "getRegister(x86)" (ppr other) + | otherwise = pprPanic "getRegister(x86)" (pdoc platform other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -1576,7 +1578,9 @@ getCondCode (CmmMachOp mop [x, y]) _ -> condIntCode (machOpToCond mop) x y -getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) +getCondCode other = do + platform <- getPlatform + pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other) machOpToCond :: MachOp -> Cond machOpToCond mo = case mo of diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 22a8e66f2f..b9fe4c0260 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -92,14 +93,14 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' + then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -107,9 +108,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] text "\t.long " - <+> ppr info_lbl + <+> pdoc platform info_lbl <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) + <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl @@ -117,7 +118,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl + then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl else empty pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc @@ -126,7 +127,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + then pdoc (ncgPlatform config) (mkAsmTempEndLabel asmLbl) <> char ':' else empty ) where @@ -141,7 +142,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprLabel platform infoLbl $$ c $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel infoLbl) <> char ':' + then pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':' else empty ) -- Make sure the info table has the right .loc for the block @@ -153,15 +154,15 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') + = pprGloblDecl (ncgPlatform config) alias + $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind') pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) @@ -180,10 +181,10 @@ pprData config (CmmUninitialised bytes) pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl + | otherwise = text ".globl " <> pdoc platform lbl pprLabelType' :: Platform -> CLabel -> SDoc pprLabelType' platform lbl = @@ -246,14 +247,14 @@ pprLabelType' platform lbl = pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl + then text ".type " <> pdoc platform lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = - pprGloblDecl lbl + pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (ppr lbl <> char ':') + $$ (pdoc platform lbl <> char ':') pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment @@ -417,24 +418,23 @@ pprCond c ALWAYS -> sLit "mp"}) -pprImm :: Imm -> SDoc -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s -pprImm (ImmFloat f) = float $ fromRational f -pprImm (ImmDouble d) = double $ fromRational d - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen +pprImm :: Platform -> Imm -> SDoc +pprImm platform = \case + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> pdoc platform l + ImmIndex l i -> pdoc platform l <> char '+' <> int i + ImmLit s -> s + ImmFloat f -> float $ fromRational f + ImmDouble d -> double $ fromRational d + ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b + ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen pprAddr :: Platform -> AddrMode -> SDoc -pprAddr _platform (ImmAddr imm off) - = let pp_imm = pprImm imm +pprAddr platform (ImmAddr imm off) + = let pp_imm = pprImm platform imm in if (off == 0) then pp_imm @@ -460,7 +460,7 @@ pprAddr platform (AddrBaseIndex base index displacement) where ppr_disp (ImmInt 0) = empty - ppr_disp imm = pprImm imm + ppr_disp imm = pprImm platform imm -- | Print section header and appropriate alignment for that section. pprSectionAlign :: NCGConfig -> Section -> SDoc @@ -509,12 +509,12 @@ pprDataItem config lit imm = litToImm lit -- These seem to be common: - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.word\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] - ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm] - ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm] + ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm] + ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] ppr_item II64 _ = case platformOS platform of @@ -529,10 +529,10 @@ pprDataItem config lit (fromIntegral (x `shiftR` 32) :: Word32))] _ -> panic "X86.Ppr.ppr_item: no match for II64" | otherwise -> - [text "\t.quad\t" <> pprImm imm] + [text "\t.quad\t" <> pprImm platform imm] _ | target32Bit platform -> - [text "\t.quad\t" <> pprImm imm] + [text "\t.quad\t" <> pprImm platform imm] | otherwise -> -- x86_64: binutils can't handle the R_X86_64_PC64 -- relocation type, which means we can't do @@ -547,10 +547,10 @@ pprDataItem config lit case lit of -- A relative relocation: CmmLabelDiffOff _ _ _ _ -> - [text "\t.long\t" <> pprImm imm, + [text "\t.long\t" <> pprImm platform imm, text "\t.long\t0"] _ -> - [text "\t.quad\t" <> pprImm imm] + [text "\t.quad\t" <> pprImm platform imm] asmComment :: SDoc -> SDoc @@ -571,8 +571,8 @@ pprInstr platform i = case i of -> panic "pprInstr: NEWBLOCK" UNWIND lbl d - -> asmComment (text "\tunwind = " <> ppr d) - $$ ppr lbl <> colon + -> asmComment (text "\tunwind = " <> pdoc platform d) + $$ pdoc platform lbl <> colon LDATA _ _ -> panic "pprInstr: LDATA" @@ -814,14 +814,14 @@ pprInstr platform i = case i of -> pprFormatOpReg (sLit "xchg") format src val JXX cond blockid - -> pprCondInstr (sLit "j") cond (ppr lab) + -> pprCondInstr (sLit "j") cond (pdoc platform lab) where lab = blockLbl blockid JXX_GBL cond imm - -> pprCondInstr (sLit "j") cond (pprImm imm) + -> pprCondInstr (sLit "j") cond (pprImm platform imm) JMP (OpImm imm) _ - -> text "\tjmp " <> pprImm imm + -> text "\tjmp " <> pprImm platform imm JMP op _ -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op @@ -830,7 +830,7 @@ pprInstr platform i = case i of -> pprInstr platform (JMP op []) CALL (Left imm) _ - -> text "\tcall " <> pprImm imm + -> text "\tcall " <> pprImm platform imm CALL (Right reg) _ -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg @@ -929,7 +929,7 @@ pprInstr platform i = case i of pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" pprDollImm :: Imm -> SDoc - pprDollImm i = text "$" <> pprImm i + pprDollImm i = text "$" <> pprImm platform i pprOperand :: Platform -> Format -> Operand -> SDoc @@ -954,7 +954,7 @@ pprInstr platform i = case i of = hcat [ pprMnemonic name format, char '$', - pprImm imm, + pprImm platform imm, comma, pprOperand platform format op1 ] diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index dc7a383d2f..db93ef8df8 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -281,7 +281,7 @@ pprStmt platform stmt = CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi CmmSwitch arg ids -> pprSwitch platform arg ids - _other -> pprPanic "PprC.pprStmt" (ppr stmt) + _other -> pprPanic "PprC.pprStmt" (pdoc platform stmt) type Hinted a = (a, ForeignHint) diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index 22c2eb01df..c9b50c731e 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -164,7 +164,7 @@ cmmLlvmGen cmm@CmmProc{} = do let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" - FormatCMM (pprCmmGroup [fixed_cmm]) + FormatCMM (pprCmmGroup platform [fixed_cmm]) -- generate llvm code from cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 841fa79d33..0e43b64c77 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -16,6 +16,7 @@ where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -260,8 +261,8 @@ outputForeignStubs_help fname doc_str header footer -- module; -- | Generate code to initialise cost centres -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, singleton_CCSs) +profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc +profilingInitCode platform this_mod (local_CCs, singleton_CCSs) = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs @@ -278,22 +279,22 @@ profilingInitCode this_mod (local_CCs, singleton_CCSs) where emit_cc_decl cc = text "extern CostCentre" <+> cc_lbl <> text "[];" - where cc_lbl = ppr (mkCCLabel cc) + where cc_lbl = pdoc platform (mkCCLabel cc) local_cc_list_label = text "local_cc_" <> ppr this_mod emit_cc_list ccs = text "static CostCentre *" <> local_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma + <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi emit_ccs_decl ccs = text "extern CostCentreStack" <+> ccs_lbl <> text "[];" - where ccs_lbl = ppr (mkCCSLabel ccs) + where ccs_lbl = pdoc platform (mkCCSLabel ccs) singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod emit_ccs_list ccs = text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma + <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 90a07d7490..44babeec18 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1417,10 +1417,10 @@ hscGenHardCode hsc_env cgguts location output_filename = do <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let cost_centre_info = - (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + platform = targetPlatform dflags prof_init - | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info + | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info | otherwise = empty foreign_stubs = foreign_stubs0 `appendStubC` prof_init @@ -1446,7 +1446,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let dump a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a) + dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1494,9 +1494,10 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env home_unit = mkHomeUnitFromFlags dflags + platform = targetPlatform dflags cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1513,7 +1514,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" - FormatCMM (ppr cmmgroup) + FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] @@ -1556,6 +1557,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds @@ -1575,7 +1577,7 @@ doCodeGen hsc_env this_mod data_tycons let dump1 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" FormatCMM (ppr a) + "Cmm produced by codegen" FormatCMM (pdoc platform a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream @@ -1591,7 +1593,7 @@ doCodeGen hsc_env this_mod data_tycons dump2 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index f90abbf921..68386a69ae 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -389,7 +389,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds - ; let { spt_init_code = sptModuleInitCode mod spt_entries + ; let { platform = targetPlatform (hsc_dflags hsc_env) + ; spt_init_code = sptModuleInitCode platform mod spt_entries ; add_spt_init_code = case backend dflags of -- If we are compiling for the interpreter we will insert diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index 99320cd7ad..965140e6f2 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -256,9 +256,9 @@ sptCreateStaticBinds hsc_env this_mod binds -- -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. -sptModuleInitCode :: Module -> [SptEntry] -> SDoc -sptModuleInitCode _ [] = Outputable.empty -sptModuleInitCode this_mod entries = vcat +sptModuleInitCode :: Platform -> Module -> [SptEntry] -> SDoc +sptModuleInitCode _ _ [] = Outputable.empty +sptModuleInitCode platform this_mod entries = vcat [ text "static void hs_spt_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));" , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" @@ -266,11 +266,11 @@ sptModuleInitCode this_mod entries = vcat [ text "static StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi $$ text "extern StgPtr " - <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma [ char 'k' <> int i - , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n)) ] ) <> semi diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index cc299e58ca..9fec3472e0 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP, RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -114,9 +116,13 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance Outputable CgLoc where - ppr (CmmLoc e) = text "cmm" <+> ppr e - ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs +instance OutputableP CgLoc where + pdoc = pprCgLoc + +pprCgLoc :: Platform -> CgLoc -> SDoc +pprCgLoc platform = \case + CmmLoc e -> text "cmm" <+> pdoc platform e + LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs type SelfLoopInfo = (Id, BlockId, [LocalReg]) diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 89175caf93..70a9fc8fe7 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -204,7 +204,7 @@ slowCall fun stg_args r <- direct_call "slow_call" NativeNodeCall (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) emitComment $ mkFastString ("slow_call for " ++ - showSDoc dflags (ppr fun) ++ + showSDoc dflags (pdoc platform fun) ++ " with pat " ++ unpackFS rts_fun) return r @@ -291,10 +291,11 @@ direct_call :: String direct_call caller call_conv lbl arity args | debugIsOn && args `lengthLessThan` real_arity -- Too few args = do -- Caller should ensure that there enough args! + platform <- getPlatform pprPanic "direct_call" $ text caller <+> ppr arity <+> - ppr lbl <+> ppr (length args) <+> - ppr (map snd args) <+> ppr (map fst args) + pdoc platform lbl <+> ppr (length args) <+> + pdoc platform (map snd args) <+> ppr (map fst args) | null rest_args -- Precisely the right number of arguments = emitCall (call_conv, NativeReturn) target (nonVArgs args) diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index da68c578fb..059fc19ff7 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -182,9 +182,9 @@ data CgIdInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } -instance Outputable CgIdInfo where - ppr (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> text "-->" <+> ppr loc +instance OutputableP CgIdInfo where + pdoc platform (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> text "-->" <+> pdoc platform loc -- Sequel tells what to do with the result of this expression data Sequel diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 5b9cd98b27..190202efb9 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -364,7 +364,7 @@ emitMultiAssign [] [] = return () emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss = do platform <- getPlatform - ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss ) + ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss ) unscramble platform ([1..] `zip` (regs `zip` rhss)) unscramble :: Platform -> [Vrtx] -> FCode () diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index e89196c1a6..e4408a3084 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -234,6 +234,10 @@ alignmentOf x = case x .&. 7 of instance Outputable Alignment where ppr (Alignment m) = ppr m + +instance OutputableP Alignment where + pdoc _ = ppr + {- ************************************************************************ * * diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 8723f16233..cca43cbbab 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -17,10 +17,10 @@ -- and works over the 'SDoc' type. module GHC.Utils.Outputable ( -- * Type classes - Outputable(..), OutputableBndr(..), + Outputable(..), OutputableBndr(..), OutputableP(..), -- * Pretty printing combinators - SDoc, runSDoc, + SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, @@ -95,6 +95,7 @@ import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) +import GHC.Platform import GHC.Utils.BufHandle (BufHandle) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty @@ -934,6 +935,7 @@ deriving newtype instance Outputable LexicalFastString instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) + instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) @@ -950,6 +952,49 @@ instance Outputable Serialized where instance Outputable Extension where ppr = text . show +-- | Outputable class with an additional Platform value +class OutputableP a where + pdoc :: Platform -> a -> SDoc + pdocPrec :: Rational -> Platform -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + pdoc = pdocPrec 0 + pdocPrec _ = pdoc + +-- | Wrapper for types having a Outputable instance when an OutputableP instance +-- is required. +newtype PDoc a = PDoc a + +instance Outputable a => OutputableP (PDoc a) where + pdoc _ (PDoc a) = ppr a + +instance OutputableP a => OutputableP [a] where + pdoc platform xs = ppr (fmap (pdoc platform) xs) + +instance OutputableP a => OutputableP (Maybe a) where + pdoc platform xs = ppr (fmap (pdoc platform) xs) + +instance (OutputableP a, OutputableP b) => OutputableP (a, b) where + pdoc platform (a,b) = ppr (pdoc platform a, pdoc platform b) + +instance (OutputableP a, OutputableP b, OutputableP c) => OutputableP (a, b, c) where + pdoc platform (a,b,c) = ppr (pdoc platform a, pdoc platform b, pdoc platform c) + + +instance (OutputableP key, OutputableP elt) => OutputableP (M.Map key elt) where + pdoc platform m = ppr $ fmap (\(x,y) -> (pdoc platform x, pdoc platform y)) $ M.toList m + +instance OutputableP a => OutputableP (SCC a) where + pdoc platform scc = ppr (fmap (pdoc platform) scc) + +instance OutputableP SDoc where + pdoc _ x = x + +instance (OutputableP a) => OutputableP (Set a) where + pdoc platform s = braces (fsep (punctuate comma (map (pdoc platform) (Set.toList s)))) + + {- ************************************************************************ * * |