More work towards cross-compilation

There's now a variant of the Outputable class that knows what
platform we're targetting:

class PlatformOutputable a where
    pprPlatform :: Platform -> a -> SDoc
    pprPlatformPrec :: Platform -> Rational -> a -> SDoc

and various instances have had to be converted to use that class,
and we pass Platform around accordingly.

compiler/cmm/CLabel.hs

@@ -862,6 +862,8 @@ entry.
 
 instance Outputable CLabel where
   ppr = pprCLabel
+instance PlatformOutputable CLabel where
+  pprPlatform _ = pprCLabel
 
 pprCLabel :: CLabel -> SDoc
 

compiler/cmm/CmmCvt.hs

@@ -13,6 +13,7 @@ import CmmExpr
 import MkGraph
 import qualified OldCmm as Old
 import OldPprCmm ()
+import Platform
 
 import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
 import Control.Monad
@@ -21,23 +22,23 @@ import Maybes
 import Outputable
 import UniqSupply
 
-cmmToZgraph :: Old.Cmm -> UniqSM Cmm
-cmmOfZgraph :: Cmm     -> Old.Cmm
+cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
+cmmOfZgraph :: Cmm -> Old.Cmm
 
-cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
+cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
   where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
-          do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
+          do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g
              return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
         mapTop (CmmData s ds) = return $ CmmData s ds
 cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
   where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
         mapTop (CmmData s ds) = CmmData s ds
 
-toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
-toZgraph _ (Old.ListGraph []) =
+toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
+toZgraph _ _ (Old.ListGraph []) =
   do g <- lgraphOfAGraph emptyAGraph
      return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
-toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = 
+toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
            let (offset, entry) = mkCallEntry NativeNodeCall [] in
            do g <- labelAGraph id $
                      entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
@@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
         mkStmts (last : []) = mkLast last
         mkStmts []          = bad "fell off end"
         mkStmts (_ : _ : _) = bad "last node not at end"
-        bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
+        bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g)
         mkLast (Old.CmmCall (Old.CmmCallee f conv) []     args _ Old.CmmNeverReturns) =
             mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
         mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =

compiler/cmm/CmmLint.hs

@@ -23,6 +23,7 @@ import Outputable
 import OldPprCmm()
 import Constants
 import FastString
+import Platform
 
 import Data.Maybe
 
@@ -30,21 +31,22 @@ import Data.Maybe
 -- Exported entry points:
 
 cmmLint :: (Outputable d, Outputable h)
-	=> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
+        => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops
 
 cmmLintTop :: (Outputable d, Outputable h)
-	   => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop top = runCmmLint lintCmmTop top
+           => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLintTop platform top = runCmmLint platform lintCmmTop top
 
-runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint l p = 
+runCmmLint :: PlatformOutputable a
+           => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint platform l p =
    case unCL (l p) of
-	Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
-				nest 2 err,
-				ptext $ sLit ("Program was:"),
-				nest 2 (ppr p)])
-  	Right _  -> Nothing
+   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
+                           nest 2 err,
+                           ptext $ sLit ("Program was:"),
+                           nest 2 (pprPlatform platform p)])
+   Right _  -> Nothing
 
 lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
 lintCmmTop (CmmProc _ lbl (ListGraph blocks))

compiler/cmm/CmmParse.y

@@ -1075,7 +1075,7 @@ parseCmmFile dflags filename = do
         if (errorsFound dflags ms)
          then return (ms, Nothing)
          else do
-           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
+           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
            return (ms, Just cmm)
   where
 	no_module = panic "parseCmmFile: no module"

compiler/cmm/CmmPipeline.hs

