Remove PlatformOutputable
authorIan Lynagh <igloo@earth.li>
Wed, 13 Jun 2012 11:13:00 +0000 (12:13 +0100)
committerIan Lynagh <igloo@earth.li>
Wed, 13 Jun 2012 11:13:00 +0000 (12:13 +0100)
We can now get the Platform from the DynFlags inside an SDoc, so we
no longer need to pass the Platform in.

33 files changed:
compiler/cmm/CLabel.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmProcPoint.hs
compiler/cmm/OldPprCmm.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmDecl.hs
compiler/cmm/PprCmmExpr.hs
compiler/codeGen/CgBindery.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/main/DynFlags.hs-boot
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/RegAlloc/Graph/Main.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Graph/Stats.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/SPARC/CodeGen/CondCode.hs
compiler/nativeGen/SPARC/CodeGen/Gen64.hs
compiler/nativeGen/SPARC/CodeGen/Sanity.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Ppr.hs
compiler/profiling/ProfInit.hs
compiler/utils/Digraph.lhs
compiler/utils/Outputable.lhs

index 717a38a..20cd584 100644 (file)
@@ -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
 
index b39a591..81d82d0 100644 (file)
@@ -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 =
index 98e6eb2..01ebac6 100644 (file)
@@ -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))
index 9d831b7..075ed22 100644 (file)
@@ -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"
index 73e8b33..409623d 100644 (file)
@@ -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
index b794542..f50d850 100644 (file)
@@ -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)
index 24821b6..19b9138 100644 (file)
@@ -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 ]
 
index d32f129..fd2efdf 100644 (file)
@@ -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 ]
index 5c1c6f0..80c5b81 100644 (file)
@@ -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
index 81ce84c..37d6be9 100644 (file)
@@ -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)
index 06442dc..0efc99d 100644 (file)
@@ -146,10 +146,10 @@ data StableLoc
                 -- be saved, so it makes sense to treat treat them as
                 -- having a stable location
 
-instance PlatformOutputable CgIdInfo where
-  pprPlatform platform (CgIdInfo id _ vol stb _ _)
+instance Outputable CgIdInfo where
+  ppr (CgIdInfo id _ vol stb _ _)
     -- TODO, pretty pring the tag info
-    = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb]
+    = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb]
 
 instance Outputable VolatileLoc where
   ppr NoVolatileLoc = empty
@@ -157,12 +157,12 @@ instance Outputable VolatileLoc where
   ppr (VirHpLoc v)   = ptext (sLit "vh")  <+> ppr v
   ppr (VirNodeLoc v) = ptext (sLit "vn")  <+> ppr v
 
-instance PlatformOutputable StableLoc where
-  pprPlatform _        NoStableLoc   = empty
-  pprPlatform _        VoidLoc       = ptext (sLit "void")
-  pprPlatform _        (VirStkLoc v) = ptext (sLit "vs")    <+> ppr v
-  pprPlatform _        (VirStkLNE v) = ptext (sLit "lne")   <+> ppr v
-  pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a
+instance Outputable StableLoc where
+  ppr NoStableLoc   = empty
+  ppr VoidLoc       = ptext (sLit "void")
+  ppr (VirStkLoc v) = ptext (sLit "vs")    <+> ppr v
+  ppr (VirStkLNE v) = ptext (sLit "lne")   <+> ppr v
+  ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a
 \end{code}
 
 %************************************************************************
index 9ad8d13..aff5e46 100644 (file)
@@ -78,7 +78,6 @@ cgTopRhsCon id con args
         ; amodes <- getArgAmodes args
 
         ; let
-            platform = targetPlatform dflags
             name          = idName id
             lf_info       = mkConLFInfo con
             closure_label = mkClosureLabel name $ idCafInfo id
@@ -92,7 +91,7 @@ cgTopRhsCon id con args
 
             payload = map get_lit amodes_w_offsets
             get_lit (CmmLit lit, _offset) = lit
-            get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other)
+            get_lit other = pprPanic "CgCon.get_lit" (ppr other)
                 -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
                 -- NB2: all the amodes should be Lits!
 
