diff options
33 files changed, 285 insertions, 328 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 717a38a6db..20cd584065 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -253,22 +253,21 @@ data ForeignLabelSource -- The regular Outputable instance only shows the label name, and not its other info. -- pprDebugCLabel :: Platform -> CLabel -> SDoc -pprDebugCLabel platform lbl +pprDebugCLabel _ lbl = case lbl of - IdLabel{} -> pprPlatform platform lbl <> (parens $ text "IdLabel") + IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") CmmLabel pkg _name _info - -> pprPlatform platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) - RtsLabel{} -> pprPlatform platform lbl <> (parens $ text "RtsLabel") + RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") ForeignLabel _name mSuffix src funOrData - -> pprPlatform platform lbl <> (parens - $ text "ForeignLabel" + -> ppr lbl <> (parens $ text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData) - _ -> pprPlatform platform lbl <> (parens $ text "other CLabel)") + _ -> ppr lbl <> (parens $ text "other CLabel)") data IdLabelInfo @@ -922,8 +921,8 @@ Not exporting these Just_info labels reduces the number of symbols somewhat. -} -instance PlatformOutputable CLabel where - pprPlatform = pprCLabel +instance Outputable CLabel where + ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c pprCLabel :: Platform -> CLabel -> SDoc diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index b39a59134c..81d82d0b8a 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -228,12 +228,12 @@ data TopSRT = TopSRT { lbl :: CLabel , rev_elts :: [CLabel] , elt_map :: Map CLabel Int } -- map: CLabel -> its last entry in the table -instance PlatformOutputable TopSRT where - pprPlatform platform (TopSRT lbl next elts eltmap) = - text "TopSRT:" <+> pprPlatform platform lbl +instance Outputable TopSRT where + ppr (TopSRT lbl next elts eltmap) = + text "TopSRT:" <+> ppr lbl <+> ppr next - <+> pprPlatform platform elts - <+> pprPlatform platform eltmap + <+> ppr elts + <+> ppr eltmap emptySRT :: MonadUnique m => m TopSRT emptySRT = diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 98e6eb286d..01ebac6254 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -31,22 +31,22 @@ import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (PlatformOutputable d, PlatformOutputable h) +cmmLint :: (Outputable d, Outputable h) => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops -cmmLintTop :: (PlatformOutputable d, PlatformOutputable h) +cmmLintTop :: (Outputable d, Outputable h) => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top -runCmmLint :: PlatformOutputable a +runCmmLint :: Outputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint platform l p = +runCmmLint _ 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 (pprPlatform platform p)]) + nest 2 (ppr p)]) Right _ -> Nothing lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () @@ -81,7 +81,7 @@ lintCmmExpr platform expr@(CmmMachOp op args) = do tys <- mapM (lintCmmExpr platform) args if map (typeWidth . cmmExprType) args == machOpArgReps op then cmmCheckMachOp op args tys - else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op) + else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) lintCmmExpr platform (CmmRegOff reg offset) = lintCmmExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) @@ -103,14 +103,14 @@ isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint () -_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset platform e -_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset platform e -_cmmCheckWordAddress _ _ + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress _ = return () -- No warnings for unaligned arithmetic with the node register, @@ -128,7 +128,7 @@ lintCmmStmt platform labels = lint let reg_ty = cmmRegType reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () - else cmmLintAssignErr platform stmt erep reg_ty + else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do _ <- lintCmmExpr platform l _ <- lintCmmExpr platform r @@ -136,13 +136,13 @@ lintCmmStmt platform labels = lint lint (CmmCall target _res args _) = do lintTarget platform labels target mapM_ (lintCmmExpr platform . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr platform e if (erep `cmmEqType_ignoring_ptrhood` bWord) then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <> + else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) lint (CmmJump e _) = lintCmmExpr platform e >> return () lint (CmmReturn) = return () @@ -158,12 +158,12 @@ lintTarget platform labels (CmmPrim _ (Just stmts)) = mapM_ (lintCmmStmt platform labels) stmts -checkCond :: Platform -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond platform expr +checkCond :: CmmExpr -> CmmLint () +checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values +checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 - (pprPlatform platform expr)) + (ppr expr)) -- ----------------------------------------------------------------------------- -- CmmLint monad @@ -187,23 +187,23 @@ addLintInfo info thing = CmmLint $ Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr platform expr argsRep opExpectsRep +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep = cmmLintErr (text "in MachOp application: " $$ - nest 2 (pprPlatform platform expr) $$ + nest 2 (ppr expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) -cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr platform stmt e_ty r_ty +cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr stmt e_ty r_ty = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [pprPlatform platform stmt, + nest 2 (vcat [ppr stmt, text "Reg ty:" <+> ppr r_ty, text "Rhs ty:" <+> ppr e_ty])) -cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a -cmmLintDubiousWordOffset platform expr +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (pprPlatform platform expr)) + nest 2 (ppr expr)) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 9d831b7fc2..075ed22ea9 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1078,7 +1078,7 @@ parseCmmFile dflags filename = do if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr 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 73e8b338f5..409623d58f 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -73,7 +73,7 @@ cmmPipeline hsc_env (topSRT, rst) prog = let cmms :: CmmGroup cmms = reverse (concat tops) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) -- SRT is not affected by control flow optimization pass let prog' = runCmmContFlowOpts cmms @@ -100,33 +100,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Eliminate common blocks ------------------- g <- return $ elimCommonBlocks g - dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g + dump 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 (targetPlatform dflags) callPPs g g <- run $ addProcPointProtocols callPPs procPoints g - dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g + dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g ----------- Spills and reloads ------------------- g <- run $ dualLivenessWithInsertion procPoints g - dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g + dump Opt_D_dump_cmmz_spills "Post spills and reloads" g ----------- Sink and inline assignments ------------------- g <- runOptimization $ rewriteAssignments platform g - dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g ----------- Eliminate dead assignments ------------------- g <- runOptimization $ removeDeadAssignments g - dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g + dump 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 - dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g @@ -137,7 +137,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 - dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g + dump 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... @@ -146,21 +146,21 @@ 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_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs + mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs ------------- More CAFs and foreign calls ------------ cafEnv <- run $ cafAnal platform g let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs - mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return () + mbpprTrace "localCAFs" (ppr localCAFs) $ return () gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs - mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + mapM_ (dump 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_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs gs <- return $ map (bundleCAFs cafEnv) gs - mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs return (localCAFs, gs) -- gs :: [ (CAFSet, CmmDecl) ] @@ -170,7 +170,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) platform = targetPlatform dflags mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z 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 diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index b7945429ea..f50d850b3a 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -163,7 +163,7 @@ extendPPSet platform g blocks procPoints = newPoint = listToMaybe newPoints ppSuccessor b = let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of + pprPanic "no ppt" (ppr id <+> ppr b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b) diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 24821b61af..19b913853c 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -55,24 +55,24 @@ import Data.List ----------------------------------------------------------------------------- -instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where - pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) -instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where - pprPlatform platform b = pprBBlock platform b +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock -instance PlatformOutputable CmmStmt where - pprPlatform = pprStmt +instance Outputable CmmStmt where + ppr s = sdocWithPlatform $ \platform -> pprStmt platform s -instance PlatformOutputable CmmInfo where - pprPlatform = pprInfo +instance Outputable CmmInfo where + ppr i = sdocWithPlatform $ \platform -> pprInfo platform i -- -------------------------------------------------------------------------- -instance PlatformOutputable CmmSafety where - pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_") - pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_") - pprPlatform platform (CmmSafe srt) = pprPlatform platform srt +instance Outputable CmmSafety where + ppr CmmUnsafe = ptext (sLit "_unsafe_call_") + ppr CmmInterruptible = ptext (sLit "_interruptible_call_") + ppr (CmmSafe srt) = ppr srt -- -------------------------------------------------------------------------- -- Info tables. The current pretty printer needs refinement @@ -89,14 +89,14 @@ pprInfo platform (CmmInfo _gc_target update_frame info_table) = maybe (ptext (sLit "<none>")) (pprUpdateFrame platform) update_frame, - pprPlatform platform info_table] + ppr info_table] -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc -pprBBlock platform (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. @@ -111,10 +111,10 @@ pprStmt platform stmt = case stmt of CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where rep = ppr ( cmmExprType expr ) @@ -132,8 +132,8 @@ pprStmt platform stmt = case stmt of | otherwise = commafy (map ppr_ar results) <+> equals -- Don't print the hints on a native C-- call ppr_ar (CmmHinted ar k) = case cconv of - CmmCallConv -> pprPlatform platform ar - _ -> pprPlatform platform (ar,k) + CmmCallConv -> ppr ar + _ -> ppr (ar,k) pp_conv = case cconv of CmmCallConv -> empty _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) @@ -150,7 +150,7 @@ pprStmt platform stmt = case stmt of Nothing ForeignLabelInThisPackage IsFunction) CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch platform expr ident + CmmCondBranch expr ident -> genCondBranch expr ident CmmJump expr live -> genJump platform expr live CmmReturn -> genReturn platform CmmSwitch arg ids -> genSwitch platform arg ids @@ -159,8 +159,6 @@ pprStmt platform stmt = case stmt of -- ... is that a good idea? --Isaac Dupree instance (Outputable a) => Outputable (CmmHinted a) where ppr (CmmHinted a k) = ppr (a, k) -instance (PlatformOutputable a) => PlatformOutputable (CmmHinted a) where - pprPlatform platform (CmmHinted a k) = pprPlatform platform (a, k) pprUpdateFrame :: Platform -> UpdateFrame -> SDoc pprUpdateFrame platform (UpdateFrame expr args) = @@ -172,7 +170,7 @@ pprUpdateFrame platform (UpdateFrame expr args) = CmmLoad (CmmReg _) _ -> pprExpr platform expr _ -> parens (pprExpr platform expr) , space - , parens ( commafy $ map (pprPlatform platform) args ) ] + , parens ( commafy $ map ppr args ) ] -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 @@ -188,10 +186,10 @@ genBranch ident = -- -- if (expr) { goto lbl; } -- -genCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc -genCondBranch platform expr ident = +genCondBranch :: CmmExpr -> BlockId -> SDoc +genCondBranch expr ident = hsep [ ptext (sLit "if") - , parens(pprPlatform platform expr) + , parens (ppr expr) , ptext (sLit "goto") , ppr ident <> semi ] diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index d32f129247..fd2efdf011 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -59,12 +59,12 @@ import Prelude hiding (succ) instance Outputable CmmStackInfo where ppr = pprStackInfo -instance PlatformOutputable CmmTopInfo where - pprPlatform = pprTopInfo +instance Outputable CmmTopInfo where + ppr x = sdocWithPlatform $ \platform -> pprTopInfo platform x -instance PlatformOutputable (CmmNode e x) where - pprPlatform = pprNode +instance Outputable (CmmNode e x) where + ppr x = sdocWithPlatform $ \platform -> pprNode platform x instance Outputable Convention where ppr = pprConvention @@ -72,24 +72,24 @@ instance Outputable Convention where instance Outputable ForeignConvention where ppr = pprForeignConvention -instance PlatformOutputable ForeignTarget where - pprPlatform = pprForeignTarget +instance Outputable ForeignTarget where + ppr x = sdocWithPlatform $ \platform -> pprForeignTarget platform x -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 (Block CmmNode C C) where + ppr x = sdocWithPlatform $ \platform -> pprBlock platform x +instance Outputable (Block CmmNode C O) where + ppr x = sdocWithPlatform $ \platform -> pprBlock platform x +instance Outputable (Block CmmNode O C) where + ppr x = sdocWithPlatform $ \platform -> pprBlock platform x +instance Outputable (Block CmmNode O O) where + ppr x = sdocWithPlatform $ \platform -> pprBlock platform x -instance PlatformOutputable (Graph CmmNode e x) where - pprPlatform = pprGraph +instance Outputable (Graph CmmNode e x) where + ppr x = sdocWithPlatform $ \platform -> pprGraph platform x -instance PlatformOutputable CmmGraph where - pprPlatform platform = pprCmmGraph platform +instance Outputable CmmGraph where + ppr g = sdocWithPlatform $ \platform -> pprCmmGraph platform g ---------------------------------------------------------- -- Outputting types Cmm contains @@ -100,8 +100,8 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ptext (sLit "updfr_space: ") <> ppr updfr_space pprTopInfo :: Platform -> CmmTopInfo -> SDoc -pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = - vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl, +pprTopInfo _ (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, ptext (sLit "stack_info: ") <> ppr stack_info] ---------------------------------------------------------- @@ -109,30 +109,30 @@ pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock platform block - = foldBlockNodesB3 ( ($$) . pprPlatform platform - , ($$) . (nest 4) . pprPlatform platform - , ($$) . (nest 4) . pprPlatform platform +pprBlock _ block + = foldBlockNodesB3 ( ($$) . ppr + , ($$) . (nest 4) . ppr + , ($$) . (nest 4) . ppr ) block empty pprGraph :: Platform -> Graph CmmNode e x -> SDoc pprGraph _ GNil = empty -pprGraph platform (GUnit block) = pprPlatform platform block -pprGraph platform (GMany entry body exit) +pprGraph _ (GUnit block) = ppr block +pprGraph _ (GMany entry body exit) = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty - pprMaybeO (JustO block) = pprPlatform platform block + pprMaybeO (JustO block) = ppr block pprCmmGraph :: Platform -> CmmGraph -> SDoc -pprCmmGraph platform g +pprCmmGraph _ g = text "{" <> text "offset" - $$ nest 2 (vcat $ map (pprPlatform platform) blocks) + $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorderDfs g @@ -154,24 +154,24 @@ pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs pprForeignTarget :: Platform -> ForeignTarget -> SDoc -pprForeignTarget platform (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn +pprForeignTarget _ (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn where ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c args res) = doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = pprPlatform platform t - ppr_target fn' = parens (pprPlatform platform fn') + ppr_target t@(CmmLit _) = ppr t + ppr_target fn' = parens (ppr fn') -pprForeignTarget platform (PrimTarget op) +pprForeignTarget _ (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign. - = pprPlatform platform + = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing ForeignLabelInThisPackage IsFunction)) pprNode :: Platform -> CmmNode e x -> SDoc -pprNode platform node = pp_node <+> pp_debug +pprNode _ node = pp_node <+> pp_debug where pp_node :: SDoc pp_node = case node of @@ -182,10 +182,10 @@ pprNode platform node = pp_node <+> pp_debug CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where rep = ppr ( cmmExprType expr ) @@ -195,7 +195,7 @@ pprNode platform node = pp_node <+> pp_debug hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, ptext $ sLit "call", - pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi] + ppr target <> parens (commafy $ map ppr args) <> semi] -- goto label; CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi @@ -203,7 +203,7 @@ pprNode platform node = pp_node <+> pp_debug -- if (expr) goto t; else goto f; CmmCondBranch expr t f -> hsep [ ptext (sLit "if") - , parens(pprPlatform platform expr) + , parens(ppr expr) , ptext (sLit "goto") , ppr t <> semi , ptext (sLit "else goto") @@ -215,8 +215,8 @@ pprNode platform node = pp_node <+> pp_debug , int (length maybe_ids - 1) , ptext (sLit "] ") , if isTrivialCmmExpr expr - then pprPlatform platform expr - else parens (pprPlatform platform expr) + then ppr expr + else parens (ppr expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace @@ -237,15 +237,15 @@ pprNode platform node = pp_node <+> pp_debug <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] - where pprFun f@(CmmLit _) = pprPlatform platform f - pprFun f = parens (pprPlatform platform f) + where pprFun f@(CmmLit _) = ppr f + pprFun f = parens (ppr f) CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space - , pprPlatform platform t, ptext (sLit "(...)"), space + , ppr t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s - <+> ptext (sLit "args:") <+> parens (pprPlatform platform as) + <+> ptext (sLit "args:") <+> parens (ppr as) <+> ptext (sLit "ress:") <+> parens (ppr rs) , ptext (sLit " with update frame") <+> ppr u , semi ] diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 5c1c6f0b6a..80c5b813ce 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -61,38 +61,36 @@ import SMRep #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (PlatformOutputable info, PlatformOutputable g) +pprCmms :: (Outputable info, Outputable g) => Platform -> [GenCmmGroup CmmStatics info g] -> SDoc -pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) +pprCmms _ cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (PlatformOutputable info, PlatformOutputable g) +writeCmms :: (Outputable info, Outputable g) => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () writeCmms dflags handle cmms = printForC dflags handle (pprCmms platform cmms) where platform = targetPlatform dflags ----------------------------------------------------------------------------- -instance (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) - => PlatformOutputable (GenCmmDecl d info i) where - pprPlatform platform t = pprTop platform t +instance (Outputable d, Outputable info, Outputable i) + => Outputable (GenCmmDecl d info i) where + ppr t = sdocWithPlatform $ \platform -> pprTop platform t -instance PlatformOutputable CmmStatics where - pprPlatform = pprStatics +instance Outputable CmmStatics where + ppr x = sdocWithPlatform $ \platform -> pprStatics platform x -instance PlatformOutputable CmmStatic where - pprPlatform = pprStatic +instance Outputable CmmStatic where + ppr x = sdocWithPlatform $ \platform -> pprStatic platform x -instance PlatformOutputable CmmInfoTable where - pprPlatform = pprInfoTable +instance Outputable CmmInfoTable where + ppr x = sdocWithPlatform $ \platform -> pprInfoTable platform x ----------------------------------------------------------------------------- -pprCmmGroup :: (PlatformOutputable d, - PlatformOutputable info, - PlatformOutputable g) +pprCmmGroup :: (Outputable d, Outputable info, Outputable g) => Platform -> GenCmmGroup d info g -> SDoc pprCmmGroup platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops @@ -100,14 +98,14 @@ pprCmmGroup platform tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i) +pprTop :: (Outputable d, Outputable info, Outputable i) => Platform -> GenCmmDecl d info i -> SDoc pprTop platform (CmmProc info lbl graph) = vcat [ pprCLabel platform lbl <> lparen <> rparen - , nest 8 $ lbrace <+> pprPlatform platform info $$ rbrace - , nest 4 $ pprPlatform platform graph + , nest 8 $ lbrace <+> ppr info $$ rbrace + , nest 4 $ ppr graph , rbrace ] -- -------------------------------------------------------------------------- @@ -115,8 +113,8 @@ pprTop platform (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop platform (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (pprPlatform platform ds)) +pprTop _ (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace -- -------------------------------------------------------------------------- @@ -125,22 +123,21 @@ pprTop platform (CmmData section ds) = pprInfoTable :: Platform -> CmmInfoTable -> SDoc pprInfoTable _ CmmNonInfoTable = empty -pprInfoTable platform +pprInfoTable _ (CmmInfoTable { cit_lbl = lbl, cit_rep = rep , cit_prof = prof_info , cit_srt = _srt }) - = vcat [ ptext (sLit "label:") <+> pprPlatform platform lbl + = vcat [ ptext (sLit "label:") <+> ppr lbl , ptext (sLit "rep:") <> ppr rep , case prof_info of NoProfilingInfo -> empty ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct , ptext (sLit "desc: ") <> pprWord8String cd ] ] -instance PlatformOutputable C_SRT where - pprPlatform _ (NoC_SRT) = ptext (sLit "_no_srt_") - pprPlatform platform (C_SRT label off bitmap) - = parens (pprPlatform platform label <> comma <> ppr off - <> comma <> text (show bitmap)) +instance Outputable C_SRT where + ppr NoC_SRT = ptext (sLit "_no_srt_") + ppr (C_SRT label off bitmap) + = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap)) instance Outputable ForeignHint where ppr NoHint = empty @@ -148,8 +145,6 @@ instance Outputable ForeignHint where -- ppr AddrHint = quotes(text "address") -- Temp Jan08 ppr AddrHint = (text "PtrHint") -instance PlatformOutputable ForeignHint where - pprPlatform _ = ppr -- -------------------------------------------------------------------------- -- Static data. @@ -157,7 +152,8 @@ instance PlatformOutputable ForeignHint where -- following C-- -- pprStatics :: Platform -> CmmStatics -> SDoc -pprStatics platform (Statics lbl ds) = vcat ((pprCLabel platform lbl <> colon) : map (pprPlatform platform) ds) +pprStatics platform (Statics lbl ds) + = vcat ((pprCLabel platform lbl <> colon) : map ppr ds) pprStatic :: Platform -> CmmStatic -> SDoc pprStatic platform s = case s of diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 81ce84c264..37d6be97af 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -57,19 +57,17 @@ import Numeric ( fromRat ) ----------------------------------------------------------------------------- -instance PlatformOutputable CmmExpr where - pprPlatform = pprExpr +instance Outputable CmmExpr where + ppr e = sdocWithPlatform $ \platform -> pprExpr platform e instance Outputable CmmReg where ppr e = pprReg e -instance PlatformOutputable CmmLit where - pprPlatform = pprLit +instance Outputable CmmLit where + ppr l = sdocWithPlatform $ \platform -> pprLit platform l instance Outputable LocalReg where ppr e = pprLocalReg e -instance PlatformOutputable LocalReg where - pprPlatform _ = ppr instance Outputable Area where ppr e = pprArea e @@ -147,7 +145,7 @@ pprExpr9 :: Platform -> CmmExpr -> SDoc pprExpr9 platform e = case e of CmmLit lit -> pprLit1 platform lit - CmmLoad expr rep -> ppr rep <> brackets (pprPlatform platform expr) + CmmLoad expr rep -> ppr rep <> brackets (ppr expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 06442dc004..0efc99d370 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -146,10 +146,10 @@ data StableLoc -- be saved, so it makes sense to treat treat them as -- having a stable location -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo id _ vol stb _ _) +instance Outputable CgIdInfo where + ppr (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info - = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb] + = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb] instance Outputable VolatileLoc where ppr NoVolatileLoc = empty @@ -157,12 +157,12 @@ instance Outputable VolatileLoc where ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v -instance PlatformOutputable StableLoc where - pprPlatform _ NoStableLoc = empty - pprPlatform _ VoidLoc = ptext (sLit "void") - pprPlatform _ (VirStkLoc v) = ptext (sLit "vs") <+> ppr v - pprPlatform _ (VirStkLNE v) = ptext (sLit "lne") <+> ppr v - pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a +instance Outputable StableLoc where + ppr NoStableLoc = empty + ppr VoidLoc = ptext (sLit "void") + ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v + ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v + ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a \end{code} %************************************************************************ diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 9ad8d13b5f..aff5e468ca 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -78,7 +78,6 @@ cgTopRhsCon id con args ; amodes <- getArgAmodes args ; let - platform = targetPlatform dflags name = idName id lf_info = mkConLFInfo con closure_label = mkClosureLabel name $ idCafInfo id @@ -92,7 +91,7 @@ cgTopRhsCon id con args payload = map get_lit amodes_w_offsets get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other) + get_lit other = pprPanic "CgCon.get_lit" (ppr other) -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs -- NB2: all the amodes should be Lits! diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 1e80616887..6c77255a62 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -45,7 +45,6 @@ import Unique import StaticFlags import Constants -import DynFlags import Util import Outputable @@ -168,8 +167,6 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do - dflags <- getDynFlags - let platform = targetPlatform dflags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -179,7 +176,7 @@ mkStackLayout = do | (offset, b) <- binds] WARN( not (all (\bind -> fst bind >= 0) rel_binds), - pprPlatform platform binds $$ pprPlatform platform rel_binds $$ + ppr binds $$ ppr rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) return $ stack_layout rel_binds frame_size diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index c97c3d47cd..87e6d9f9dd 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -151,11 +151,9 @@ direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode () direct_call caller lbl arity args reps | debugIsOn && arity > length reps -- Too few args = do -- Caller should ensure that there enough args! - dflags <- getDynFlags - let platform = targetPlatform dflags pprPanic "direct_call" (text caller <+> ppr arity - <+> pprPlatform platform lbl <+> ppr (length reps) - <+> pprPlatform platform args <+> ppr reps ) + <+> ppr lbl <+> ppr (length reps) + <+> ppr args <+> ppr reps ) | null rest_reps -- Precisely the right number of arguments = emitCall (NativeDirectCall, NativeReturn) target args @@ -177,9 +175,8 @@ direct_call caller lbl arity args reps slow_call :: CmmExpr -> [CmmExpr] -> [ArgRep] -> FCode () slow_call fun args reps = do dflags <- getDynFlags - let platform = targetPlatform dflags call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps - emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (pprPlatform platform fun) ++ + emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (ppr fun) ++ " with pat " ++ unpackFS rts_fun) emit (mkAssign nodeReg fun <*> call) where diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 71457c530c..4eea38e22c 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -197,13 +197,13 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc +instance Outputable CgIdInfo where + ppr (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> ptext (sLit "-->") <+> ppr loc -instance PlatformOutputable CgLoc where - pprPlatform platform (CmmLoc e) = ptext (sLit "cmm") <+> pprPlatform platform e - pprPlatform _ (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs +instance Outputable CgLoc where + ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e + ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs -- Sequel tells what to do with the result of this expression diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 7530192e1a..906e522479 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -1,6 +1,11 @@ module DynFlags where +import Platform + data DynFlags + tracingDynFlags :: DynFlags +targetPlatform :: DynFlags -> Platform + diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 3941588714..5a90f2acdd 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1284,7 +1284,7 @@ hscGenHardCode cgguts mod_summary = do ------------------ Code output ----------------------- rawcmms <- {-# SCC "cmmToRawCmm" #-} cmmToRawCmm platform cmms - dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) (_stub_h_exists, stub_c_exists) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod location foreign_stubs @@ -1368,7 +1368,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" (pprPlatform platform prog') + dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') return prog' myCoreToStg :: DynFlags -> Module -> CoreProgram diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 45d0af0ab9..0574e9246c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl { nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () nativeCodeGen dflags h us cmms = let platform = targetPlatform dflags - nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' :: (Outputable statics, Outputable 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' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) +nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () @@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) +cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> BufHandle @@ -316,7 +316,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count count' <- return $! count + 1; -- force evaulation all this stuff to avoid space leaks - {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map (pprPlatform platform) imports) `seq` return () + {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return () cmmNativeGens dflags ncgImpl h us' cmms @@ -332,7 +332,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 - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest -> UniqSupply @@ -380,7 +380,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map (pprPlatform platform) withLiveness) + (vcat $ map ppr withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -414,7 +414,7 @@ cmmNativeGen dflags ncgImpl us cmm count (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ pprPlatform platform stats) + $$ ppr stats) $ zip [0..] regAllocStats) let mPprStats = diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 6026abcd5e..9f366b9945 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -134,8 +134,8 @@ pprASCII str -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr pprReg :: Platform -> Reg -> SDoc diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 0a4dc49881..4e359a1c79 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -45,7 +45,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. @@ -73,8 +73,8 @@ regAlloc dflags regsFree slotsFree code , reverse debug_codeGraphs ) regAlloc_spin :: (Instruction instr, - PlatformOutputable instr, - PlatformOutputable statics) + Outputable instr, + Outputable statics) => DynFlags -> Int -> Color.Triv VirtualReg RegClass RealReg @@ -329,7 +329,7 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr @@ -352,7 +352,7 @@ patchRegsFromGraph platform graph code | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ pprPlatform platform code + $$ ppr code $$ Color.dotGraph (\_ -> text "white") (trivColorable platform diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 222e222c75..c7b41de912 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -70,12 +70,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 :: (PlatformOutputable instr, Instruction instr) +slurpSpillCostInfo :: (Outputable instr, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SpillCostInfo -slurpSpillCostInfo platform cmm +slurpSpillCostInfo _ cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -104,7 +104,7 @@ slurpSpillCostInfo platform cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> pprPlatform platform instr) + (text "no liveness information on instruction " <> ppr 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 69be2f0ed6..32970336ad 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -72,12 +72,12 @@ data RegAllocStats statics instr , raFinal :: [NatCmmDecl statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where +instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where - pprPlatform platform (s@RegAllocStatsStart{}) - = text "# Start" + ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> + text "# Start" $$ text "# Native code with liveness information." - $$ pprPlatform platform (raLiveCmm s) + $$ ppr (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph @@ -88,11 +88,11 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu (raGraph s) - pprPlatform platform (s@RegAllocStatsSpill{}) - = text "# Spill" + ppr (s@RegAllocStatsSpill{}) = + text "# Spill" $$ text "# Code with liveness information." - $$ pprPlatform platform (raCode s) + $$ ppr (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -106,14 +106,14 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu $$ text "" $$ text "# Code with spills inserted." - $$ pprPlatform platform (raSpilled s) + $$ ppr (raSpilled s) - pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = text "# Colored" + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform -> + text "# Colored" $$ text "# Code with liveness information." - $$ pprPlatform platform (raCode s) + $$ ppr (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." @@ -132,19 +132,19 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu else empty) $$ text "# Native code after coalescings applied." - $$ pprPlatform platform (raCodeCoalesced s) + $$ ppr (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ pprPlatform platform (raPatched s) + $$ ppr (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ pprPlatform platform (raSpillClean s) + $$ ppr (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ pprPlatform platform (raFinal s) + $$ ppr (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 64b0f68eda..8c38fd1de6 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 - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => DynFlags -> LiveCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats) @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -189,7 +189,7 @@ linearRegAlloc dflags first_id block_live sccs ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> freeRegs -> BlockId -- ^ the first block @@ -205,7 +205,7 @@ linearRegAlloc' platform initFreeRegs first_id block_live sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockId -> BlockMap RegSet @@ -241,7 +241,7 @@ linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +process :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockId -> BlockMap RegSet @@ -286,7 +286,7 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on @@ -321,7 +321,7 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. @@ -350,7 +350,7 @@ linearRA platform block_live accInstr accFixups id (instr:instrs) -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. @@ -410,11 +410,11 @@ raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) (uniqSetToList $ liveDieWrite live) -raInsn platform _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) +raInsn _ _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> ppr instr) -genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) +genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> BlockMap RegSet -> [instr] @@ -554,7 +554,7 @@ releaseRegs regs = do saveClobberedTemps - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => Platform -> [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn @@ -647,7 +647,7 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + :: (FR freeRegs, Outputable instr, Instruction instr) => Platform -> Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out @@ -692,7 +692,7 @@ allocateRegsAndSpill platform 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, PlatformOutputable instr) +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) => Platform -> Bool -> [VirtualReg] @@ -798,7 +798,7 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => Platform -> VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 0212e8cb16..5ff89e811f 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -171,13 +171,13 @@ type LiveBasicBlock instr = GenBasicBlock (LiveInstr instr) -instance PlatformOutputable instr - => PlatformOutputable (InstrSR instr) where +instance Outputable instr + => Outputable (InstrSR instr) where - pprPlatform platform (Instr realInstr) - = pprPlatform platform realInstr + ppr (Instr realInstr) + = ppr realInstr - pprPlatform _ (SPILL reg slot) + ppr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -185,7 +185,7 @@ instance PlatformOutputable instr comma, ptext (sLit "SLOT") <> parens (int slot)] - pprPlatform _ (RELOAD slot reg) + ppr (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -193,14 +193,14 @@ instance PlatformOutputable instr comma, ppr reg] -instance PlatformOutputable instr - => PlatformOutputable (LiveInstr instr) where +instance Outputable instr + => Outputable (LiveInstr instr) where - pprPlatform platform (LiveInstr instr Nothing) - = pprPlatform platform instr + ppr (LiveInstr instr Nothing) + = ppr instr - pprPlatform platform (LiveInstr instr (Just live)) - = pprPlatform platform instr + ppr (LiveInstr instr (Just live)) + = ppr instr $$ (nest 8 $ vcat [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) @@ -213,9 +213,9 @@ instance PlatformOutputable instr | isEmptyUniqSet regs = empty | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) -instance PlatformOutputable LiveInfo where - pprPlatform platform (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (maybe empty (pprPlatform platform) mb_static) +instance Outputable LiveInfo where + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty (ppr) mb_static) $$ text "# firstId = " <> ppr firstId $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -460,9 +460,7 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive - :: (PlatformOutputable statics, - PlatformOutputable instr, - Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => Platform -> LiveCmmDecl statics instr -> NatCmmDecl statics instr @@ -470,9 +468,7 @@ stripLive stripLive platform live = stripCmm live - where stripCmm :: (PlatformOutputable statics, - PlatformOutputable instr, - Instruction instr) + where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) @@ -493,7 +489,7 @@ stripLive platform 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" (pprPlatform platform proc) + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -666,7 +662,7 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- Annotate code with register liveness information -- regLiveness - :: (PlatformOutputable instr, Instruction instr) + :: (Outputable instr, Instruction instr) => Platform -> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr) @@ -680,9 +676,9 @@ regLiveness _ (CmmProc info lbl []) (LiveInfo static mFirst (Just mapEmpty) Map.empty) lbl [] -regLiveness platform (CmmProc info lbl sccs) +regLiveness _ (CmmProc info lbl sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness platform sccs + = let (ann_sccs, block_live) = computeLiveness sccs in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) lbl ann_sccs @@ -746,21 +742,20 @@ reverseBlocksInTops top -- want for the next pass. -- computeLiveness - :: (PlatformOutputable instr, Instruction instr) - => Platform - -> [SCC (LiveBasicBlock instr)] + :: (Outputable instr, Instruction instr) + => [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 platform sccs +computeLiveness 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 - , pprPlatform platform sccs]) + , ppr sccs]) livenessSCCs :: Instruction instr diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index f02b7a45a8..74f20196df 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -26,7 +26,6 @@ import Size import OldCmm -import DynFlags import OrdList import Outputable @@ -62,11 +61,9 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> do dflags <- getDynFlags - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) + _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlags - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other) +getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 5352281296..654875c497 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -201,8 +201,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) iselExpr64 expr - = do dflags <- getDynFlags - pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr) + = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 78dbb1b493..3eea016124 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -32,7 +32,7 @@ checkBlock :: Platform -> NatBasicBlock Instr -> NatBasicBlock Instr -checkBlock platform cmm block@(BasicBlock _ instrs) +checkBlock _ cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -40,9 +40,9 @@ checkBlock platform cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , pprPlatform platform cmm + , ppr cmm , text " -- native code ---------\n" - , pprPlatform platform block ]) + , ppr block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 4d01b1f48c..7fe1975f9d 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -136,8 +136,8 @@ pprASCII str -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr -- | Pretty print a register. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 4fa42820ca..68f8adf250 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -401,8 +401,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do ) iselExpr64 expr - = do dflags <- getDynFlags - pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr) + = pprPanic "iselExpr64(i386)" (ppr expr) -------------------------------------------------------------------------------- @@ -888,8 +887,7 @@ getRegister' _ (CmmLit lit) in return (Any size code) -getRegister' _ other = do dflags <- getDynFlags - pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other) +getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -1229,11 +1227,9 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> do dflags <- getDynFlags - pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) + _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlags - pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other) +getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 36593b3229..02f8efddae 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -158,8 +158,8 @@ pprAlign platform bytes -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance PlatformOutputable Instr where - pprPlatform platform instr = pprInstr platform instr +instance Outputable Instr where + ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr pprReg :: Platform -> Size -> Reg -> SDoc diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs index fa99a752d1..6934a079b5 100644 --- a/compiler/profiling/ProfInit.hs +++ b/compiler/profiling/ProfInit.hs @@ -23,7 +23,7 @@ import Module -- module; profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc -profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs) +profilingInitCode _ this_mod (local_CCs, ___extern_CCs, singleton_CCSs) | not opt_SccProfilingOn = empty | otherwise = vcat @@ -39,8 +39,8 @@ profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs) emitRegisterCC cc = ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi - where cc_lbl = pprPlatform platform (mkCCLabel cc) + where cc_lbl = ppr (mkCCLabel cc) emitRegisterCCS ccs = ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi - where ccs_lbl = pprPlatform platform (mkCCSLabel ccs) + where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a2b40152f3..f7bdff2612 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -240,9 +240,6 @@ 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 696d803208..7774405583 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,7 +13,6 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), - PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -57,6 +56,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, QualifyName(..), + sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, @@ -71,16 +71,16 @@ module Outputable ( pprDebugAndThen, ) where -import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags ) +import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags, targetPlatform ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) import StaticFlags import FastString import FastTypes -import Platform import qualified Pretty import Util +import Platform import Pretty ( Doc, Mode(..) ) import Panic @@ -283,6 +283,12 @@ pprSetDepth depth doc = SDoc $ \ctx -> getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithPlatform :: (Platform -> SDoc) -> SDoc +sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \end{code} \begin{code} @@ -599,13 +605,6 @@ 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} @@ -615,8 +614,6 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n -instance PlatformOutputable Int where - pprPlatform _ = ppr instance Outputable Word16 where ppr n = integer $ fromIntegral n @@ -629,29 +626,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 (Set a) where ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) 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") ppr (Just x) = ptext (sLit "Just") <+> ppr x -instance PlatformOutputable a => PlatformOutputable (Maybe a) where - pprPlatform _ Nothing = ptext (sLit "Nothing") - pprPlatform platform (Just x) = ptext (sLit "Just") <+> pprPlatform platform x instance (Outputable a, Outputable b) => Outputable (Either a b) where ppr (Left x) = ptext (sLit "Left") <+> ppr x @@ -708,8 +695,6 @@ 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} |