Commit d06edb8e authored by Ian Lynagh's avatar Ian Lynagh

Remove PlatformOutputable

We can now get the Platform from the DynFlags inside an SDoc, so we
no longer need to pass the Platform in.
parent 2901e3ff
...@@ -253,22 +253,21 @@ data ForeignLabelSource ...@@ -253,22 +253,21 @@ data ForeignLabelSource
-- The regular Outputable instance only shows the label name, and not its other info. -- The regular Outputable instance only shows the label name, and not its other info.
-- --
pprDebugCLabel :: Platform -> CLabel -> SDoc pprDebugCLabel :: Platform -> CLabel -> SDoc
pprDebugCLabel platform lbl pprDebugCLabel _ lbl
= case lbl of = case lbl of
IdLabel{} -> pprPlatform platform lbl <> (parens $ text "IdLabel") IdLabel{} -> ppr lbl <> (parens $ text "IdLabel")
CmmLabel pkg _name _info 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 ForeignLabel _name mSuffix src funOrData
-> pprPlatform platform lbl <> (parens -> ppr lbl <> (parens $ text "ForeignLabel"
$ text "ForeignLabel"
<+> ppr mSuffix <+> ppr mSuffix
<+> ppr src <+> ppr src
<+> ppr funOrData) <+> ppr funOrData)
_ -> pprPlatform platform lbl <> (parens $ text "other CLabel)") _ -> ppr lbl <> (parens $ text "other CLabel)")
data IdLabelInfo data IdLabelInfo
...@@ -922,8 +921,8 @@ Not exporting these Just_info labels reduces the number of symbols ...@@ -922,8 +921,8 @@ Not exporting these Just_info labels reduces the number of symbols
somewhat. somewhat.
-} -}
instance PlatformOutputable CLabel where instance Outputable CLabel where
pprPlatform = pprCLabel ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c
pprCLabel :: Platform -> CLabel -> SDoc pprCLabel :: Platform -> CLabel -> SDoc
......
...@@ -228,12 +228,12 @@ data TopSRT = TopSRT { lbl :: CLabel ...@@ -228,12 +228,12 @@ data TopSRT = TopSRT { lbl :: CLabel
, rev_elts :: [CLabel] , rev_elts :: [CLabel]
, elt_map :: Map CLabel Int } , elt_map :: Map CLabel Int }
-- map: CLabel -> its last entry in the table -- map: CLabel -> its last entry in the table
instance PlatformOutputable TopSRT where instance Outputable TopSRT where
pprPlatform platform (TopSRT lbl next elts eltmap) = ppr (TopSRT lbl next elts eltmap) =
text "TopSRT:" <+> pprPlatform platform lbl text "TopSRT:" <+> ppr lbl
<+> ppr next <+> ppr next
<+> pprPlatform platform elts <+> ppr elts
<+> pprPlatform platform eltmap <+> ppr eltmap
emptySRT :: MonadUnique m => m TopSRT emptySRT :: MonadUnique m => m TopSRT
emptySRT = emptySRT =
......
...@@ -31,22 +31,22 @@ import Data.Maybe ...@@ -31,22 +31,22 @@ import Data.Maybe
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Exported entry points: -- Exported entry points:
cmmLint :: (PlatformOutputable d, PlatformOutputable h) cmmLint :: (Outputable d, Outputable h)
=> Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops 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 => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
runCmmLint :: PlatformOutputable a runCmmLint :: Outputable a
=> Platform -> (a -> CmmLint b) -> a -> Maybe SDoc => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint platform l p = runCmmLint _ l p =
case unCL (l p) of case unCL (l p) of
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
nest 2 err, nest 2 err,
ptext $ sLit ("Program was:"), ptext $ sLit ("Program was:"),
nest 2 (pprPlatform platform p)]) nest 2 (ppr p)])
Right _ -> Nothing Right _ -> Nothing
lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
...@@ -81,7 +81,7 @@ lintCmmExpr platform expr@(CmmMachOp op args) = do ...@@ -81,7 +81,7 @@ lintCmmExpr platform expr@(CmmMachOp op args) = do
tys <- mapM (lintCmmExpr platform) args tys <- mapM (lintCmmExpr platform) args
if map (typeWidth . cmmExprType) args == machOpArgReps op if map (typeWidth . cmmExprType) args == machOpArgReps op
then cmmCheckMachOp op args tys 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 (CmmRegOff reg offset)
= lintCmmExpr platform (CmmMachOp (MO_Add rep) = lintCmmExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
...@@ -103,14 +103,14 @@ isOffsetOp _ = False ...@@ -103,14 +103,14 @@ isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded: -- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets. -- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint () _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset platform e = cmmLintDubiousWordOffset e
_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset platform e = cmmLintDubiousWordOffset e
_cmmCheckWordAddress _ _ _cmmCheckWordAddress _
= return () = return ()
-- No warnings for unaligned arithmetic with the node register, -- No warnings for unaligned arithmetic with the node register,
...@@ -128,7 +128,7 @@ lintCmmStmt platform labels = lint ...@@ -128,7 +128,7 @@ lintCmmStmt platform labels = lint
let reg_ty = cmmRegType reg let reg_ty = cmmRegType reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty) if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return () then return ()
else cmmLintAssignErr platform stmt erep reg_ty else cmmLintAssignErr stmt erep reg_ty
lint (CmmStore l r) = do lint (CmmStore l r) = do
_ <- lintCmmExpr platform l _ <- lintCmmExpr platform l
_ <- lintCmmExpr platform r _ <- lintCmmExpr platform r
...@@ -136,13 +136,13 @@ lintCmmStmt platform labels = lint ...@@ -136,13 +136,13 @@ lintCmmStmt platform labels = lint
lint (CmmCall target _res args _) = lint (CmmCall target _res args _) =
do lintTarget platform labels target do lintTarget platform labels target
mapM_ (lintCmmExpr platform . hintlessCmm) args 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 lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr platform e erep <- lintCmmExpr platform e
if (erep `cmmEqType_ignoring_ptrhood` bWord) if (erep `cmmEqType_ignoring_ptrhood` bWord)
then return () 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) text " :: " <> ppr erep)
lint (CmmJump e _) = lintCmmExpr platform e >> return () lint (CmmJump e _) = lintCmmExpr platform e >> return ()
lint (CmmReturn) = return () lint (CmmReturn) = return ()
...@@ -158,12 +158,12 @@ lintTarget platform labels (CmmPrim _ (Just stmts)) ...@@ -158,12 +158,12 @@ lintTarget platform labels (CmmPrim _ (Just stmts))
= mapM_ (lintCmmStmt platform labels) stmts = mapM_ (lintCmmStmt platform labels) stmts
checkCond :: Platform -> CmmExpr -> CmmLint () checkCond :: CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond platform expr checkCond expr
= cmmLintErr (hang (text "expression is not a conditional:") 2 = cmmLintErr (hang (text "expression is not a conditional:") 2
(pprPlatform platform expr)) (ppr expr))
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- CmmLint monad -- CmmLint monad
...@@ -187,23 +187,23 @@ addLintInfo info thing = CmmLint $ ...@@ -187,23 +187,23 @@ addLintInfo info thing = CmmLint $
Left err -> Left (hang info 2 err) Left err -> Left (hang info 2 err)
Right a -> Right a Right a -> Right a
cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr platform expr argsRep opExpectsRep cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$ = cmmLintErr (text "in MachOp application: " $$
nest 2 (pprPlatform platform expr) $$ nest 2 (ppr expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep)) (text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr platform stmt e_ty r_ty cmmLintAssignErr stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$ = cmmLintErr (text "in assignment: " $$
nest 2 (vcat [pprPlatform platform stmt, nest 2 (vcat [ppr stmt,
text "Reg ty:" <+> ppr r_ty, text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty])) text "Rhs ty:" <+> ppr e_ty]))
cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset platform expr cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$ = cmmLintErr (text "offset is not a multiple of words: " $$
nest 2 (pprPlatform platform expr)) nest 2 (ppr expr))
...@@ -1078,7 +1078,7 @@ parseCmmFile dflags filename = do ...@@ -1078,7 +1078,7 @@ parseCmmFile dflags filename = do
if (errorsFound dflags ms) if (errorsFound dflags ms)
then return (ms, Nothing) then return (ms, Nothing)
else do 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) return (ms, Just cmm)
where where
no_module = panic "parseCmmFile: no module" no_module = panic "parseCmmFile: no module"
......
...@@ -73,7 +73,7 @@ cmmPipeline hsc_env (topSRT, rst) prog = ...@@ -73,7 +73,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
let cmms :: CmmGroup let cmms :: CmmGroup
cmms = reverse (concat tops) 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 -- SRT is not affected by control flow optimization pass
let prog' = runCmmContFlowOpts cmms let prog' = runCmmContFlowOpts cmms
...@@ -100,33 +100,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -100,33 +100,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Eliminate common blocks ------------------- ----------- Eliminate common blocks -------------------
g <- return $ elimCommonBlocks g 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 -- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points ------------------- ----------- Proc points -------------------
let callPPs = callProcPoints g let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- run $ addProcPointProtocols callPPs procPoints 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 ------------------- ----------- Spills and reloads -------------------
g <- run $ dualLivenessWithInsertion procPoints g 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 ------------------- ----------- Sink and inline assignments -------------------
g <- runOptimization $ rewriteAssignments platform g 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 ------------------- ----------- Eliminate dead assignments -------------------
g <- runOptimization $ removeDeadAssignments g 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) --------------- ----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early -- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues g <- if opt_StubDeadValues
then run $ stubSlotsOnDeath g then run $ stubSlotsOnDeath g
else return 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 ---------------- --------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g slotEnv <- run $ liveSlotAnal g
...@@ -137,7 +137,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -137,7 +137,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------ Manifest the stack pointer -------- ------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g 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. -- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update... -- 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}}) ...@@ -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 dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g) (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 ------------ ------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal platform g cafEnv <- run $ cafAnal platform g
let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs 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 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 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs 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 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) return (localCAFs, gs)
-- gs :: [ (CAFSet, CmmDecl) ] -- gs :: [ (CAFSet, CmmDecl) ]
...@@ -170,7 +170,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -170,7 +170,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
platform = targetPlatform dflags platform = targetPlatform dflags
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f = dumpWith ppr f dump f = dumpWith ppr f
dumpPlatform platform = dumpWith (pprPlatform platform)
dumpWith pprFun f txt g = do dumpWith pprFun f txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split -- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely -- them into files." Also, -ddump-cmmz doesn't play nicely
......
...@@ -163,7 +163,7 @@ extendPPSet platform g blocks procPoints = ...@@ -163,7 +163,7 @@ extendPPSet platform g blocks procPoints =
newPoint = listToMaybe newPoints newPoint = listToMaybe newPoints
ppSuccessor b = ppSuccessor b =
let nreached id = case mapLookup id env `orElse` 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 ProcPoint -> 1
ReachedBy ps -> setSize ps ReachedBy ps -> setSize ps
block_procpoints = nreached (entryLabel b) block_procpoints = nreached (entryLabel b)
......
...@@ -55,24 +55,24 @@ import Data.List ...@@ -55,24 +55,24 @@ import Data.List
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where instance Outputable instr => Outputable (ListGraph instr) where
pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) ppr (ListGraph blocks) = vcat (map ppr blocks)
instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where instance Outputable instr => Outputable (GenBasicBlock instr) where
pprPlatform platform b = pprBBlock platform b ppr = pprBBlock
instance PlatformOutputable CmmStmt where instance Outputable CmmStmt where
pprPlatform = pprStmt ppr s = sdocWithPlatform $ \platform -> pprStmt platform s
instance PlatformOutputable CmmInfo where instance Outputable CmmInfo where
pprPlatform = pprInfo ppr i = sdocWithPlatform $ \platform -> pprInfo platform i
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
instance PlatformOutputable CmmSafety where instance Outputable CmmSafety where
pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_") ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_") ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
pprPlatform platform (CmmSafe srt) = pprPlatform platform srt ppr (CmmSafe srt) = ppr srt
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement -- Info tables. The current pretty printer needs refinement
...@@ -89,14 +89,14 @@ pprInfo platform (CmmInfo _gc_target update_frame info_table) = ...@@ -89,14 +89,14 @@ pprInfo platform (CmmInfo _gc_target update_frame info_table) =
maybe (ptext (sLit "<none>")) maybe (ptext (sLit "<none>"))
(pprUpdateFrame platform) (pprUpdateFrame platform)
update_frame, update_frame,
pprPlatform platform info_table] ppr info_table]
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks. -- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; .. -- lbl: stmt ; stmt ; ..
pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock platform (BasicBlock ident stmts) = pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious. -- Statements. C-- usually, exceptions to this should be obvious.
...@@ -111,10 +111,10 @@ pprStmt platform stmt = case stmt of ...@@ -111,10 +111,10 @@ pprStmt platform stmt = case stmt of
CmmComment s -> text "//" <+> ftext s CmmComment s -> text "//" <+> ftext s
-- reg = expr; -- reg = expr;
CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-- rep[lv] = expr; -- 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 where
rep = ppr ( cmmExprType expr ) rep = ppr ( cmmExprType expr )
...@@ -132,8 +132,8 @@ pprStmt platform stmt = case stmt of ...@@ -132,8 +132,8 @@ pprStmt platform stmt = case stmt of
| otherwise = commafy (map ppr_ar results) <+> equals | otherwise = commafy (map ppr_ar results) <+> equals
-- Don't print the hints on a native C-- call -- Don't print the hints on a native C-- call
ppr_ar (CmmHinted ar k) = case cconv of ppr_ar (CmmHinted ar k) = case cconv of
CmmCallConv -> pprPlatform platform ar CmmCallConv -> ppr ar
_ -> pprPlatform platform (ar,k) _ -> ppr (ar,k)
pp_conv = case cconv of pp_conv = case cconv of
CmmCallConv -> empty CmmCallConv -> empty
_ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
...@@ -150,7 +150,7 @@ pprStmt platform stmt = case stmt of ...@@ -150,7 +150,7 @@ pprStmt platform stmt = case stmt of
Nothing ForeignLabelInThisPackage IsFunction) Nothing ForeignLabelInThisPackage IsFunction)
CmmBranch ident -> genBranch ident CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch platform expr ident CmmCondBranch expr ident -> genCondBranch expr ident
CmmJump expr live -> genJump platform expr live CmmJump expr live -> genJump platform expr live
CmmReturn -> genReturn platform CmmReturn -> genReturn platform
CmmSwitch arg ids -> genSwitch platform arg ids CmmSwitch arg ids -> genSwitch platform arg ids
...@@ -159,8 +159,6 @@ pprStmt platform stmt = case stmt of ...@@ -159,8 +159,6 @@ pprStmt platform stmt = case stmt of
-- ... is that a good idea? --Isaac Dupree -- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmHinted a) where instance (Outputable a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k) 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 -> SDoc
pprUpdateFrame platform (UpdateFrame expr args) = pprUpdateFrame platform (UpdateFrame expr args) =
...@@ -172,7 +170,7 @@ pprUpdateFrame platform (UpdateFrame expr args) = ...@@ -172,7 +170,7 @@ pprUpdateFrame platform (UpdateFrame expr args) =
CmmLoad (CmmReg _) _ -> pprExpr platform expr CmmLoad (CmmReg _) _ -> pprExpr platform expr
_ -> parens (pprExpr platform expr) _ -> parens (pprExpr platform expr)
, space , space
, parens ( commafy $ map (pprPlatform platform) args ) ] , parens ( commafy $ map ppr args ) ]
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- goto local label. [1], section 6.6 -- goto local label. [1], section 6.6
...@@ -188,10 +186,10 @@ genBranch ident = ...@@ -188,10 +186,10 @@ genBranch ident =
-- --
-- if (expr) { goto lbl; } -- if (expr) { goto lbl; }
-- --
genCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc genCondBranch :: CmmExpr -> BlockId -> SDoc
genCondBranch platform expr ident = genCondBranch expr ident =
hsep [ ptext (sLit "if") hsep [ ptext (sLit "if")
, parens(pprPlatform platform expr) , parens (ppr expr)
, ptext (sLit "goto") , ptext (sLit "goto")
, ppr ident <> semi ] , ppr ident <> semi ]
......
...@@ -59,12 +59,12 @@ import Prelude hiding (succ) ...@@ -59,12 +59,12 @@ import Prelude hiding (succ)
instance Outputable CmmStackInfo where instance Outputable CmmStackInfo where
ppr = pprStackInfo ppr = pprStackInfo
instance PlatformOutputable CmmTopInfo where instance Outputable CmmTopInfo where
pprPlatform = pprTopInfo ppr x = sdocWithPlatform $ \platform -> pprTopInfo platform x
instance PlatformOutputable (CmmNode e x) where instance Outputable (CmmNode e x) where
pprPlatform = pprNode ppr x = sdocWithPlatform $ \platform -> pprNode platform x
instance Outputable Convention where instance Outputable Convention where
ppr = pprConvention ppr = pprConvention
...@@ -72,24 +72,24 @@ instance Outputable Convention where ...@@ -72,24 +72,24 @@ instance Outputable Convention where
instance Outputable ForeignConvention where instance Outputable ForeignConvention where
ppr = pprForeignConvention ppr = pprForeignConvention
instance PlatformOutputable ForeignTarget where instance Outputable ForeignTarget where
pprPlatform = pprForeignTarget ppr x = sdocWithPlatform $ \platform -> pprForeignTarget platform x
instance PlatformOutputable (Block CmmNode C C) where instance Outputable (Block CmmNode C C) where
pprPlatform = pprBlock ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
instance PlatformOutputable (Block CmmNode C O) where instance Outputable (Block CmmNode C O) where
pprPlatform = pprBlock ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
instance PlatformOutputable (Block CmmNode O C) where instance Outputable (Block CmmNode O C) where
pprPlatform = pprBlock ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
instance PlatformOutputable (Block CmmNode O O) where instance Outputable (Block CmmNode O O) where
pprPlatform = pprBlock ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
instance PlatformOutputable (Graph CmmNode e x) where instance Outputable (Graph CmmNode e x) where
pprPlatform = pprGraph ppr x = sdocWithPlatform $ \platform -> pprGraph platform x
instance PlatformOutputable CmmGraph where instance Outputable CmmGraph where
pprPlatform platform = pprCmmGraph platform ppr g = sdocWithPlatform $ \platform -> pprCmmGraph platform g
---------------------------------------------------------- ----------------------------------------------------------
-- Outputting types Cmm contains -- Outputting types Cmm contains
...@@ -100,8 +100,8 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ...@@ -100,8 +100,8 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
ptext (sLit "updfr_space: ") <> ppr updfr_space ptext (sLit "updfr_space: ") <> ppr updfr_space
pprTopInfo :: Platform -> CmmTopInfo -> SDoc pprTopInfo :: Platform -> CmmTopInfo -> SDoc
pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = pprTopInfo _ (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl, vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
ptext (sLit "stack_info: ") <> ppr stack_info] ptext (sLit "stack_info: ") <> ppr stack_info]
---------------------------------------------------------- ----------------------------------------------------------
...@@ -109,30 +109,30 @@ pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = ...@@ -109,30 +109,30 @@ pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
=> Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock platform block pprBlock _ block
= foldBlockNodesB3 ( ($$) . pprPlatform platform