index 1e80616..6c77255 100644 (file)
@@ -45,7 +45,6 @@ import Unique
 import StaticFlags
 
 import Constants
-import DynFlags
 import Util
 import Outputable
 
@@ -168,8 +167,6 @@ is not present in the list (it is always assumed).
 -}
 mkStackLayout :: FCode [Maybe LocalReg]
 mkStackLayout = do
-  dflags <- getDynFlags
-  let platform = targetPlatform dflags
   StackUsage { realSp = real_sp,
                frameSp = frame_sp } <- getStkUsage
   binds <- getLiveStackBindings
@@ -179,7 +176,7 @@ mkStackLayout = do
                     | (offset, b) <- binds]
 
   WARN( not (all (\bind -> fst bind >= 0) rel_binds),
-        pprPlatform platform binds $$ pprPlatform platform rel_binds $$
+        ppr binds $$ ppr rel_binds $$
         ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
     return $ stack_layout rel_binds frame_size
 
index c97c3d4..87e6d9f 100644 (file)
@@ -151,11 +151,9 @@ direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode ()
 direct_call caller lbl arity args reps
   | debugIsOn && arity > length reps   -- Too few args
   = do -- Caller should ensure that there enough args!
-       dflags <- getDynFlags
-       let platform = targetPlatform dflags
        pprPanic "direct_call" (text caller <+> ppr arity
-                           <+> pprPlatform platform lbl <+> ppr (length reps)
-                           <+> pprPlatform platform args <+> ppr reps )
+                           <+> ppr lbl <+> ppr (length reps)
+                           <+> ppr args <+> ppr reps )
 
   | null rest_reps     -- Precisely the right number of arguments
   = emitCall (NativeDirectCall, NativeReturn) target args
@@ -177,9 +175,8 @@ direct_call caller lbl arity args reps
 slow_call :: CmmExpr -> [CmmExpr] -> [ArgRep] -> FCode ()
 slow_call fun args reps
   = do dflags <- getDynFlags
-       let platform = targetPlatform dflags
        call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
-       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (pprPlatform platform fun) ++
+       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (ppr fun) ++
                                         " with pat " ++ unpackFS rts_fun)
        emit (mkAssign nodeReg fun <*> call)
   where
index 71457c5..4eea38e 100644 (file)
@@ -197,13 +197,13 @@ data CgLoc
        -- To tail-call it, assign to these locals, 
        -- and branch to the block id
 
-instance PlatformOutputable CgIdInfo where
-  pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc })
-    = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc
+instance Outputable CgIdInfo where
+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
+    = ppr id <+> ptext (sLit "-->") <+> ppr loc
 
