diff options
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)))) + + {- ************************************************************************ * * |