@@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
      let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
      (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
      let cmms = Cmm (reverse (concat tops))
-     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
      -- SRT is not affected by control flow optimization pass
      let prog' = map runCmmContFlowOpts (cmms : rst)
      return (topSRT, prog')
@@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        ----------- Eliminate common blocks -------------------
        g <- return $ elimCommonBlocks g
-       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
+       dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g
        -- Any work storing block Labels must be performed _after_ elimCommonBlocks
 
        ----------- Proc points -------------------
        let callPPs = callProcPoints g
-       procPoints <- run $ minimalProcPointSet callPPs g
+       procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
        g <- run $ addProcPointProtocols callPPs procPoints g
-       dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
+       dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g
 
        ----------- Spills and reloads -------------------
        g <- run $ dualLivenessWithInsertion procPoints g
-       dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
+       dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g
 
        ----------- Sink and inline assignments -------------------
        g <- runOptimization $ rewriteAssignments g
-       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+       dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
 
        ----------- Eliminate dead assignments -------------------
        g <- runOptimization $ removeDeadAssignments g
-       dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
+       dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g
 
        ----------- Zero dead stack slots (Debug only) ---------------
        -- Debugging: stubbing slots on death can cause crashes early
        g <- if opt_StubDeadValues
                 then run $ stubSlotsOnDeath g
                 else return g
-       dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
+       dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
 
        --------------- Stack layout ----------------
        slotEnv <- run $ liveSlotAnal g
@@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
 
        ------------  Manifest the stack pointer --------
        g  <- run $ manifestSP spEntryMap areaMap entry_off g
-       dump Opt_D_dump_cmmz_sp "Post manifestSP" g
+       dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
 
@@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
                                        (CmmProc h l g)
-       mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
+       mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs
 
        ------------- More CAFs and foreign calls ------------
        cafEnv <- run $ cafAnal g
@@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 
        gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
+       mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
 
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
        gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+       mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
        gs <- return $ map (bundleCAFs cafEnv) gs
-       mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+       mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
        return (localCAFs, gs)
   where dflags = hsc_dflags hsc_env
+        platform = targetPlatform dflags
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
-        dump f txt g = do
+        dump f = dumpWith ppr f
+        dumpPlatform platform = dumpWith (pprPlatform platform)
+        dumpWith pprFun f txt g = do
             -- ToDo: No easy way of say "dump all the cmmz, *and* split
             -- them into files."  Also, -ddump-cmmz doesn't play nicely
             -- with -ddump-to-file, since the headers get omitted.
-            dumpIfSet_dyn dflags f txt (ppr g)
+            dumpIfSet_dyn dflags f txt (pprFun g)
             when (not (dopt f dflags)) $
-                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
+                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
         -- Runs a required transformation/analysis
         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
         -- Runs an optional transformation/analysis (and should

compiler/cmm/CmmProcPoint.hs

@@ -25,6 +25,7 @@ import MkGraph
 import Control.Monad
 import OptimizationFuel
 import Outputable
+import Platform
 import UniqSet
 import UniqSupply
 
@@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
                       CmmForeignCall {succ=k}     -> setInsert k set
                       _ -> set
 
-minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
 -- Given the set of successors of calls (which must be proc-points)
 -- figure out the minimal set of necessary proc-points
-minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
+minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints
 
 procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
 -- Once you know what the proc-points are, figure out
@@ -151,8 +152,8 @@ procPointAnalysis procPoints g =
   liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
   where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
 
-extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
-extendPPSet g blocks procPoints =
+extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
     do env <- procPointAnalysis procPoints g
        let add block pps = let id = entryLabel block
                            in  case mapLookup id env of
@@ -163,7 +164,7 @@ extendPPSet g blocks procPoints =
            newPoint  = listToMaybe newPoints
            ppSuccessor b =
                let nreached id = case mapLookup id env `orElse`
-                                       pprPanic "no ppt" (ppr id <+> ppr b) of
+                                       pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of
                                    ProcPoint -> 1
                                    ReachedBy ps -> setSize ps
                    block_procpoints = nreached (entryLabel b)
@@ -181,7 +182,7 @@ extendPPSet g blocks procPoints =
 -}
        case newPoint of Just id ->
                           if setMember id procPoints' then panic "added old proc pt"
-                          else extendPPSet g blocks (setInsert id procPoints')
+                          else extendPPSet platform g blocks (setInsert id procPoints')
                         Nothing -> return procPoints'
 
 

compiler/cmm/OldPprCmm.hs

@@ -50,20 +50,23 @@ import PprCmmExpr
 import BasicTypes
 import ForeignCall
 import Outputable
+import Platform
 import FastString
 
 import Data.List
 
 -----------------------------------------------------------------------------
 
-instance (Outputable instr) => Outputable (ListGraph instr) where
-    ppr (ListGraph blocks) = vcat (map ppr blocks)
+instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
+    pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)
 
-instance (Outputable instr) => Outputable (GenBasicBlock instr) where
-    ppr b = pprBBlock b
+instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
+    pprPlatform platform b = pprBBlock platform b
 
 instance Outputable CmmStmt where
     ppr s = pprStmt s
+instance PlatformOutputable CmmStmt where
+    pprPlatform _ = ppr
 
 instance Outputable CmmInfo where
     ppr e = pprInfo e
@@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) =
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; ..
-pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
-pprBBlock (BasicBlock ident stmts) =
-    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
+pprBBlock platform (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts))
 
 -- --------------------------------------------------------------------------
 -- Statements. C-- usually, exceptions to this should be obvious.

compiler/cmm/PprCmm.hs

@@ -49,6 +49,7 @@ import PprCmmExpr
 import Util
 
 import BasicTypes
+import Platform
 import Compiler.Hoopl
 import Data.List
 import Prelude hiding (succ)
@@ -76,20 +77,20 @@ instance Outputable ForeignTarget where
     ppr = pprForeignTarget
 
 
-instance Outputable (Block CmmNode C C) where
-    ppr = pprBlock
-instance Outputable (Block CmmNode C O) where
-    ppr = pprBlock
-instance Outputable (Block CmmNode O C) where
-    ppr = pprBlock
-instance Outputable (Block CmmNode O O) where
-    ppr = pprBlock
+instance PlatformOutputable (Block CmmNode C C) where
+    pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode C O) where
+    pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode O C) where
+    pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode O O) where
+    pprPlatform _ = pprBlock
 