-instance PlatformOutputable CgLoc where
-  pprPlatform platform (CmmLoc e)    = ptext (sLit "cmm") <+> pprPlatform platform e
-  pprPlatform _        (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
+instance Outputable CgLoc where
+  ppr (CmmLoc e)    = ptext (sLit "cmm") <+> ppr e
+  ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
 
 
 -- Sequel tells what to do with the result of this expression
index 7530192..906e522 100644 (file)
@@ -1,6 +1,11 @@
 
 module DynFlags where
 
+import Platform
+
 data DynFlags
+
 tracingDynFlags :: DynFlags
 
+targetPlatform :: DynFlags -> Platform
+
index 3941588..5a90f2a 100644 (file)
@@ -1284,7 +1284,7 @@ hscGenHardCode cgguts mod_summary = do
         ------------------  Code output -----------------------
         rawcmms <- {-# SCC "cmmToRawCmm" #-}
                    cmmToRawCmm platform cmms
-        dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
+        dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
         (_stub_h_exists, stub_c_exists)
             <- {-# SCC "codeOutput" #-}
                codeOutput dflags this_mod location foreign_stubs
@@ -1368,7 +1368,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
     (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
 
     let prog' = map cmmOfZgraph (srtToData topSRT : prog)
-    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
+    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
     return prog'
 
 myCoreToStg :: DynFlags -> Module -> CoreProgram
index 45d0af0..0574e92 100644 (file)
@@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
 nativeCodeGen dflags h us cmms
  = let platform = targetPlatform dflags
-       nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
+       nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
@@ -206,7 +206,7 @@ nativeCodeGen dflags h us cmms
                  ArchUnknown ->
                      panic "nativeCodeGen: No NCG for unknown arch"
 
-nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
                -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
@@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
               -> NcgImpl statics instr jumpDest
               -> BufHandle
@@ -316,7 +316,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
         count' <- return $! count + 1;
 
         -- force evaulation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map (pprPlatform platform) imports) `seq` return ()
+        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
 
         cmmNativeGens dflags ncgImpl
             h us' cmms
@@ -332,7 +332,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
 --      Dumping the output of each stage along the way.
 --      Global conflict graph and NGC stats
 cmmNativeGen
-        :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+        :: (Outputable statics, Outputable instr, Instruction instr)
     => DynFlags
     -> NcgImpl statics instr jumpDest
         -> UniqSupply
@@ -380,7 +380,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_liveness "Liveness annotations added"
-                (vcat $ map (pprPlatform platform) withLiveness)
+                (vcat $ map ppr withLiveness)
 
         -- allocate registers
         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
@@ -414,7 +414,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                         (vcat   $ map (\(stage, stats)
                                         -> text "# --------------------------"
                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage
-                                        $$ pprPlatform platform stats)
+                                        $$ ppr stats)
                                 $ zip [0..] regAllocStats)
 
                 let mPprStats =
index 6026abc..9f366b9 100644 (file)
@@ -134,8 +134,8 @@ pprASCII str
 -- -----------------------------------------------------------------------------
 -- pprInstr: print an 'Instr'
 
-instance PlatformOutputable Instr where
-    pprPlatform platform instr = pprInstr platform instr
+instance Outputable Instr where
+    ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr
 
 
 pprReg :: Platform -> Reg -> SDoc
index 0a4dc49..4e359a1 100644 (file)
@@ -45,7 +45,7 @@ maxSpinCount    = 10
 
 -- | The top level of the graph coloring register allocator.
 regAlloc
-        :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+        :: (Outputable statics, Outputable instr, Instruction instr)
         => DynFlags
         -> UniqFM (UniqSet RealReg)     -- ^ the registers we can use for allocation
         -> UniqSet Int                  -- ^ the set of available spill slots.
@@ -73,8 +73,8 @@ regAlloc dflags regsFree slotsFree code
                 , reverse debug_codeGraphs )
 
 regAlloc_spin :: (Instruction instr,
-                  PlatformOutputable instr,
-                  PlatformOutputable statics)
+                  Outputable instr,
+                  Outputable statics)
               => DynFlags
               -> Int
               -> Color.Triv VirtualReg RegClass RealReg
@@ -329,7 +329,7 @@ graphAddCoalesce _ _
 
 -- | Patch registers in code using the reg -> reg mapping in this graph.
 patchRegsFromGraph
-        :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+        :: (Outputable statics, Outputable instr, Instruction instr)
         => Platform -> Color.Graph VirtualReg RegClass RealReg
         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
 
@@ -352,7 +352,7 @@ patchRegsFromGraph platform graph code
                 | otherwise
                 = pprPanic "patchRegsFromGraph: register mapping failed."
                         (  text "There is no node in the graph for register " <> ppr reg
-                        $$ pprPlatform platform code
+                        $$ ppr code
                         $$ Color.dotGraph
                                 (\_ -> text "white")
                                 (trivColorable platform
index 222e222..c7b41de 100644 (file)
@@ -70,12 +70,12 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
 --     for each vreg, the number of times it was written to, read from,
 --     and the number of instructions it was live on entry to (lifetime)
 --
-slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr)
+slurpSpillCostInfo :: (Outputable instr, Instruction instr)
                    => Platform
                    -> LiveCmmDecl statics instr
                    -> SpillCostInfo
 
-slurpSpillCostInfo platform cmm
+slurpSpillCostInfo _ cmm
        = execState (countCmm cmm) zeroSpillCostInfo
  where
        countCmm CmmData{}              = return ()
@@ -104,7 +104,7 @@ slurpSpillCostInfo platform cmm
 
                | otherwise
                = pprPanic "RegSpillCost.slurpSpillCostInfo"
-                       (text "no liveness information on instruction " <> pprPlatform platform instr)
+                       (text "no liveness information on instruction " <> ppr instr)
 
        countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)
         = do
