diff options
30 files changed, 320 insertions, 255 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index ec655e0b2c..8828adb0d0 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -862,6 +862,8 @@ entry. instance Outputable CLabel where ppr = pprCLabel +instance PlatformOutputable CLabel where + pprPlatform _ = pprCLabel pprCLabel :: CLabel -> SDoc diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 83d72b8f6e..fcb220d74c 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -13,6 +13,7 @@ import CmmExpr import MkGraph import qualified OldCmm as Old import OldPprCmm () +import Platform import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch) import Control.Monad @@ -21,23 +22,23 @@ import Maybes import Outputable import UniqSupply -cmmToZgraph :: Old.Cmm -> UniqSM Cmm -cmmOfZgraph :: Cmm -> Old.Cmm +cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm +cmmOfZgraph :: Cmm -> Old.Cmm -cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops +cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) = - do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g + do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g mapTop (CmmData s ds) = return $ CmmData s ds cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds -toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) -toZgraph _ (Old.ListGraph []) = +toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) +toZgraph _ _ (Old.ListGraph []) = do g <- lgraphOfAGraph emptyAGraph return (StackInfo {arg_space=0, updfr_space=Nothing}, g) -toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = +toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = let (offset, entry) = mkCallEntry NativeNodeCall [] in do g <- labelAGraph id $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks @@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = mkStmts (last : []) = mkLast last mkStmts [] = bad "fell off end" mkStmts (_ : _ : _) = bad "last node not at end" - bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g) + bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g) mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) = mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) = diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 32fead337e..15357ecb94 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -23,6 +23,7 @@ import Outputable import OldPprCmm() import Constants import FastString +import Platform import Data.Maybe @@ -30,21 +31,22 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops + => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops cmmLintTop :: (Outputable d, Outputable h) - => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop top = runCmmLint lintCmmTop top + => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop platform top = runCmmLint platform lintCmmTop top -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = +runCmmLint :: PlatformOutputable a + => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (pprPlatform platform p)]) + Right _ -> Nothing lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint () lintCmmTop (CmmProc _ lbl (ListGraph blocks)) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 07a8c11df5..2d59fe751e 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1075,7 +1075,7 @@ parseCmmFile dflags filename = do if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 1e4809d2b2..5effa6ca77 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog = let topCAFEnv = mkTopCAFInfo (concat cafEnvs) (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) -- SRT is not affected by control flow optimization pass let prog' = map runCmmContFlowOpts (cmms : rst) return (topSRT, prog') @@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Eliminate common blocks ------------------- g <- return $ elimCommonBlocks g - dump Opt_D_dump_cmmz_cbe "Post common block elimination" g + dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g -- Any work storing block Labels must be performed _after_ elimCommonBlocks ----------- Proc points ------------------- let callPPs = callProcPoints g - procPoints <- run $ minimalProcPointSet callPPs g + procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g g <- run $ addProcPointProtocols callPPs procPoints g - dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g + dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g ----------- Spills and reloads ------------------- g <- run $ dualLivenessWithInsertion procPoints g - dump Opt_D_dump_cmmz_spills "Post spills and reloads" g + dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g ----------- Sink and inline assignments ------------------- g <- runOptimization $ rewriteAssignments g - dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g ----------- Eliminate dead assignments ------------------- g <- runOptimization $ removeDeadAssignments g - dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g + dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g ----------- Zero dead stack slots (Debug only) --------------- -- Debugging: stubbing slots on death can cause crashes early g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g @@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------ Manifest the stack pointer -------- g <- run $ manifestSP spEntryMap areaMap entry_off g - dump Opt_D_dump_cmmz_sp "Post manifestSP" g + dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... @@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g) - mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs ------------- More CAFs and foreign calls ------------ cafEnv <- run $ cafAnal g @@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) mbpprTrace "localCAFs" (ppr localCAFs) $ return () gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs gs <- return $ map (bundleCAFs cafEnv) gs - mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs return (localCAFs, gs) where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z - dump f txt g = do + dump f = dumpWith ppr f + dumpPlatform platform = dumpWith (pprPlatform platform) + dumpWith pprFun f txt g = do -- ToDo: No easy way of say "dump all the cmmz, *and* split -- them into files." Also, -ddump-cmmz doesn't play nicely -- with -ddump-to-file, since the headers get omitted. - dumpIfSet_dyn dflags f txt (ppr g) + dumpIfSet_dyn dflags f txt (pprFun g) when (not (dopt f dflags)) $ - dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g) -- Runs a required transformation/analysis run = runInfiniteFuelIO (hsc_OptFuel hsc_env) -- Runs an optional transformation/analysis (and should diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 0527b6eea0..b608b291d4 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -25,6 +25,7 @@ import MkGraph import Control.Monad import OptimizationFuel import Outputable +import Platform import UniqSet import UniqSupply @@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g CmmForeignCall {succ=k} -> setInsert k set _ -> set -minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points -minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints +minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status) -- Once you know what the proc-points are, figure out @@ -151,8 +152,8 @@ procPointAnalysis procPoints g = liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints] -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet -extendPPSet g blocks procPoints = +extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet +extendPPSet platform g blocks procPoints = do env <- procPointAnalysis procPoints g let add block pps = let id = entryLabel block in case mapLookup id env of @@ -163,7 +164,7 @@ extendPPSet 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 <+> pprPlatform platform b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b) @@ -181,7 +182,7 @@ extendPPSet g blocks procPoints = -} case newPoint of Just id -> if setMember id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (setInsert id procPoints') + else extendPPSet platform g blocks (setInsert id procPoints') Nothing -> return procPoints' diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index f443ce80d9..4050359710 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -50,20 +50,23 @@ import PprCmmExpr import BasicTypes import ForeignCall import Outputable +import Platform import FastString import Data.List ----------------------------------------------------------------------------- -instance (Outputable instr) => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) +instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where + pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) -instance (Outputable instr) => Outputable (GenBasicBlock instr) where - ppr b = pprBBlock b +instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where + pprPlatform platform b = pprBBlock platform b instance Outputable CmmStmt where ppr s = pprStmt s +instance PlatformOutputable CmmStmt where + pprPlatform _ = ppr instance Outputable CmmInfo where ppr e = pprInfo e @@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) = -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) +pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc +pprBBlock platform (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index cede69e06f..43e1c5bb2f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -49,6 +49,7 @@ import PprCmmExpr import Util import BasicTypes +import Platform import Compiler.Hoopl import Data.List import Prelude hiding (succ) @@ -76,20 +77,20 @@ instance Outputable ForeignTarget where ppr = pprForeignTarget -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 PlatformOutputable (Block CmmNode C C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode C O) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O O) where + pprPlatform _ = pprBlock -instance Outputable (Graph CmmNode e x) where - ppr = pprGraph +instance PlatformOutputable (Graph CmmNode e x) where + pprPlatform = pprGraph -instance Outputable CmmGraph where - ppr = pprCmmGraph +instance PlatformOutputable CmmGraph where + pprPlatform platform = pprCmmGraph platform ---------------------------------------------------------- -- Outputting types Cmm contains @@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = ---------------------------------------------------------- -- Outputting blocks and graphs -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc pprBlock block = foldBlockNodesB3 ( ($$) . ppr , ($$) . (nest 4) . ppr , ($$) . (nest 4) . ppr @@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr block empty -pprGraph :: Graph CmmNode e x -> SDoc -pprGraph GNil = empty -pprGraph (GUnit block) = ppr block -pprGraph (GMany entry body exit) +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph _ GNil = empty +pprGraph platform (GUnit block) = pprPlatform platform block +pprGraph platform (GMany entry body exit) = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc + where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty - pprMaybeO (JustO block) = ppr block + pprMaybeO (JustO block) = pprPlatform platform block -pprCmmGraph :: CmmGraph -> SDoc -pprCmmGraph g +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g = text "{" <> text "offset" - $$ nest 2 (vcat $ map ppr blocks) + $$ nest 2 (vcat $ map (pprPlatform platform) blocks) $$ text "}" where blocks = postorderDfs g diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 08fa075d11..f688f211fb 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -43,6 +43,7 @@ import PprCmmExpr import Outputable +import Platform import FastString import Data.List @@ -54,23 +55,25 @@ import ClosureInfo #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatics info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) +pprCmms :: (Outputable info, PlatformOutputable g) + => Platform -> [GenCmm CmmStatics info g] -> SDoc +pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatics info g] -> IO () -writeCmms handle cmms = printForC handle (pprCmms cmms) +writeCmms :: (Outputable info, PlatformOutputable g) + => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO () +writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) ----------------------------------------------------------------------------- -instance (Outputable d, Outputable info, Outputable g) - => Outputable (GenCmm d info g) where - ppr c = pprCmm c +instance (Outputable d, Outputable info, PlatformOutputable g) + => PlatformOutputable (GenCmm d info g) where + pprPlatform platform c = pprCmm platform c -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmTop d info i) where - ppr t = pprTop t +instance (Outputable d, Outputable info, PlatformOutputable i) + => PlatformOutputable (GenCmmTop d info i) where + pprPlatform platform t = pprTop platform t instance Outputable CmmStatics where ppr e = pprStatics e @@ -84,20 +87,22 @@ instance Outputable CmmInfoTable where ----------------------------------------------------------------------------- -pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc -pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops +pprCmm :: (Outputable d, Outputable info, PlatformOutputable g) + => Platform -> GenCmm d info g -> SDoc +pprCmm platform (Cmm tops) + = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmTop d info i -> SDoc +pprTop :: (Outputable d, Outputable info, PlatformOutputable i) + => Platform -> GenCmmTop d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop platform (CmmProc info lbl graph) = vcat [ pprCLabel lbl <> lparen <> rparen , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph + , nest 4 $ pprPlatform platform graph , rbrace ] -- -------------------------------------------------------------------------- @@ -105,7 +110,7 @@ pprTop (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop (CmmData section ds) = +pprTop _ (CmmData section ds) = (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 1825c97256..42c4bd24fc 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 0404258446..29a254fafc 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 340a313561..be5c79cf64 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -115,7 +115,7 @@ cmmLlvmGen dflags us env cmm = do let fixed_cmm = fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [fixed_cmm]) + (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm]) -- generate llvm code from cmm let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b58b7cd395..3ff35b6b92 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -61,7 +61,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC do { when (dopt Opt_DoCmmLinting dflags) $ do { showPass dflags "CmmLint" - ; let lints = map cmmLint flat_abstractC + ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC ; case firstJusts lints of Just err -> do { printDump err ; ghcExit dflags 1 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 2836c0d2d1..266395d0b1 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1054,6 +1054,7 @@ hscGenHardCode cgguts mod_summary cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + platform = targetPlatform dflags location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1089,7 +1090,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -1160,10 +1161,11 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do { let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags ; prog <- StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) + (pprCmms platform prog) -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. @@ -1172,7 +1174,7 @@ tryNewCodeGen hsc_env this_mod data_tycons ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog') ; return prog' } @@ -1189,11 +1191,12 @@ optionallyConvertAndOrCPS hsc_env cmms = testCmmConversion :: HscEnv -> Cmm -> IO Cmm testCmmConversion hsc_env cmm = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags showPass dflags "CmmToCmm" - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let zgraph = initUs_ us (cmmToZgraph cmm) + let zgraph = initUs_ us (cmmToZgraph platform cmm) chosen_graph <- if dopt Opt_RunCPSZ dflags then do us <- mkSplitUniqSupply 'S' @@ -1201,10 +1204,10 @@ testCmmConversion hsc_env cmm = (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph return zgraph else return (runCmmContFlowOpts zgraph) - dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph) showPass dflags "Convert from Z back to Cmm" let cvt = cmmOfZgraph chosen_graph - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt) return cvt myCoreToStg :: DynFlags -> Module -> [CoreBind] diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 7a3bdefeff..0e497fea7e 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -133,7 +133,7 @@ The machine-dependent bits break down as follows: -- Top-level of the native codegen data NcgImpl statics instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + cmmTopCodeGen :: Platform -> RawCmmTop -> NatM [NatCmmTop statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, @@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen @@ -206,7 +206,7 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) +nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () @@ -272,7 +272,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) +cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> BufHandle @@ -327,7 +327,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Outputable statics, Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> UniqSupply @@ -341,6 +341,7 @@ cmmNativeGen cmmNativeGen dflags ncgImpl us cmm count = do + let platform = targetPlatform dflags -- rewrite assignments to global regs let fixed_cmm = @@ -354,27 +355,27 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [opt_cmm]) + (pprCmm platform $ Cmm [opt_cmm]) -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm + initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl platform) opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native) -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapUs regLiveness + $ mapUs (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) + (vcat $ map (pprPlatform platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -401,14 +402,14 @@ cmmNativeGen dflags ncgImpl us cmm count -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) + $$ pprPlatform platform stats) $ zip [0..] regAllocStats) let mPprStats = @@ -432,7 +433,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) let mPprStats = if dopt Opt_D_dump_asm_stats dflags @@ -476,7 +477,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) expanded) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded) return ( usAlloc , expanded diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 89ad516875..71373ee21d 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -66,10 +66,11 @@ import FastString -- order. cmmTopCodeGen - :: RawCmmTop + :: Platform + -> RawCmmTop -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen _ (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlagsNat @@ -80,7 +81,7 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Just picBase -> initializePicBase_ppc ArchPPC os picBase tops Nothing -> return tops -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen _ (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 340cf3f8da..de8db68e65 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -41,7 +41,7 @@ import Platform import Pretty import FastString import qualified Outputable -import Outputable ( Outputable, panic ) +import Outputable ( PlatformOutputable, panic ) import Data.Word import Data.Bits @@ -142,8 +142,8 @@ pprASCII str -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr pprReg :: Reg -> Doc diff --git a/compiler/nativeGen/PprInstruction.hs b/compiler/nativeGen/PprInstruction.hs new file mode 100644 index 0000000000..6c19160e35 --- /dev/null +++ b/compiler/nativeGen/PprInstruction.hs @@ -0,0 +1,2 @@ + + pprInstruction :: Platform -> instr -> SDoc diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 298b5673d4..9e8c25e68d 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -28,6 +28,7 @@ import UniqSet import UniqFM import Bag import Outputable +import Platform import DynFlags import Data.List @@ -44,7 +45,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable statics, Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. @@ -79,6 +80,7 @@ regAlloc_spin debug_codeGraphs code = do + let platform = targetPlatform dflags -- if any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the -- allocator to ditch them early so we don't end up creating space leaks. @@ -111,7 +113,7 @@ regAlloc_spin -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -159,14 +161,14 @@ regAlloc_spin else graph_colored -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced -- clean out unneeded SPILL/RELOADs let code_spillclean = map cleanSpills code_patched -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map stripLive code_spillclean + let code_final = map (stripLive platform) code_spillclean -- record what happened in this stage for debugging let stat = @@ -211,7 +213,7 @@ regAlloc_spin -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = @@ -320,11 +322,11 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable statics, Outputable instr, Instruction instr) - => Color.Graph VirtualReg RegClass RealReg + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmTop statics instr -> LiveCmmTop statics instr -patchRegsFromGraph graph code +patchRegsFromGraph platform graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg @@ -343,7 +345,7 @@ patchRegsFromGraph graph code | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ ppr code + $$ pprPlatform platform code $$ Color.dotGraph (\_ -> text "white") (trivColorable diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 8a16b25187..3ea150a3df 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -29,6 +29,7 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -62,12 +63,12 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo - :: (Outputable instr, Instruction instr) - => LiveCmmTop statics instr - -> SpillCostInfo +slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -96,7 +97,7 @@ slurpSpillCostInfo cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> ppr instr) + (text "no liveness information on instruction " <> pprPlatform platform instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index f24e876cb2..c4a3c9087d 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -65,12 +65,12 @@ data RegAllocStats statics instr , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where +instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) + pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pprPlatform platform (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph @@ -81,11 +81,11 @@ instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats sta (raGraph s) - ppr (s@RegAllocStatsSpill{}) + pprPlatform platform (s@RegAllocStatsSpill{}) = text "# Spill" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -99,14 +99,14 @@ instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats sta $$ text "" $$ text "# Code with spills inserted." - $$ (ppr (raSpilled s)) + $$ pprPlatform platform (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." @@ -125,19 +125,19 @@ instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats sta else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pprPlatform platform (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pprPlatform platform (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pprPlatform platform (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pprPlatform platform (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 4e54b4744d..f72f644930 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -127,7 +127,7 @@ import Control.Monad -- Allocate registers regAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags -> LiveCmmTop statics instr -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -178,51 +178,54 @@ linearRegAlloc -> UniqSM ([NatBasicBlock instr], RegAllocStats) linearRegAlloc dflags first_id block_live sccs - = case platformArch $ targetPlatform dflags of - ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs - ArchARM -> panic "linearRegAlloc ArchARM" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + = let platform = targetPlatform dflags + in case platformArch platform of + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => freeRegs + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> freeRegs -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats) -linearRegAlloc' initFreeRegs first_id block_live sccs +linearRegAlloc' platform initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs first_id block_live [] sccs + $ linearRA_SCCs platform first_id block_live [] sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ blocksAcc [] +linearRA_SCCs _ _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live +linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock platform block_live block + linearRA_SCCs platform first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process platform first_id block_live blocks [] (return []) False + linearRA_SCCs platform first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -238,8 +241,9 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -247,10 +251,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ [] [] accum _ +process _ _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process platform first_id block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -260,10 +264,10 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process platform first_id block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process platform first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -271,26 +275,27 @@ process first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock block_live b - process first_id block_live blocks + b' <- processBlock platform block_live b + process platform first_id block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process platform first_id block_live blocks (b : next_round) accum madeProgress -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated -processBlock block_live (BasicBlock id instrs) +processBlock platform block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) - <- linearRA block_live [] [] id instrs + <- linearRA platform block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -316,8 +321,9 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. @@ -328,24 +334,25 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ accInstr accFixup _ [] +linearRA _ _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA block_live accInstr accFixups id (instr:instrs) +linearRA platform block_live accInstr accFixups id (instr:instrs) = do (accInstr', new_fixups) - <- raInsn block_live accInstr id instr + <- raInsn platform block_live accInstr id instr - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -353,17 +360,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn _ block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -403,11 +410,11 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) +raInsn platform _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) +genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) => BlockMap RegSet -> [instr] -> BlockId @@ -546,7 +553,7 @@ releaseRegs regs = do saveClobberedTemps - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will @@ -638,7 +645,7 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -682,7 +689,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) => Bool -> [VirtualReg] -> [instr] @@ -787,7 +794,7 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 7867f8e7c6..01337308b8 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -40,6 +40,7 @@ import OldPprCmm() import Digraph import Outputable +import Platform import Unique import UniqSet import UniqFM @@ -169,13 +170,13 @@ type LiveBasicBlock instr = GenBasicBlock (LiveInstr instr) -instance Outputable instr - => Outputable (InstrSR instr) where +instance PlatformOutputable instr + => PlatformOutputable (InstrSR instr) where - ppr (Instr realInstr) - = ppr realInstr + pprPlatform platform (Instr realInstr) + = pprPlatform platform realInstr - ppr (SPILL reg slot) + pprPlatform _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -183,7 +184,7 @@ instance Outputable instr comma, ptext (sLit "SLOT") <> parens (int slot)] - ppr (RELOAD slot reg) + pprPlatform _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -191,14 +192,14 @@ instance Outputable instr comma, ppr reg] -instance Outputable instr - => Outputable (LiveInstr instr) where +instance PlatformOutputable instr + => PlatformOutputable (LiveInstr instr) where - ppr (LiveInstr instr Nothing) - = ppr instr + pprPlatform platform (LiveInstr instr Nothing) + = pprPlatform platform instr - ppr (LiveInstr instr (Just live)) - = ppr instr + pprPlatform platform (LiveInstr instr (Just live)) + = pprPlatform platform instr $$ (nest 8 $ vcat [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) @@ -458,11 +459,12 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmTop stripLive - :: (Outputable statics, Outputable instr, Instruction instr) - => LiveCmmTop statics instr + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr -> NatCmmTop statics instr -stripLive live +stripLive platform live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds @@ -484,8 +486,7 @@ stripLive live -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -657,22 +658,23 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- Annotate code with register liveness information -- regLiveness - :: (Outputable instr, Instruction instr) - => LiveCmmTop statics instr + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr -> UniqSM (LiveCmmTop statics instr) -regLiveness (CmmData i d) +regLiveness _ (CmmData i d) = returnUs $ CmmData i d -regLiveness (CmmProc info lbl []) +regLiveness _ (CmmProc info lbl []) | LiveInfo static mFirst _ _ <- info = returnUs $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) lbl [] -regLiveness (CmmProc info lbl sccs) +regLiveness platform (CmmProc info lbl sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs + = let (ann_sccs, block_live) = computeLiveness platform sccs in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) lbl ann_sccs @@ -736,20 +738,21 @@ reverseBlocksInTops top -- want for the next pass. -- computeLiveness - :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". BlockMap RegSet) -- blocks annontated with set of live registers -- on entry to the block. -computeLiveness sccs +computeLiveness platform sccs = case checkIsReverseDependent sccs of Nothing -> livenessSCCs emptyBlockMap [] sccs Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" (vcat [ text "SCCs aren't in reverse dependent order" , text "bad blockId" <+> ppr bad - , ppr sccs]) + , pprPlatform platform sccs]) livenessSCCs :: Instruction instr diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 72e4649eca..817fa47183 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -44,26 +44,27 @@ import CLabel import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Platform import Unique import Control.Monad ( mapAndUnzipM ) -- | Top level code generation -cmmTopCodeGen - :: RawCmmTop - -> NatM [NatCmmTop CmmStatics Instr] +cmmTopCodeGen :: Platform + -> RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen +cmmTopCodeGen platform (CmmProc info lab (ListGraph blocks)) = do - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks let proc = CmmProc info lab (ListGraph $ concat nat_blocks) let tops = proc : concat statics return tops -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen _ (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -72,12 +73,12 @@ cmmTopCodeGen (CmmData sec dat) = do -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop CmmStatics Instr]) +basicBlockCodeGen :: Platform + -> CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do +basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let (top,other_blocks,statics) @@ -94,7 +95,7 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock platform cmm) $ BasicBlock id top : other_blocks return (blocksChecked, statics) diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index ca4c8e4994..a3053cbae8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -15,15 +15,17 @@ import Instruction import OldCmm import Outputable +import Platform -- | Enforce intra-block invariants. -- -checkBlock - :: CmmBasicBlock - -> NatBasicBlock Instr -> NatBasicBlock Instr +checkBlock :: Platform + -> CmmBasicBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -31,9 +33,9 @@ checkBlock cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pprPlatform platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pprPlatform platform block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 2e8bf29a2e..bf3fd3c303 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -39,7 +39,7 @@ import CLabel import Unique ( Uniquable(..), pprUnique ) import qualified Outputable -import Outputable (Outputable, panic) +import Outputable (PlatformOutputable, panic) import Platform import Pretty import FastString @@ -133,8 +133,8 @@ pprASCII str -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 49ac543e65..00d9a5bbad 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -79,10 +79,11 @@ if_sse2 sse2 x87 = do if b then sse2 else x87 cmmTopCodeGen - :: RawCmmTop + :: Platform + -> RawCmmTop -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen _ (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlagsNat @@ -94,7 +95,7 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Just picBase -> initializePicBase_x86 ArchX86 os picBase tops Nothing -> return tops -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen _ (CmmData sec dat) = do return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 17b169e27a..a755d839fb 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -39,7 +39,7 @@ import Platform import Pretty import FastString import qualified Outputable -import Outputable (panic, Outputable) +import Outputable (panic, PlatformOutputable) import Data.Word @@ -162,8 +162,8 @@ pprAlign platform bytes -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr defaultTargetPlatform instr +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr pprReg :: Platform -> Size -> Reg -> Doc diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a341bdecbc..ec65cded94 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -164,6 +164,9 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance PlatformOutputable a => PlatformOutputable (SCC a) where + pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) + pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 8a0c62a2ed..7f8a3a67ff 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,6 +13,7 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -74,6 +75,7 @@ import {-# SOURCE #-} OccName( OccName ) import StaticFlags import FastString import FastTypes +import Platform import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -600,6 +602,13 @@ class Outputable a where ppr = pprPrec 0 pprPrec _ = ppr + +class PlatformOutputable a where + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -621,12 +630,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" +instance PlatformOutputable () where + pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) +instance (PlatformOutputable a) => PlatformOutputable [a] where + pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) +instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where + pprPlatform platform (x,y) + = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") @@ -687,6 +703,8 @@ instance Outputable FastString where instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) +instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where + pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) \end{code} |