-instance Outputable (Graph CmmNode e x) where
-    ppr = pprGraph
+instance PlatformOutputable (Graph CmmNode e x) where
+    pprPlatform = pprGraph
 
-instance Outputable CmmGraph where
-    ppr = pprCmmGraph
+instance PlatformOutputable CmmGraph where
+    pprPlatform platform = pprCmmGraph platform
 
 ----------------------------------------------------------
 -- Outputting types Cmm contains
@@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
 ----------------------------------------------------------
 -- Outputting blocks and graphs
 
-pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+         => Block CmmNode e x -> IndexedCO e SDoc SDoc
 pprBlock block = foldBlockNodesB3 ( ($$) . ppr
                                   , ($$) . (nest 4) . ppr
                                   , ($$) . (nest 4) . ppr
@@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr
                                   block
                                   empty
 
-pprGraph :: Graph CmmNode e x -> SDoc
-pprGraph GNil = empty
-pprGraph (GUnit block) = ppr block
-pprGraph (GMany entry body exit)
+pprGraph :: Platform -> Graph CmmNode e x -> SDoc
+pprGraph _ GNil = empty
+pprGraph platform (GUnit block) = pprPlatform platform block
+pprGraph platform (GMany entry body exit)
    = text "{"
-  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
   $$ text "}"
-  where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
+  where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
+                  => MaybeO ex (Block CmmNode e x) -> SDoc
         pprMaybeO NothingO = empty
-        pprMaybeO (JustO block) = ppr block
+        pprMaybeO (JustO block) = pprPlatform platform block
 
-pprCmmGraph :: CmmGraph -> SDoc
-pprCmmGraph g
+pprCmmGraph :: Platform -> CmmGraph -> SDoc
+pprCmmGraph platform g
    = text "{" <> text "offset"
-  $$ nest 2 (vcat $ map ppr blocks)
+  $$ nest 2 (vcat $ map (pprPlatform platform) blocks)
   $$ text "}"
   where blocks = postorderDfs g
 

compiler/cmm/PprCmmDecl.hs

@@ -43,6 +43,7 @@ import PprCmmExpr
 
 
 import Outputable
+import Platform
 import FastString
 
 import Data.List
@@ -54,23 +55,25 @@ import ClosureInfo
 #include "../includes/rts/storage/FunTypes.h"
 
 
-pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatics info g] -> SDoc
-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+pprCmms :: (Outputable info, PlatformOutputable g)
+        => Platform -> [GenCmm CmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms))
         where
           separator = space $$ ptext (sLit "-------------------") $$ space
 
-writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatics info g] -> IO ()
-writeCmms handle cmms = printForC handle (pprCmms cmms)
+writeCmms :: (Outputable info, PlatformOutputable g)
+          => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO ()
+writeCmms platform handle cmms = printForC handle (pprCmms platform cmms)
 
 -----------------------------------------------------------------------------
 
-instance (Outputable d, Outputable info, Outputable g)
-    => Outputable (GenCmm d info g) where
-    ppr c = pprCmm c
+instance (Outputable d, Outputable info, PlatformOutputable g)
+      => PlatformOutputable (GenCmm d info g) where
+    pprPlatform platform c = pprCmm platform c
 
-instance (Outputable d, Outputable info, Outputable i)
-	=> Outputable (GenCmmTop d info i) where
-    ppr t = pprTop t
+instance (Outputable d, Outputable info, PlatformOutputable i)
+      => PlatformOutputable (GenCmmTop d info i) where
+    pprPlatform platform t = pprTop platform t
 
 instance Outputable CmmStatics where
     ppr e = pprStatics e
@@ -84,20 +87,22 @@ instance Outputable CmmInfoTable where
 
 -----------------------------------------------------------------------------
 
-pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
-pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
+pprCmm :: (Outputable d, Outputable info, PlatformOutputable g)
+       => Platform -> GenCmm d info g -> SDoc
+pprCmm platform (Cmm tops)
+    = vcat $ intersperse blankLine $ map (pprTop platform) tops
 
 -- --------------------------------------------------------------------------
 -- Top level `procedure' blocks.
 --
-pprTop 	:: (Outputable d, Outputable info, Outputable i)
-	=> GenCmmTop d info i -> SDoc
+pprTop :: (Outputable d, Outputable info, PlatformOutputable i)
+       => Platform -> GenCmmTop d info i -> SDoc
 
-pprTop (CmmProc info lbl graph)
+pprTop platform (CmmProc info lbl graph)
 
   = vcat [ pprCLabel lbl <> lparen <> rparen
          , nest 8 $ lbrace <+> ppr info $$ rbrace
-         , nest 4 $ ppr graph
+         , nest 4 $ pprPlatform platform graph
          , rbrace ]
 
 -- --------------------------------------------------------------------------
@@ -105,7 +110,7 @@ pprTop (CmmProc info lbl graph)
 --
 --      section "data" { ... }
 --
-pprTop (CmmData section ds) = 
+pprTop _ (CmmData section ds) = 
     (hang (pprSection section <+> lbrace) 4 (ppr ds))
     $$ rbrace
 

compiler/codeGen/CodeGen.lhs

@@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
                 -- initialisation routines; see Note
                 -- [pipeline-split-init].
 
-  ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
+  ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff)
 
   ; return code_stuff }
 

compiler/codeGen/StgCmm.hs

@@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons
                 -- initialisation routines; see Note
                 -- [pipeline-split-init].
 
-        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
+        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff)
 
         ; return code_stuff }
 

compiler/llvmGen/LlvmCodeGen.hs

@@ -115,7 +115,7 @@ cmmLlvmGen dflags us env cmm = do
     let fixed_cmm = fixStgRegisters cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
-        (pprCmm $ Cmm [fixed_cmm])
+        (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm])
 
     -- generate llvm code from cmm
     let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm

compiler/main/CodeOutput.lhs

@@ -61,7 +61,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 
     do	{ when (dopt Opt_DoCmmLinting dflags) $ do
 		{ showPass dflags "CmmLint"
-		; let lints = map cmmLint flat_abstractC
+		; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
 		; case firstJusts lints of
 			Just err -> do { printDump err
 				       ; ghcExit dflags 1

compiler/main/HscMain.lhs

@@ -1054,6 +1054,7 @@ hscGenHardCode cgguts mod_summary
                      cg_dep_pkgs = dependencies,
                      cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env
+             platform = targetPlatform dflags
              location = ms_location mod_summary
              data_tycons = filter isDataTyCon tycons
              -- cg_tycons includes newtypes, for the benefit of External Core,
@@ -1089,7 +1090,7 @@ hscGenHardCode cgguts mod_summary
                  -- unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
-         dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
+         dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
          (_stub_h_exists, stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 
                 dependencies rawcmms
@@ -1160,10 +1161,11 @@ tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
 tryNewCodeGen hsc_env this_mod data_tycons
               cost_centre_info stg_binds hpc_info =
   do    { let dflags = hsc_dflags hsc_env
+              platform = targetPlatform dflags
         ; prog <- StgCmm.codeGen dflags this_mod data_tycons
                          cost_centre_info stg_binds hpc_info
         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
-                (pprCmms prog)
+                (pprCmms platform prog)
 
         -- We are building a single SRT for the entire module, so
         -- we must thread it through all the procedures as we cps-convert them.
@@ -1172,7 +1174,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
         ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
 
         ; let prog' = map cmmOfZgraph (srtToData topSRT : prog)
-        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
+        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
         ; return prog' }
 
 
@@ -1189,11 +1191,12 @@ optionallyConvertAndOrCPS hsc_env cmms =
 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
 testCmmConversion hsc_env cmm =
     do let dflags = hsc_dflags hsc_env
+           platform = targetPlatform dflags
        showPass dflags "CmmToCmm"
-       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
+       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm)
        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
        us <- mkSplitUniqSupply 'C'
-       let zgraph = initUs_ us (cmmToZgraph cmm)
+       let zgraph = initUs_ us (cmmToZgraph platform cmm)
        chosen_graph <-
         if dopt Opt_RunCPSZ dflags
             then do us <- mkSplitUniqSupply 'S'
@@ -1201,10 +1204,10 @@ testCmmConversion hsc_env cmm =
                     (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph
                     return zgraph
             else return (runCmmContFlowOpts zgraph)
-       dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
+       dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph)
        showPass dflags "Convert from Z back to Cmm"
        let cvt = cmmOfZgraph chosen_graph
-       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
+       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt)
        return cvt
 
 myCoreToStg :: DynFlags -> Module -> [CoreBind]

compiler/nativeGen/AsmCodeGen.lhs

@@ -133,7 +133,7 @@ The machine-dependent bits break down as follows:
 -- Top-level of the native codegen
 
 data NcgImpl statics instr jumpDest = NcgImpl {
-    cmmTopCodeGen             :: RawCmmTop -> NatM [NatCmmTop statics instr],
+    cmmTopCodeGen             :: Platform -> RawCmmTop -> NatM [NatCmmTop statics instr],
     generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr),
     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
     canShortcut               :: instr -> Maybe jumpDest,
@@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
 --------------------
 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
 nativeCodeGen dflags h us cmms
- = let nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
+ = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
@@ -206,7 +206,7 @@ nativeCodeGen dflags h us cmms
                  ArchUnknown ->
                      panic "nativeCodeGen: No NCG for unknown arch"
 
-nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
+nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
                -> Handle -> UniqSupply -> [RawCmm] -> IO ()
@@ -272,7 +272,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
+cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr)
               => DynFlags
               -> NcgImpl statics instr jumpDest
               -> BufHandle
@@ -327,7 +327,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
 --	Dumping the output of each stage along the way.
 --	Global conflict graph and NGC stats
 cmmNativeGen
-	:: (Outputable statics, Outputable instr, Instruction instr)
+	:: (Outputable statics, PlatformOutputable instr, Instruction instr)
     => DynFlags
     -> NcgImpl statics instr jumpDest
 	-> UniqSupply
@@ -341,6 +341,7 @@ cmmNativeGen
 
 cmmNativeGen dflags ncgImpl us cmm count
  = do
+        let platform = targetPlatform dflags
 
 	-- rewrite assignments to global regs
  	let fixed_cmm =
@@ -354,27 +355,27 @@ cmmNativeGen dflags ncgImpl us cmm count
 
 	dumpIfSet_dyn dflags
 		Opt_D_dump_opt_cmm "Optimised Cmm"
-		(pprCmm $ Cmm [opt_cmm])
+		(pprCmm platform $ Cmm [opt_cmm])