index 69be2f0..3297033 100644 (file)
@@ -72,12 +72,12 @@ data RegAllocStats statics instr
        , raFinal         :: [NatCmmDecl statics instr]                         -- ^ final code
        , raSRMs          :: (Int, Int, Int) }                          -- ^ spill\/reload\/reg-reg moves present in this code
 
-instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where
+instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where
 
- pprPlatform platform (s@RegAllocStatsStart{})
-       =  text "#  Start"
+ ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->
+          text "#  Start"
        $$ text "#  Native code with liveness information."
-       $$ pprPlatform platform (raLiveCmm s)
+       $$ ppr (raLiveCmm s)
        $$ text ""
        $$ text "#  Initial register conflict graph."
        $$ Color.dotGraph 
@@ -88,11 +88,11 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu
                (raGraph s)
 
 
- pprPlatform platform (s@RegAllocStatsSpill{})
-       =  text "#  Spill"
+ ppr (s@RegAllocStatsSpill{}) =
+          text "#  Spill"
 
        $$ text "#  Code with liveness information."
-       $$ pprPlatform platform (raCode s)
+       $$ ppr (raCode s)
        $$ text ""
 
        $$ (if (not $ isNullUFM $ raCoalesced s)
@@ -106,14 +106,14 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu
        $$ text ""
 
        $$ text "#  Code with spills inserted."
-       $$ pprPlatform platform (raSpilled s)
+       $$ ppr (raSpilled s)
 
 
- pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
-       =  text "#  Colored"
+ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform ->
+          text "#  Colored"
 
        $$ text "#  Code with liveness information."
-       $$ pprPlatform platform (raCode s)
+       $$ ppr (raCode s)
        $$ text ""
 
        $$ text "#  Register conflict graph (colored)."
@@ -132,19 +132,19 @@ instance (PlatformOutputable statics, PlatformOutputable instr) => PlatformOutpu
                else empty)
 
        $$ text "#  Native code after coalescings applied."
-       $$ pprPlatform platform (raCodeCoalesced s)
+       $$ ppr (raCodeCoalesced s)
        $$ text ""
 
        $$ text "#  Native code after register allocation."
-       $$ pprPlatform platform (raPatched s)
+       $$ ppr (raPatched s)
        $$ text ""
 
        $$ text "#  Clean out unneeded spill/reloads."
-       $$ pprPlatform platform (raSpillClean s)
+       $$ ppr (raSpillClean s)
        $$ text ""
 
        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
-       $$ pprPlatform platform (raFinal s)
+       $$ ppr (raFinal s)
        $$ text ""
        $$  text "#  Score:"
        $$ (text "#          spills  inserted: " <> int spills)
index 64b0f68..8c38fd1 100644 (file)
@@ -127,7 +127,7 @@ import Control.Monad
 
 -- Allocate registers
 regAlloc
-        :: (PlatformOutputable instr, Instruction instr)
+        :: (Outputable instr, Instruction instr)
         => DynFlags
         -> LiveCmmDecl statics instr
         -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats)
@@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _)
 --   an entry in the block map or it is the first block.
 --
 linearRegAlloc
-        :: (PlatformOutputable instr, Instruction instr)
+        :: (Outputable instr, Instruction instr)
         => DynFlags
         -> BlockId                      -- ^ the first block
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
@@ -189,7 +189,7 @@ linearRegAlloc dflags first_id block_live sccs
       ArchUnknown   -> panic "linearRegAlloc ArchUnknown"
 
 linearRegAlloc'
-        :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)
         => Platform
         -> freeRegs
         -> BlockId                      -- ^ the first block
