diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-09-14 19:46:45 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-17 20:04:08 -0400 |
commit | e45c85446de7589e17acf5654c2b33f766043eb1 (patch) | |
tree | db36adba8d53eb3b9cc8e6cbfd37d43f7c8445b7 | |
parent | ca48076ae866665913b9c81cbc0c76f0afef7a00 (diff) | |
download | haskell-e45c85446de7589e17acf5654c2b33f766043eb1.tar.gz |
Generalize OutputableP
Add a type parameter for the environment required by OutputableP. It
avoids tying Platform with OutputableP.
-rw-r--r-- | compiler/GHC/Cmm.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Dataflow/Label.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Cmm/DebugBlock.hs | 49 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Info/Build.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Lint.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Ppr.hs | 27 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Ppr/Decl.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Ppr/Expr.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Dwarf/Types.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Reg/Graph.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Reg/Liveness.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/SPARC/Ppr.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Monad.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 41 |
19 files changed, 182 insertions, 111 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index a5b3b35b8b..5c4c619b69 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -4,6 +4,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + module GHC.Cmm ( -- * Cmm top-level datatypes @@ -266,15 +269,15 @@ 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 OutputableP env instr => OutputableP env (ListGraph instr) where + pdoc env g = ppr (fmap (pdoc env) 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) +instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where + pdoc env block = ppr (fmap (pdoc env) block) pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 924991794f..370e727930 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -9,6 +9,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + module GHC.Cmm.CLabel ( CLabel, -- abstract type @@ -1210,7 +1213,7 @@ The info table label and the local block label are both local labels and are not externally visible. -} -instance OutputableP CLabel where +instance OutputableP Platform CLabel where pdoc platform lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) platform lbl) pprCLabel :: Backend -> Platform -> CLabel -> SDoc diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs index e01f301627..148fc15ede 100644 --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -3,6 +3,9 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + module GHC.Cmm.Dataflow.Label ( Label @@ -43,7 +46,7 @@ instance Uniquable Label where instance Outputable Label where ppr label = ppr (getUnique label) -instance OutputableP Label where +instance OutputableP env Label where pdoc _ l = ppr l ----------------------------------------------------------------------------- @@ -131,8 +134,8 @@ 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 OutputableP env a => OutputableP env (LabelMap a) where + pdoc env = pdoc env . mapToList instance TrieMap LabelMap where type Key LabelMap = Label diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 927003b16f..d5410b9b6a 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -1,6 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -72,20 +77,20 @@ data DebugBlock = , dblBlocks :: ![DebugBlock] -- ^ Nested blocks } -instance OutputableP DebugBlock where - pdoc platform blk = +instance OutputableP env CLabel => OutputableP env DebugBlock where + pdoc env blk = (if | dblProcedure blk == dblLabel blk -> text "proc" | dblHasInfoTbl blk -> text "pp-blk" | otherwise -> text "blk") <+> - ppr (dblLabel blk) <+> parens (pdoc platform (dblCLabel blk)) <+> + ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+> (maybe empty ppr (dblSourceTick blk)) <+> (maybe (text "removed") ((text "pos " <>) . ppr) (dblPosition blk)) <+> - (pdoc platform (dblUnwind blk)) $+$ - (if null (dblBlocks blk) then empty else nest 4 (pdoc platform (dblBlocks blk))) + (pdoc env (dblUnwind blk)) $+$ + (if null (dblBlocks blk) then empty else nest 4 (pdoc env (dblBlocks blk))) -- | Intermediate data structure holding debug-relevant context information -- about a block. @@ -490,12 +495,12 @@ LOC this information will end up in is Y. -- | A label associated with an 'UnwindTable' data UnwindPoint = UnwindPoint !CLabel !UnwindTable -instance OutputableP UnwindPoint where - pdoc platform (UnwindPoint lbl uws) = - braces $ pdoc platform lbl <> colon +instance OutputableP env CLabel => OutputableP env UnwindPoint where + pdoc env (UnwindPoint lbl uws) = + braces $ pdoc env lbl <> colon <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) where - pprUw (g, expr) = ppr g <> char '=' <> pdoc platform expr + pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr -- | Maps registers to expressions that yield their "old" values -- further up the stack. Most interesting for the stack pointer @Sp@, @@ -514,19 +519,19 @@ data UnwindExpr = UwConst !Int -- ^ literal value | UwTimes UnwindExpr UnwindExpr deriving (Eq) -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) +instance OutputableP env CLabel => OutputableP env UnwindExpr where + pdocPrec _ _ (UwConst i) = ppr i + pdocPrec _ _ (UwReg g 0) = ppr g + pdocPrec p env (UwReg g x) = pdocPrec p env (UwPlus (UwReg g 0) (UwConst x)) + pdocPrec _ env (UwDeref e) = char '*' <> pdocPrec 3 env e + pdocPrec _ env (UwLabel l) = pdocPrec 3 env l + pdocPrec p env (UwPlus e0 e1) | p <= 0 + = pdocPrec 0 env e0 <> char '+' <> pdocPrec 0 env e1 + pdocPrec p env (UwMinus e0 e1) | p <= 0 + = pdocPrec 1 env e0 <> char '-' <> pdocPrec 1 env e1 + pdocPrec p env (UwTimes e0 e1) | p <= 1 + = pdocPrec 2 env e0 <> char '*' <> pdocPrec 2 env e1 + pdocPrec _ env other = parens (pdocPrec 0 env other) -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 0497f18937..b2078ae462 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -1,6 +1,13 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, ScopedTypeVariables, OverloadedStrings, LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + module GHC.Cmm.Info.Build ( CAFSet, CAFEnv, cafAnal, cafAnalData @@ -455,7 +462,9 @@ non-CAFFY. -- map them to SRTEntry later, which ranges over labels that do exist. -- newtype CAFLabel = CAFLabel CLabel - deriving (Eq,Ord,OutputableP) + deriving (Eq,Ord) + +deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel type CAFSet = Set CAFLabel type CAFEnv = LabelMap CAFSet @@ -466,7 +475,10 @@ 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, OutputableP) + deriving (Eq, Ord) + +deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry + -- --------------------------------------------------------------------- -- CAF analysis @@ -597,12 +609,12 @@ data ModuleSRTInfo = ModuleSRTInfo , moduleSRTMap :: SRTMap } -instance OutputableP ModuleSRTInfo where - pdoc platform ModuleSRTInfo{..} = +instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where + pdoc env ModuleSRTInfo{..} = text "ModuleSRTInfo {" $$ - (nest 4 $ text "dedupSRTs =" <+> pdoc platform dedupSRTs $$ - text "flatSRTs =" <+> pdoc platform flatSRTs $$ - text "moduleSRTMap =" <+> pdoc platform moduleSRTMap) $$ char '}' + (nest 4 $ text "dedupSRTs =" <+> pdoc env dedupSRTs $$ + text "flatSRTs =" <+> pdoc env flatSRTs $$ + text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}' emptySRT :: Module -> ModuleSRTInfo emptySRT mod = @@ -635,10 +647,10 @@ data SomeLabel | DeclLabel CLabel deriving (Eq, Ord) -instance OutputableP SomeLabel where - pdoc platform = \case - BlockLabel l -> text "b:" <+> pdoc platform l - DeclLabel l -> text "s:" <+> pdoc platform l +instance OutputableP env CLabel => OutputableP env SomeLabel where + pdoc env = \case + BlockLabel l -> text "b:" <+> pdoc env l + DeclLabel l -> text "s:" <+> pdoc env l getBlockLabel :: SomeLabel -> Maybe Label getBlockLabel (BlockLabel l) = Just l diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index da9ff30d85..2fd19ec507 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -37,14 +37,14 @@ import Control.Monad (ap, unless) -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (OutputableP d, OutputableP h) +cmmLint :: (OutputableP Platform d, OutputableP Platform 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 :: OutputableP a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint :: OutputableP Platform 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:", @@ -224,7 +224,7 @@ 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, OutputableP a) +mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a) => SDoc -> a -> CmmLint () mayNotMentionCallerSavedRegs what thing = do platform <- getPlatform diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs index b791b78d70..479dee7430 100644 --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} ---------------------------------------------------------------------------- @@ -63,11 +68,11 @@ import GHC.Cmm.Dataflow.Graph instance Outputable CmmStackInfo where ppr = pprStackInfo -instance OutputableP CmmTopInfo where +instance OutputableP Platform CmmTopInfo where pdoc = pprTopInfo -instance OutputableP (CmmNode e x) where +instance OutputableP Platform (CmmNode e x) where pdoc = pprNode instance Outputable Convention where @@ -76,25 +81,25 @@ instance Outputable Convention where instance Outputable ForeignConvention where ppr = pprForeignConvention -instance OutputableP ForeignTarget where +instance OutputableP Platform ForeignTarget where pdoc = pprForeignTarget instance Outputable CmmReturnInfo where ppr = pprReturnInfo -instance OutputableP (Block CmmNode C C) where +instance OutputableP Platform (Block CmmNode C C) where pdoc = pprBlock -instance OutputableP (Block CmmNode C O) where +instance OutputableP Platform (Block CmmNode C O) where pdoc = pprBlock -instance OutputableP (Block CmmNode O C) where +instance OutputableP Platform (Block CmmNode O C) where pdoc = pprBlock -instance OutputableP (Block CmmNode O O) where +instance OutputableP Platform (Block CmmNode O O) where pdoc = pprBlock -instance OutputableP (Graph CmmNode e x) where +instance OutputableP Platform (Graph CmmNode e x) where pdoc = pprGraph -instance OutputableP CmmGraph where +instance OutputableP Platform CmmGraph where pdoc = pprCmmGraph ---------------------------------------------------------- @@ -130,7 +135,7 @@ pprGraph platform = \case text "{" $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: OutputableP (Block CmmNode e x) + where pprMaybeO :: OutputableP Platform (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty pprMaybeO (JustO block) = pdoc platform block diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index b65cb9bd0b..c2e46c6e16 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -1,4 +1,8 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + ---------------------------------------------------------------------------- -- @@ -54,7 +58,7 @@ import Data.List import qualified Data.ByteString as BS -pprCmms :: (OutputableP info, OutputableP g) +pprCmms :: (OutputableP Platform info, OutputableP Platform g) => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms)) where @@ -62,23 +66,23 @@ pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc ----------------------------------------------------------------------------- -instance (OutputableP d, OutputableP info, OutputableP i) - => OutputableP (GenCmmDecl d info i) where +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => OutputableP Platform (GenCmmDecl d info i) where pdoc = pprTop -instance OutputableP (GenCmmStatics a) where +instance OutputableP Platform (GenCmmStatics a) where pdoc = pprStatics -instance OutputableP CmmStatic where +instance OutputableP Platform CmmStatic where pdoc = pprStatic -instance OutputableP CmmInfoTable where +instance OutputableP Platform CmmInfoTable where pdoc = pprInfoTable ----------------------------------------------------------------------------- -pprCmmGroup :: (OutputableP d, OutputableP info, OutputableP g) +pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) => Platform -> GenCmmGroup d info g -> SDoc pprCmmGroup platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops @@ -86,7 +90,7 @@ pprCmmGroup platform tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (OutputableP d, OutputableP info, OutputableP i) +pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) => Platform -> GenCmmDecl d info i -> SDoc pprTop platform (CmmProc info lbl live graph) diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs index 5b1d01b00a..c656c98522 100644 --- a/compiler/GHC/Cmm/Ppr/Expr.hs +++ b/compiler/GHC/Cmm/Ppr/Expr.hs @@ -32,6 +32,9 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Cmm.Ppr.Expr @@ -53,13 +56,13 @@ import Numeric ( fromRat ) ----------------------------------------------------------------------------- -instance OutputableP CmmExpr where +instance OutputableP Platform CmmExpr where pdoc = pprExpr instance Outputable CmmReg where ppr e = pprReg e -instance OutputableP CmmLit where +instance OutputableP Platform CmmLit where pdoc = pprLit instance Outputable LocalReg where @@ -71,7 +74,7 @@ instance Outputable Area where instance Outputable GlobalReg where ppr e = pprGlobalReg e -instance OutputableP GlobalReg where +instance OutputableP env GlobalReg where pdoc _ = ppr -- -------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 108df2b600..6c142ed9d8 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -7,6 +7,10 @@ {-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} @@ -150,7 +154,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' :: ( OutputableP statics, Outputable jumpDest, Instruction instr) + nCG' :: ( OutputableP Platform 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 +218,7 @@ unwinding table). See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} -nativeCodeGen' :: (OutputableP statics, Outputable jumpDest, Instruction instr) +nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -293,7 +297,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" FormatText -cmmNativeGenStream :: (OutputableP statics, Outputable jumpDest, Instruction instr) +cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -349,7 +353,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. - (OutputableP statics, Outputable jumpDest, Instruction instr) + (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation @@ -427,7 +431,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, OutputableP statics, Outputable jumpDest) + :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => DynFlags -> Module -> ModLocation -> NcgImpl statics instr jumpDest diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index e0d2549dc9..c4748b00cd 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + module GHC.CmmToAsm.Dwarf.Types ( -- * Dwarf information DwarfInfo(..) @@ -286,8 +291,8 @@ data DwarfFrameBlock -- in the block } -instance OutputableP DwarfFrameBlock where - pdoc platform (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc platform unwinds +instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where + pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs index 0207487f20..b8b1e48efb 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + -- | Graph coloring register allocator. module GHC.CmmToAsm.Reg.Graph ( @@ -46,7 +50,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (OutputableP statics, Instruction instr) + :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots. @@ -91,7 +95,7 @@ regAlloc config regsFree slotsFree slotsCount code cfg regAlloc_spin :: forall instr statics. (Instruction instr, - OutputableP statics) + OutputableP Platform statics) => NCGConfig -> Int -- ^ Number of solver iterations we've already performed. -> Color.Triv VirtualReg RegClass RealReg @@ -388,7 +392,7 @@ graphAddCoalesce (r1, r2) graph -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (OutputableP statics, Instruction instr) + :: (OutputableP Platform 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 0bfba3dbc7..534c6f0bbb 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -1,4 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -113,7 +117,7 @@ data RegAllocStats statics instr deriving (Functor) -instance (OutputableP statics, OutputableP instr) +instance (OutputableP Platform statics, OutputableP Platform instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index 3c2603b507..c19a8085a8 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -3,6 +3,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -249,12 +252,12 @@ instance Outputable instr | otherwise = name <> (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) -instance OutputableP instr => OutputableP (LiveInstr instr) where - pdoc platform i = ppr (fmap (pdoc platform) i) +instance OutputableP env instr => OutputableP env (LiveInstr instr) where + pdoc env i = ppr (fmap (pdoc env) i) -instance OutputableP LiveInfo where - pdoc platform (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) - = (pdoc platform mb_static) +instance OutputableP Platform LiveInfo where + pdoc env (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) + = (pdoc env mb_static) $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -507,7 +510,7 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive - :: (OutputableP statics, Instruction instr) + :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr @@ -515,7 +518,7 @@ stripLive stripLive config live = stripCmm live - where stripCmm :: (OutputableP statics, Instruction instr) + where stripCmm :: (OutputableP Platform 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) @@ -536,7 +539,7 @@ stripLive config live -- | Pretty-print a `LiveCmmDecl` -pprLiveCmmDecl :: (OutputableP statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc +pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc pprLiveCmmDecl platform d = pdoc platform (mapLiveCmmDecl (pprInstr platform) d) diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 88444cce89..20b3beea35 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- @@ -150,7 +153,7 @@ pprLabel platform lbl = -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance OutputableP Instr where +instance OutputableP Platform Instr where pdoc = pprInstr diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 9fec3472e0..cacb783a16 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- @@ -116,7 +119,7 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance OutputableP CgLoc where +instance OutputableP Platform CgLoc where pdoc = pprCgLoc pprCgLoc :: Platform -> CgLoc -> SDoc diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 059fc19ff7..556c1c6ffd 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- @@ -182,9 +185,9 @@ data CgIdInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } -instance OutputableP CgIdInfo where - pdoc platform (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> text "-->" <+> pdoc platform loc +instance OutputableP Platform CgIdInfo where + pdoc env (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> text "-->" <+> pdoc env loc -- Sequel tells what to do with the result of this expression data Sequel diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index e4408a3084..34ac178efc 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -15,6 +15,9 @@ types that -} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Types.Basic ( @@ -235,7 +238,7 @@ alignmentOf x = case x .&. 7 of instance Outputable Alignment where ppr (Alignment m) = ppr m -instance OutputableP Alignment where +instance OutputableP env Alignment where pdoc _ = ppr {- diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index cca43cbbab..736711ccb4 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -3,6 +3,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {- (c) The University of Glasgow 2006-2012 @@ -95,7 +97,6 @@ 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 @@ -953,9 +954,9 @@ 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 +class OutputableP env a where + pdoc :: env -> a -> SDoc + pdocPrec :: Rational -> env -> a -> SDoc -- 0 binds least tightly -- We use Rational because there is always a -- Rational between any other two Rationals @@ -966,33 +967,33 @@ class OutputableP a where -- is required. newtype PDoc a = PDoc a -instance Outputable a => OutputableP (PDoc a) where +instance Outputable a => OutputableP env (PDoc a) where pdoc _ (PDoc a) = ppr a -instance OutputableP a => OutputableP [a] where - pdoc platform xs = ppr (fmap (pdoc platform) xs) +instance OutputableP env a => OutputableP env [a] where + pdoc env xs = ppr (fmap (pdoc env) xs) -instance OutputableP a => OutputableP (Maybe a) where - pdoc platform xs = ppr (fmap (pdoc platform) xs) +instance OutputableP env a => OutputableP env (Maybe a) where + pdoc env xs = ppr (fmap (pdoc env) xs) -instance (OutputableP a, OutputableP b) => OutputableP (a, b) where - pdoc platform (a,b) = ppr (pdoc platform a, pdoc platform b) +instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where + pdoc env (a,b) = ppr (pdoc env a, pdoc env 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 env a, OutputableP env b, OutputableP env c) => OutputableP env (a, b, c) where + pdoc env (a,b,c) = ppr (pdoc env a, pdoc env b, pdoc env 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 env key, OutputableP env elt) => OutputableP env (M.Map key elt) where + pdoc env m = ppr $ fmap (\(x,y) -> (pdoc env x, pdoc env y)) $ M.toList m -instance OutputableP a => OutputableP (SCC a) where - pdoc platform scc = ppr (fmap (pdoc platform) scc) +instance OutputableP env a => OutputableP env (SCC a) where + pdoc env scc = ppr (fmap (pdoc env) scc) -instance OutputableP SDoc where +instance OutputableP env 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)))) +instance (OutputableP env a) => OutputableP env (Set a) where + pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s)))) {- |