summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs17
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs10
-rw-r--r--compiler/cmm/CmmLint.hs58
-rw-r--r--compiler/cmm/CmmParse.y2
-rw-r--r--compiler/cmm/CmmPipeline.hs27
-rw-r--r--compiler/cmm/CmmProcPoint.hs2
-rw-r--r--compiler/cmm/OldPprCmm.hs52
-rw-r--r--compiler/cmm/PprCmm.hs94
-rw-r--r--compiler/cmm/PprCmmDecl.hs56
-rw-r--r--compiler/cmm/PprCmmExpr.hs12
10 files changed, 160 insertions, 170 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)
View Lorry Controller Status