@@ -205,7 +205,7 @@ linearRegAlloc' platform initFreeRegs first_id block_live sccs
         return  (blocks, stats)
 
 
-linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
               => Platform
               -> BlockId
               -> BlockMap RegSet
@@ -241,7 +241,7 @@ linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs)
    more sanity checking to guard against this eventuality.
 -}
 
-process :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
+process :: (FR freeRegs, Instruction instr, Outputable instr)
         => Platform
         -> BlockId
         -> BlockMap RegSet
@@ -286,7 +286,7 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks)
 -- | Do register allocation on this basic block
 --
 processBlock
-        :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)
         => Platform
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> LiveBasicBlock instr         -- ^ block to do register allocation on
@@ -321,7 +321,7 @@ initBlock id
 
 -- | Do allocation for a sequence of instructions.
 linearRA
-        :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)
         => Platform
         -> BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
@@ -350,7 +350,7 @@ linearRA platform block_live accInstr accFixups id (instr:instrs)
 
 -- | Do allocation for a single instruction.
 raInsn
-        :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)
         => Platform
         -> BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
@@ -410,11 +410,11 @@ raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live))
                         (uniqSetToList $ liveDieWrite live)
 
 
-raInsn platform _ _ _ instr
-        = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr)
+raInsn _ _ _ _ instr
+        = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 
 
-genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
           => Platform
           -> BlockMap RegSet
           -> [instr]
@@ -554,7 +554,7 @@ releaseRegs regs = do
 
 
 saveClobberedTemps
-        :: (PlatformOutputable instr, Instruction instr)
+        :: (Outputable instr, Instruction instr)
         => Platform
         -> [RealReg]            -- real registers clobbered by this instruction
         -> [Reg]                -- registers which are no longer live after this insn
@@ -647,7 +647,7 @@ data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
 --   the list of free registers and free stack slots.
 
 allocateRegsAndSpill
-        :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)
         => Platform
         -> Bool                 -- True <=> reading (load up spilled regs)
         -> [VirtualReg]         -- don't push these out
@@ -692,7 +692,7 @@ allocateRegsAndSpill platform reading keep spills alloc (r:rs)
 
 -- reading is redundant with reason, but we keep it around because it's
 -- convenient and it maintains the recursive structure of the allocator. -- EZY
-allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
                         => Platform
                         -> Bool
                         -> [VirtualReg]
@@ -798,7 +798,7 @@ newLocation _ my_reg = InReg my_reg
 
 -- | Load up a spilled temporary if we need to (read from memory).
 loadTemp
-        :: (PlatformOutputable instr, Instruction instr)
+        :: (Outputable instr, Instruction instr)
         => Platform
         -> VirtualReg   -- the temp being loaded
         -> SpillLoc     -- the current location of this temp
index 0212e8c..5ff89e8 100644 (file)
@@ -171,13 +171,13 @@ type LiveBasicBlock instr
         = GenBasicBlock (LiveInstr instr)
 
 
-instance PlatformOutputable instr
-      => PlatformOutputable (InstrSR instr) where
+instance Outputable instr
+      => Outputable (InstrSR instr) where
 
-        pprPlatform platform (Instr realInstr)
-           = pprPlatform platform realInstr
+        ppr (Instr realInstr)
+           = ppr realInstr
 
-        pprPlatform _ (SPILL reg slot)
+        ppr (SPILL reg slot)
            = hcat [
                 ptext (sLit "\tSPILL"),
                 char ' ',
@@ -185,7 +185,7 @@ instance PlatformOutputable instr
                 comma,
                 ptext (sLit "SLOT") <> parens (int slot)]
 
-        pprPlatform _ (RELOAD slot reg)
+        ppr (RELOAD slot reg)
            = hcat [
                 ptext (sLit "\tRELOAD"),
                 char ' ',
@@ -193,14 +193,14 @@ instance PlatformOutputable instr
                 comma,
                 ppr reg]
 
-instance PlatformOutputable instr
-      => PlatformOutputable (LiveInstr instr) where
+instance Outputable instr
+      => Outputable (LiveInstr instr) where
 
-        pprPlatform platform (LiveInstr instr Nothing)
-         = pprPlatform platform instr
+        ppr (LiveInstr instr Nothing)
+         = ppr instr
 
-        pprPlatform platform (LiveInstr instr (Just live))
-         =  pprPlatform platform instr
+        ppr (LiveInstr instr (Just live))
+         =  ppr instr
                 $$ (nest 8
                         $ vcat
                         [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
@@ -213,9 +213,9 @@ instance PlatformOutputable instr
                  | isEmptyUniqSet regs  = empty
                  | otherwise            = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
 
-instance PlatformOutputable LiveInfo where
-    pprPlatform platform (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
-        =  (maybe empty (pprPlatform platform) mb_static)
+instance Outputable LiveInfo where
+    ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
+        =  (maybe empty (ppr) mb_static)
         $$ text "# firstId          = " <> ppr firstId
         $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
         $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
@@ -460,9 +460,7 @@ slurpReloadCoalesce live
 
 -- | Strip away liveness information, yielding NatCmmDecl
 stripLive
-        :: (PlatformOutputable statics,
-            PlatformOutputable instr,
-            Instruction instr)
+        :: (Outputable statics, Outputable instr, Instruction instr)
         => Platform
         -> LiveCmmDecl statics instr
         -> NatCmmDecl statics instr
@@ -470,9 +468,7 @@ stripLive
 stripLive platform live
         = stripCmm live
 
- where  stripCmm :: (PlatformOutputable statics,
-                     PlatformOutputable instr,
-                     Instruction instr)
+ where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
                  => LiveCmmDecl statics instr -> NatCmmDecl statics instr
         stripCmm (CmmData sec ds)       = CmmData sec ds
         stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
@@ -493,7 +489,7 @@ stripLive platform live
 
         -- If the proc has blocks but we don't know what the first one was, then we're dead.
         stripCmm proc
-                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc)
+                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
 
 -- | Strip away liveness information from a basic block,
 --   and make real spill instructions out of SPILL, RELOAD pseudos along the way.
@@ -666,7 +662,7 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
 -- Annotate code with register liveness information
 --
 regLiveness
-        :: (PlatformOutputable instr, Instruction instr)
+        :: (Outputable instr, Instruction instr)
         => Platform
         -> LiveCmmDecl statics instr
         -> UniqSM (LiveCmmDecl statics instr)
@@ -680,9 +676,9 @@ regLiveness _ (CmmProc info lbl [])
                         (LiveInfo static mFirst (Just mapEmpty) Map.empty)
                         lbl []
 
-regLiveness platform (CmmProc info lbl sccs)
+regLiveness _ (CmmProc info lbl sccs)
         | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
-        = let   (ann_sccs, block_live)  = computeLiveness platform sccs
+        = let   (ann_sccs, block_live)  = computeLiveness sccs
 
           in    returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
                            lbl ann_sccs
@@ -746,21 +742,20 @@ reverseBlocksInTops top
 --  want for the next pass.
 --
 computeLiveness
-        :: (PlatformOutputable instr, Instruction instr)
-        => Platform
-        -> [SCC (LiveBasicBlock instr)]
+        :: (Outputable instr, Instruction instr)
+        => [SCC (LiveBasicBlock instr)]
         -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
                                                 -- which are "dead after this instruction".
                BlockMap RegSet)                 -- blocks annontated with set of live registers
                                                 -- on entry to the block.
 
-computeLiveness platform sccs
+computeLiveness sccs
  = case checkIsReverseDependent sccs of
         Nothing         -> livenessSCCs emptyBlockMap [] sccs
         Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
                                 (vcat   [ text "SCCs aren't in reverse dependent order"
                                         , text "bad blockId" <+> ppr bad
-                                        , pprPlatform platform sccs])
+                                        , ppr sccs])
 
 livenessSCCs
        :: Instruction instr
index f02b7a4..74f2019 100644 (file)
@@ -26,7 +26,6 @@ import Size
 
 import OldCmm
 
-import DynFlags
 import OrdList
 import Outputable
 
@@ -62,11 +61,9 @@ getCondCode (CmmMachOp mop [x, y])
       MO_U_Lt _   -> condIntCode LU   x y
       MO_U_Le _   -> condIntCode LEU  x y
 
-      _           -> do dflags <- getDynFlags
-                        pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y]))
+      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))
 
-getCondCode other = do dflags <- getDynFlags
-                       pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other)
+getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)
 
 
 
index 5352281..654875c 100644 (file)
@@ -201,8 +201,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
 
 
 iselExpr64 expr
-   = do dflags <- getDynFlags
-        pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr)
+   = pprPanic "iselExpr64(sparc)" (ppr expr)
 
 
 
index 78dbb1b..3eea016 100644 (file)
@@ -32,7 +32,7 @@ checkBlock :: Platform
            -> NatBasicBlock Instr
            -> NatBasicBlock Instr
 
-checkBlock platform cmm block@(BasicBlock _ instrs)
+checkBlock _ cmm block@(BasicBlock _ instrs)
        | checkBlockInstrs instrs
        = block
        
@@ -40,9 +40,9 @@ checkBlock platform cmm block@(BasicBlock _ instrs)
        = pprPanic 
                ("SPARC.CodeGen: bad block\n")
                ( vcat  [ text " -- cmm -----------------\n"
-                       , pprPlatform platform cmm
+                       , ppr cmm
                        , text " -- native code ---------\n"
-                       , pprPlatform platform block ])
+                       , ppr block ])
 
 
 checkBlockInstrs :: [Instr] -> Bool
index 4d01b1f..7fe1975 100644 (file)
@@ -136,8 +136,8 @@ pprASCII str
 -- -----------------------------------------------------------------------------
 -- pprInstr: print an 'Instr'
 
-instance PlatformOutputable Instr where
-    pprPlatform platform instr = pprInstr platform instr
+instance Outputable Instr where
+    ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr
 
 
 -- | Pretty print a register.
index 4fa4282..68f8adf 100644 (file)
@@ -401,8 +401,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
             )
 
 iselExpr64 expr
-   = do dflags <- getDynFlags
-        pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr)
+   = pprPanic "iselExpr64(i386)" (ppr expr)
 
 
 --------------------------------------------------------------------------------
@@ -888,8 +887,7 @@ getRegister' _ (CmmLit lit)
     in
         return (Any size code)
 
-getRegister' _ other = do dflags <- getDynFlags
-                          pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other)
+getRegister' _ other = pprPanic "getRegister(x86)" (ppr other)
 
 
 intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
@@ -1229,11 +1227,9 @@ getCondCode (CmmMachOp mop [x, y])
       MO_U_Lt _ -> condIntCode LU  x y
       MO_U_Le _ -> condIntCode LEU x y
 
-      _other -> do dflags <- getDynFlags
-                   pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y]))
+      _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
 
-getCondCode other = do dflags <- getDynFlags
-                       pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other)
+getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
 
 
 
index 36593b3..02f8efd 100644 (file)
@@ -158,8 +158,8 @@ pprAlign platform bytes
 -- -----------------------------------------------------------------------------
 -- pprInstr: print an 'Instr'
 
-instance PlatformOutputable Instr where
-    pprPlatform platform instr = pprInstr platform instr
+instance Outputable Instr where
+    ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr
 
 
 pprReg :: Platform -> Size -> Reg -> SDoc
index fa99a75..6934a07 100644 (file)
@@ -23,7 +23,7 @@ import Module
 -- module;
 
 profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc
-profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
+profilingInitCode _ this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
  | not opt_SccProfilingOn = empty
  | otherwise
  = vcat
@@ -39,8 +39,8 @@ profilingInitCode platform this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
    emitRegisterCC cc   =
       ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$
       ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi
-     where cc_lbl = pprPlatform platform (mkCCLabel cc)
+     where cc_lbl = ppr (mkCCLabel cc)
    emitRegisterCCS ccs =
       ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$
       ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi
-     where ccs_lbl = pprPlatform platform (mkCCSLabel ccs)
+     where ccs_lbl = ppr (mkCCSLabel ccs)
index a2b4015..f7bdff2 100644 (file)
@@ -240,9 +240,6 @@ flattenSCC (CyclicSCC vs) = vs
 instance Outputable a => Outputable (SCC a) where
    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
-instance PlatformOutputable a => PlatformOutputable (SCC a) where
-   pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v))
-   pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs)))
 \end{code}
 
 %************************************************************************
index 696d803..7774405 100644 (file)
@@ -13,7 +13,6 @@
 module Outputable (
         -- * Type classes
         Outputable(..), OutputableBndr(..),
-        PlatformOutputable(..),
 
         -- * Pretty printing combinators
         SDoc, runSDoc, initSDocContext,
@@ -57,6 +56,7 @@ module Outputable (
 
         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
         QualifyName(..),
+        sdocWithDynFlags, sdocWithPlatform,
         getPprStyle, withPprStyle, withPprStyleDoc,
         pprDeeper, pprDeeperList, pprSetDepth,
         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
@@ -71,16 +71,16 @@ module Outputable (
         pprDebugAndThen,
     ) where
 
-import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags )
+import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags, targetPlatform )
 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-}   Name( Name, nameModule )
 
 import StaticFlags
 import FastString
 import FastTypes
-import Platform
 import qualified Pretty
 import Util
+import Platform
 import Pretty           ( Doc, Mode(..) )
 import Panic
 
@@ -283,6 +283,12 @@ pprSetDepth depth doc = SDoc $ \ctx ->
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
+
+sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
+sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
+
+sdocWithPlatform :: (Platform -> SDoc) -> SDoc
+sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
 \end{code}
 
 \begin{code}
@@ -599,13 +605,6 @@ class Outputable a where
 
         ppr = pprPrec 0
         pprPrec _ = ppr
-
-class PlatformOutputable a where
-        pprPlatform :: Platform -> a -> SDoc
-        pprPlatformPrec :: Platform -> Rational -> a -> SDoc
-
-        pprPlatform platform = pprPlatformPrec platform 0
-        pprPlatformPrec platform _ = pprPlatform platform
 \end{code}
 
 \begin{code}
@@ -615,8 +614,6 @@ instance Outputable Bool where
 
 instance Outputable Int where
    ppr n = int n
-instance PlatformOutputable Int where
-   pprPlatform _ = ppr
 
 instance Outputable Word16 where
    ppr n = integer $ fromIntegral n
@@ -629,29 +626,19 @@ instance Outputable Word where
 
 instance Outputable () where
    ppr _ = text "()"
-instance PlatformOutputable () where
-   pprPlatform _ _ = text "()"
 
 instance (Outputable a) => Outputable [a] where
     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
-instance (PlatformOutputable a) => PlatformOutputable [a] where
-    pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs)))
 
 instance (Outputable a) => Outputable (Set a) where
     ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
 
 instance (Outputable a, Outputable b) => Outputable (a, b) where
     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
-instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where
-    pprPlatform platform (x,y)
-     = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y])
 
 instance Outputable a => Outputable (Maybe a) where
   ppr Nothing = ptext (sLit "Nothing")
   ppr (Just x) = ptext (sLit "Just") <+> ppr x
-instance PlatformOutputable a => PlatformOutputable (Maybe a) where
-  pprPlatform _        Nothing  = ptext (sLit "Nothing")
-  pprPlatform platform (Just x) = ptext (sLit "Just") <+> pprPlatform platform x
 
 instance (Outputable a, Outputable b) => Outputable (Either a b) where
   ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
@@ -708,8 +695,6 @@ instance Outputable FastString where
 
 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
     ppr m = ppr (M.toList m)
-instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where
-    pprPlatform platform m = pprPlatform platform (M.toList m)
 instance (Outputable elt) => Outputable (IM.IntMap elt) where
     ppr m = ppr (IM.toList m)
 \end{code}