summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/UniqSupply.lhs9
-rw-r--r--compiler/cmm/PprCmm.hs49
-rw-r--r--compiler/cmm/PprCmmDecl.hs16
-rw-r--r--compiler/codeGen/CodeGen.lhs2
-rw-r--r--compiler/deSugar/Coverage.lhs461
-rw-r--r--compiler/main/HscMain.hs5
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs4
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs38
-rw-r--r--compiler/nativeGen/RegAlloc/Liveness.hs6
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs12
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Sanity.hs6
-rw-r--r--compiler/profiling/ProfInit.hs5
12 files changed, 294 insertions, 319 deletions
diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs
index f34172f7b2..bb40be7ac1 100644
--- a/compiler/basicTypes/UniqSupply.lhs
+++ b/compiler/basicTypes/UniqSupply.lhs
@@ -23,7 +23,7 @@ module UniqSupply (
lazyThenUs, lazyMapUs,
-- ** Deprecated operations on 'UniqSM'
- getUniqueUs, getUs, returnUs, thenUs, mapUs
+ getUniqueUs, getUs,
) where
import Unique
@@ -188,13 +188,6 @@ getUniqueUs = USM (\us -> case splitUniqSupply us of
getUniquesUs :: UniqSM [Unique]
getUniquesUs = USM (\us -> case splitUniqSupply us of
(us1,us2) -> (uniqsFromSupply us1, us2))
-
-mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
-mapUs _ [] = returnUs []
-mapUs f (x:xs)
- = f x `thenUs` \ r ->
- mapUs f xs `thenUs` \ rs ->
- returnUs (r:rs)
\end{code}
\begin{code}
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index fd2efdf011..183708c08e 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -48,7 +48,6 @@ import PprCmmExpr
import Util
import BasicTypes
-import Platform
import Compiler.Hoopl
import Data.List
import Prelude hiding (succ)
@@ -60,11 +59,11 @@ instance Outputable CmmStackInfo where
ppr = pprStackInfo
instance Outputable CmmTopInfo where
- ppr x = sdocWithPlatform $ \platform -> pprTopInfo platform x
+ ppr = pprTopInfo
instance Outputable (CmmNode e x) where
- ppr x = sdocWithPlatform $ \platform -> pprNode platform x
+ ppr = pprNode
instance Outputable Convention where
ppr = pprConvention
@@ -73,23 +72,23 @@ instance Outputable ForeignConvention where
ppr = pprForeignConvention
instance Outputable ForeignTarget where
- ppr x = sdocWithPlatform $ \platform -> pprForeignTarget platform x
+ ppr = pprForeignTarget
instance Outputable (Block CmmNode C C) where
- ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
+ ppr = pprBlock
instance Outputable (Block CmmNode C O) where
- ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
+ ppr = pprBlock
instance Outputable (Block CmmNode O C) where
- ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
+ ppr = pprBlock
instance Outputable (Block CmmNode O O) where
- ppr x = sdocWithPlatform $ \platform -> pprBlock platform x
+ ppr = pprBlock
instance Outputable (Graph CmmNode e x) where
- ppr x = sdocWithPlatform $ \platform -> pprGraph platform x
+ ppr = pprGraph
instance Outputable CmmGraph where
- ppr g = sdocWithPlatform $ \platform -> pprCmmGraph platform g
+ ppr = pprCmmGraph
----------------------------------------------------------
-- Outputting types Cmm contains
@@ -99,8 +98,8 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
ptext (sLit "arg_space: ") <> ppr arg_space <+>
ptext (sLit "updfr_space: ") <> ppr updfr_space
-pprTopInfo :: Platform -> CmmTopInfo -> SDoc
-pprTopInfo _ (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
+pprTopInfo :: CmmTopInfo -> SDoc
+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]
@@ -108,8 +107,8 @@ pprTopInfo _ (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
-- Outputting blocks and graphs
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
- => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
-pprBlock _ block
+ => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock block
= foldBlockNodesB3 ( ($$) . ppr
, ($$) . (nest 4) . ppr
, ($$) . (nest 4) . ppr
@@ -117,10 +116,10 @@ pprBlock _ block
block
empty
-pprGraph :: Platform -> Graph CmmNode e x -> SDoc
-pprGraph _ GNil = empty
-pprGraph _ (GUnit block) = ppr block
-pprGraph _ (GMany entry body exit)
+pprGraph :: Graph CmmNode e x -> SDoc
+pprGraph GNil = empty
+pprGraph (GUnit block) = ppr block
+pprGraph (GMany entry body exit)
= text "{"
$$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
$$ text "}"
@@ -129,8 +128,8 @@ pprGraph _ (GMany entry body exit)
pprMaybeO NothingO = empty
pprMaybeO (JustO block) = ppr block
-pprCmmGraph :: Platform -> CmmGraph -> SDoc
-pprCmmGraph _ g
+pprCmmGraph :: CmmGraph -> SDoc
+pprCmmGraph g
= text "{" <> text "offset"
$$ nest 2 (vcat $ map ppr blocks)
$$ text "}"
@@ -153,8 +152,8 @@ pprConvention (Private {}) = text "<private-convention>"
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
-pprForeignTarget :: Platform -> ForeignTarget -> SDoc
-pprForeignTarget _ (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
+pprForeignTarget :: ForeignTarget -> SDoc
+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
@@ -162,7 +161,7 @@ pprForeignTarget _ (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
ppr_target t@(CmmLit _) = ppr t
ppr_target fn' = parens (ppr fn')
-pprForeignTarget _ (PrimTarget op)
+pprForeignTarget (PrimTarget op)
-- HACK: We're just using a ForeignLabel to get this printed, the label
-- might not really be foreign.
= ppr
@@ -170,8 +169,8 @@ pprForeignTarget _ (PrimTarget op)
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction))
-pprNode :: Platform -> CmmNode e x -> SDoc
-pprNode _ node = pp_node <+> pp_debug
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
where
pp_node :: SDoc
pp_node = case node of
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 80c5b813ce..41653dcd9f 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -62,15 +62,14 @@ import SMRep
pprCmms :: (Outputable info, Outputable g)
- => Platform -> [GenCmmGroup CmmStatics info g] -> SDoc
-pprCmms _ cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+ => [GenCmmGroup CmmStatics info g] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext (sLit "-------------------") $$ space
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
+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
-----------------------------------------------------------------------------
@@ -85,7 +84,7 @@ instance Outputable CmmStatic where
ppr x = sdocWithPlatform $ \platform -> pprStatic platform x
instance Outputable CmmInfoTable where
- ppr x = sdocWithPlatform $ \platform -> pprInfoTable platform x
+ ppr = pprInfoTable
-----------------------------------------------------------------------------
@@ -120,11 +119,10 @@ pprTop _ (CmmData section ds) =
-- --------------------------------------------------------------------------
-- Info tables.
-pprInfoTable :: Platform -> CmmInfoTable -> SDoc
-pprInfoTable _ CmmNonInfoTable
+pprInfoTable :: CmmInfoTable -> SDoc
+pprInfoTable CmmNonInfoTable
= empty
-pprInfoTable _
- (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, cit_prof = prof_info
, cit_srt = _srt })
= vcat [ ptext (sLit "label:") <+> ppr lbl
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 24ac064256..ce12d43bbf 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -77,7 +77,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do
-- initialisation routines; see Note
-- [pipeline-split-init].
- dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff)
+ dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
return code_stuff
mkModuleInit
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index d9d1718177..fa7c343fac 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -3,13 +3,6 @@
% (c) University of Glasgow, 2007
%
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module Coverage (addTicksToBinds, hpcInitCode) where
import Type
@@ -29,7 +22,7 @@ import Id
import VarSet
import Data.List
import FastString
-import HscTypes
+import HscTypes
import Platform
import StaticFlags
import TyCon
@@ -47,7 +40,7 @@ import System.Directory
import Trace.Hpc.Mix
import Trace.Hpc.Util
-import BreakArray
+import BreakArray
import Data.HashTable ( hashString )
import Data.Map (Map)
import qualified Data.Map as Map
@@ -55,9 +48,9 @@ import qualified Data.Map as Map
%************************************************************************
-%* *
+%* *
%* The main function: addTicksToBinds
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -81,15 +74,15 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
if "boot" `isSuffixOf` orig_file
then return (binds, emptyHpcInfo False, emptyModBreaks)
else do
-
+
let orig_file2 = guessSourceFile binds orig_file
(binds1,_,st)
- = unTM (addTickLHsBinds binds)
- (TTE
+ = unTM (addTickLHsBinds binds)
+ (TTE
{ fileName = mkFastString orig_file2
- , declPath = []
- , dflags = dflags
+ , declPath = []
+ , tte_dflags = dflags
, exports = exports
, inScope = emptyVarSet
, blackList = Map.fromList
@@ -98,10 +91,10 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
, density = mkDensity dflags
, this_mod = mod
})
- (TT
- { tickBoxCount = 0
- , mixEntries = []
- })
+ (TT
+ { tickBoxCount = 0
+ , mixEntries = []
+ })
let entries = reverse $ mixEntries st
@@ -112,7 +105,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
doIfSet_dyn dflags Opt_D_dump_ticked $
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
-
+
return (binds1, HpcInfo count hashNo, modBreaks)
@@ -136,12 +129,12 @@ mkModBreaks count entries = do
locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
- modBreaks = emptyModBreaks
- { modBreaks_flags = breakArray
- , modBreaks_locs = locsTicks
+ modBreaks = emptyModBreaks
+ { modBreaks_flags = breakArray
+ , modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
- }
+ }
--
return modBreaks
@@ -157,17 +150,17 @@ writeMixEntries dflags mod count entries filename
hpc_mod_dir
| modulePackageId mod == mainPackageId = hpc_dir
| otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
-
+
tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationUTCTime filename
- let entries' = [ (hpcPos, box)
+ let entries' = [ (hpcPos, box)
| (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
when (length entries' /= count) $ do
panic "the number of .mix entries are inconsistent"
let hashNo = mixHash filename modTime tabStop entries'
- mixCreate hpc_mod_dir mod_name
+ mixCreate hpc_mod_dir mod_name
$ Mix filename modTime (toHash hashNo) tabStop entries'
return hashNo
@@ -256,7 +249,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
- (fvs, (MatchGroup matches' ty)) <-
+ (fvs, (MatchGroup matches' ty)) <-
getFreeVars $
addPathEntry name $
addTickMatchGroup False (fun_matches funBind)
@@ -389,7 +382,7 @@ addTickLHsExprLetBody e@(L pos e0) = do
dont_tick_it = addTickLHsExprNever e
-- version of addTick that does not actually add a tick,
--- because the scope of this tick is completely subsumed by
+-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
@@ -407,7 +400,7 @@ isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {}) = True
isGoodBreakExpr (PArrSeq {}) = True
-isGoodBreakExpr _other = False
+isGoodBreakExpr _other = False
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{} = True
@@ -438,108 +431,108 @@ addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) =
liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsApp e1 e2) =
- liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
-addTickHsExpr (OpApp e1 e2 fix e3) =
- liftM4 OpApp
- (addTickLHsExpr e1)
- (addTickLHsExprNever e2)
- (return fix)
+ liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
+addTickHsExpr (OpApp e1 e2 fix e3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsExprNever e2)
+ (return fix)
(addTickLHsExpr e3)
addTickHsExpr (NegApp e neg) =
- liftM2 NegApp
- (addTickLHsExpr e)
- (addTickSyntaxExpr hpcSrcSpan neg)
+ liftM2 NegApp
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan neg)
addTickHsExpr (HsPar e) =
liftM HsPar (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) =
- liftM2 SectionL
- (addTickLHsExpr e1)
+ liftM2 SectionL
+ (addTickLHsExpr e1)
(addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
- liftM2 SectionR
+addTickHsExpr (SectionR e1 e2) =
+ liftM2 SectionR
(addTickLHsExprNever e1)
- (addTickLHsExpr e2)
+ (addTickLHsExpr e2)
addTickHsExpr (ExplicitTuple es boxity) =
liftM2 ExplicitTuple
(mapM addTickTupArg es)
(return boxity)
-addTickHsExpr (HsCase e mgs) =
- liftM2 HsCase
+addTickHsExpr (HsCase e mgs) =
+ liftM2 HsCase
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated.
(addTickMatchGroup False mgs)
-addTickHsExpr (HsIf cnd e1 e2 e3) =
- liftM3 (HsIf cnd)
- (addBinTickLHsExpr (BinBox CondBinBox) e1)
- (addTickLHsExprOptAlt True e2)
- (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsIf cnd e1 e2 e3) =
+ liftM3 (HsIf cnd)
+ (addBinTickLHsExpr (BinBox CondBinBox) e1)
+ (addTickLHsExprOptAlt True e2)
+ (addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
- bindLocals (collectLocalBinders binds) $
- liftM2 HsLet
- (addTickHsLocalBinds binds) -- to think about: !patterns.
+ bindLocals (collectLocalBinders binds) $
+ liftM2 HsLet
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo cxt stmts srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt stmts' srcloc) }
where
- forQual = case cxt of
- ListComp -> Just $ BinBox QualBinBox
- _ -> Nothing
-addTickHsExpr (ExplicitList ty es) =
- liftM2 ExplicitList
- (return ty)
- (mapM (addTickLHsExpr) es)
+ forQual = case cxt of
+ ListComp -> Just $ BinBox QualBinBox
+ _ -> Nothing
+addTickHsExpr (ExplicitList ty es) =
+ liftM2 ExplicitList
+ (return ty)
+ (mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitPArr ty es) =
- liftM2 ExplicitPArr
- (return ty)
- (mapM (addTickLHsExpr) es)
-addTickHsExpr (RecordCon id ty rec_binds) =
- liftM3 RecordCon
- (return id)
- (return ty)
- (addTickHsRecordBinds rec_binds)
+ liftM2 ExplicitPArr
+ (return ty)
+ (mapM (addTickLHsExpr) es)
+addTickHsExpr (RecordCon id ty rec_binds) =
+ liftM3 RecordCon
+ (return id)
+ (return ty)
+ (addTickHsRecordBinds rec_binds)
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
- liftM5 RecordUpd
- (addTickLHsExpr e)
- (addTickHsRecordBinds rec_binds)
- (return cons) (return tys1) (return tys2)
+ liftM5 RecordUpd
+ (addTickLHsExpr e)
+ (addTickHsRecordBinds rec_binds)
+ (return cons) (return tys1) (return tys2)
addTickHsExpr (ExprWithTySigOut e ty) =
- liftM2 ExprWithTySigOut
- (addTickLHsExprNever e) -- No need to tick the inner expression
- -- for expressions with signatures
- (return ty)
-addTickHsExpr (ArithSeq ty arith_seq) =
- liftM2 ArithSeq
- (return ty)
- (addTickArithSeqInfo arith_seq)
+ liftM2 ExprWithTySigOut
+ (addTickLHsExprNever e) -- No need to tick the inner expression
+ -- for expressions with signatures
+ (return ty)
+addTickHsExpr (ArithSeq ty arith_seq) =
+ liftM2 ArithSeq
+ (return ty)
+ (addTickArithSeqInfo arith_seq)
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
-addTickHsExpr (PArrSeq ty arith_seq) =
- liftM2 PArrSeq
- (return ty)
- (addTickArithSeqInfo arith_seq)
+addTickHsExpr (PArrSeq ty arith_seq) =
+ liftM2 PArrSeq
+ (return ty)
+ (addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC nm e) =
- liftM2 HsSCC
+ liftM2 HsSCC
(return nm)
(addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn nm e) =
- liftM2 HsCoreAnn
+addTickHsExpr (HsCoreAnn nm e) =
+ liftM2 HsCoreAnn
(return nm)
(addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
- liftM2 HsProc
- (addTickLPat pat)
- (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
- liftM2 HsWrap
- (return w)
- (addTickHsExpr e) -- explicitly no tick on inside
+ liftM2 HsProc
+ (addTickLPat pat)
+ (liftL (addTickHsCmdTop) cmdtop)
+addTickHsExpr (HsWrap w e) =
+ liftM2 HsWrap
+ (return w)
+ (addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
@@ -594,36 +587,36 @@ addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
- = bindLocals (collectLStmtsBinders lstmts) $
+ = bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt _isGuard (LastStmt e ret) = do
- liftM2 LastStmt
- (addTickLHsExpr e)
- (addTickSyntaxExpr hpcSrcSpan ret)
+ liftM2 LastStmt
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
- liftM4 BindStmt
- (addTickLPat pat)
- (addTickLHsExprRHS e)
- (addTickSyntaxExpr hpcSrcSpan bind)
- (addTickSyntaxExpr hpcSrcSpan fail)
+ liftM4 BindStmt
+ (addTickLPat pat)
+ (addTickLHsExprRHS e)
+ (addTickSyntaxExpr hpcSrcSpan bind)
+ (addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
- liftM4 ExprStmt
- (addTick isGuard e)
- (addTickSyntaxExpr hpcSrcSpan bind')
- (addTickSyntaxExpr hpcSrcSpan guard')
- (return ty)
+ liftM4 ExprStmt
+ (addTick isGuard e)
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
+ (return ty)
addTickStmt _isGuard (LetStmt binds) = do
- liftM LetStmt
- (addTickHsLocalBinds binds)
+ liftM LetStmt
+ (addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
- liftM3 ParStmt
+ liftM3 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
(addTickSyntaxExpr hpcSrcSpan mzipExpr)
(addTickSyntaxExpr hpcSrcSpan bindExpr)
@@ -655,108 +648,108 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
-> TM (ParStmtBlock Id Id)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
- liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
+ liftM3 ParStmtBlock
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
-addTickHsLocalBinds (HsValBinds binds) =
- liftM HsValBinds
- (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds binds) =
- liftM HsIPBinds
- (addTickHsIPBinds binds)
+addTickHsLocalBinds (HsValBinds binds) =
+ liftM HsValBinds
+ (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds binds) =
+ liftM HsIPBinds
+ (addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
addTickHsValBinds (ValBindsOut binds sigs) =
- liftM2 ValBindsOut
- (mapM (\ (rec,binds') ->
- liftM2 (,)
- (return rec)
- (addTickLHsBinds binds'))
- binds)
- (return sigs)
+ liftM2 ValBindsOut
+ (mapM (\ (rec,binds') ->
+ liftM2 (,)
+ (return rec)
+ (addTickLHsBinds binds'))
+ binds)
+ (return sigs)
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
- liftM2 IPBinds
- (mapM (liftL (addTickIPBind)) ipbinds)
- (return dictbinds)
+ liftM2 IPBinds
+ (mapM (liftL (addTickIPBind)) ipbinds)
+ (return dictbinds)
addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
- liftM2 IPBind
- (return nm)
- (addTickLHsExpr e)
+ liftM2 IPBind
+ (return nm)
+ (addTickLHsExpr e)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
addTickSyntaxExpr pos x = do
- L _ x' <- addTickLHsExpr (L pos x)
- return $ x'
+ L _ x' <- addTickLHsExpr (L pos x)
+ return $ x'
-- we do not walk into patterns.
addTickLPat :: LPat Id -> TM (LPat Id)
addTickLPat pat = return pat
addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
- liftM4 HsCmdTop
- (addTickLHsCmd cmd)
- (return tys)
- (return ty)
- (return syntaxtable)
+ liftM4 HsCmdTop
+ (addTickLHsCmd cmd)
+ (return tys)
+ (return ty)
+ (return syntaxtable)
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
addTickLHsCmd (L pos c0) = do
c1 <- addTickHsCmd c0
- return $ L pos c1
+ return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
liftM HsLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsApp c e) =
- liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
-addTickHsCmd (OpApp e1 c2 fix c3) =
- liftM4 OpApp
- (addTickLHsExpr e1)
- (addTickLHsCmd c2)
- (return fix)
- (addTickLHsCmd c3)
+addTickHsCmd (HsApp c e) =
+ liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (OpApp e1 c2 fix c3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsCmd c2)
+ (return fix)
+ (addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
-addTickHsCmd (HsCase e mgs) =
- liftM2 HsCase
- (addTickLHsExpr e)
- (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsIf cnd e1 c2 c3) =
- liftM3 (HsIf cnd)
- (addBinTickLHsExpr (BinBox CondBinBox) e1)
- (addTickLHsCmd c2)
- (addTickLHsCmd c3)
+addTickHsCmd (HsCase e mgs) =
+ liftM2 HsCase
+ (addTickLHsExpr e)
+ (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsIf cnd e1 c2 c3) =
+ liftM3 (HsIf cnd)
+ (addBinTickLHsExpr (BinBox CondBinBox) e1)
+ (addTickLHsCmd c2)
+ (addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
- bindLocals (collectLocalBinders binds) $
- liftM2 HsLet
- (addTickHsLocalBinds binds) -- to think about: !patterns.
+ bindLocals (collectLocalBinders binds) $
+ liftM2 HsLet
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
-addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
- (return ty1)
- (return arr_ty)
- (return lr)
-addTickHsCmd (HsArrForm e fix cmdtop) =
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (return ty1)
+ (return arr_ty)
+ (return lr)
+addTickHsCmd (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
- (addTickLHsExpr e)
- (return fix)
- (mapM (liftL (addTickHsCmdTop)) cmdtop)
+ (addTickLHsExpr e)
+ (return fix)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
-- Others should never happen in a command context.
addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
@@ -785,7 +778,7 @@ addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
- = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
stmts (addTickLHsCmd cmd)
; return $ GRHS stmts' expr' }
@@ -805,24 +798,24 @@ addTickLCmdStmts' lstmts res
addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt (BindStmt pat c bind fail) = do
- liftM4 BindStmt
- (addTickLPat pat)
- (addTickLHsCmd c)
- (return bind)
- (return fail)
+ liftM4 BindStmt
+ (addTickLPat pat)
+ (addTickLHsCmd c)
+ (return bind)
+ (return fail)
addTickCmdStmt (LastStmt c ret) = do
- liftM2 LastStmt
- (addTickLHsCmd c)
- (addTickSyntaxExpr hpcSrcSpan ret)
+ liftM2 LastStmt
+ (addTickLHsCmd c)
+ (addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
- liftM4 ExprStmt
- (addTickLHsCmd c)
- (addTickSyntaxExpr hpcSrcSpan bind')
+ liftM4 ExprStmt
+ (addTickLHsCmd c)
+ (addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
- (return ty)
+ (return ty)
addTickCmdStmt (LetStmt binds) = do
- liftM LetStmt
- (addTickHsLocalBinds binds)
+ liftM LetStmt
+ (addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
@@ -835,31 +828,31 @@ addTickCmdStmt stmt@(RecStmt {})
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
-addTickHsRecordBinds (HsRecFields fields dd)
- = do { fields' <- mapM process fields
- ; return (HsRecFields fields' dd) }
+addTickHsRecordBinds (HsRecFields fields dd)
+ = do { fields' <- mapM process fields
+ ; return (HsRecFields fields' dd) }
where
process (HsRecField ids expr doc)
- = do { expr' <- addTickLHsExpr expr
- ; return (HsRecField ids expr' doc) }
+ = do { expr' <- addTickLHsExpr expr
+ ; return (HsRecField ids expr' doc) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
- liftM From
- (addTickLHsExpr e1)
+ liftM From
+ (addTickLHsExpr e1)
addTickArithSeqInfo (FromThen e1 e2) =
- liftM2 FromThen
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
+ liftM2 FromThen
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
addTickArithSeqInfo (FromTo e1 e2) =
- liftM2 FromTo
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
+ liftM2 FromTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
- liftM3 FromThenTo
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
- (addTickLHsExpr e3)
+ liftM3 FromThenTo
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (addTickLHsExpr e3)
liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
@@ -870,11 +863,11 @@ liftL f (L loc a) = do
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry_]
- }
+ }
data TickTransEnv = TTE { fileName :: FastString
, density :: TickDensity
- , dflags :: DynFlags
+ , tte_dflags :: DynFlags
, exports :: NameSet
, declPath :: [String]
, inScope :: VarSet
@@ -882,7 +875,7 @@ data TickTransEnv = TTE { fileName :: FastString
, this_mod :: Module
}
--- deriving Show
+-- deriving Show
type FreeVars = OccEnv Id
noFVs :: FreeVars
@@ -906,11 +899,11 @@ data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTrans
instance Monad TM where
return a = TM $ \ _env st -> (a,noFVs,st)
- (TM m) >>= k = TM $ \ env st ->
- case m env st of
- (r1,fv1,st1) ->
+ (TM m) >>= k = TM $ \ env st ->
+ case m env st of
+ (r1,fv1,st1) ->
case unTM (k r1) env st1 of
- (r2,fv2,st2) ->
+ (r2,fv2,st2) ->
(r2, fv1 `plusOccEnv` fv2, st2)
-- getState :: TM TickTransState
@@ -923,8 +916,8 @@ getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)
withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
-withEnv f (TM m) = TM $ \ env st ->
- case m (f env) st of
+withEnv f (TM m) = TM $ \ env st ->
+ case m (f env) st of
(a, fvs, st') -> (a, fvs, st')
getDensity :: TM TickDensity
@@ -934,11 +927,11 @@ ifDensity :: TickDensity -> TM a -> TM a -> TM a
ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
getFreeVars :: TM a -> TM (FreeVars, a)
-getFreeVars (TM m)
+getFreeVars (TM m)
= TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
freeVar :: Id -> TM ()
-freeVar id = TM $ \ env st ->
+freeVar id = TM $ \ env st ->
if id `elemVarSet` inScope env
then ((), unitOccEnv (nameOccName (idName id)) id, st)
else ((), noFVs, st)
@@ -955,26 +948,26 @@ getFileName = fileName `liftM` getEnv
sameFileName :: SrcSpan -> TM a -> TM a -> TM a
sameFileName pos out_of_scope in_scope = do
file_name <- getFileName
- case srcSpanFileName_maybe pos of
- Just file_name2
+ case srcSpanFileName_maybe pos of
+ Just file_name2
| file_name == file_name2 -> in_scope
_ -> out_of_scope
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
- = TM $ \ env st ->
+ = TM $ \ env st ->
case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
(r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
- where occs = [ nameOccName (idName id) | id <- new_ids ]
+ where occs = [ nameOccName (idName id) | id <- new_ids ]
isBlackListed :: SrcSpan -> TM Bool
-isBlackListed pos = TM $ \ env st ->
- case Map.lookup pos (blackList env) of
- Nothing -> (False,noFVs,st)
- Just () -> (True,noFVs,st)
+isBlackListed pos = TM $ \ env st ->
+ case Map.lookup pos (blackList env) of
+ Nothing -> (False,noFVs,st)
+ Just () -> (True,noFVs,st)
-- the tick application inherits the source position of its
--- expression argument to support nested box allocations
+-- expression argument to support nested box allocations
allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
-> TM (LHsExpr Id)
allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
@@ -989,7 +982,7 @@ allocTickBox _boxLabel _countEntries _topOnly pos m = do
-- the tick application inherits the source position of its
--- expression argument to support nested box allocations
+-- expression argument to support nested box allocations
allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
-> TM (Maybe (Tickish Id))
allocATickBox boxLabel countEntries topOnly pos fvs | isGoodSrcSpan' pos =
@@ -1025,7 +1018,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
- count = countEntries && dopt Opt_ProfCountEntries (dflags env)
+ count = countEntries && dopt Opt_ProfCountEntries (tte_dflags env)
tickish
| opt_Hpc = HpcTick (this_mod env) c
@@ -1051,7 +1044,7 @@ allocBinTickBox boxLabel pos m
meE = (pos,declPath env, [],ExpBox False)
c = tickBoxCount st
mes = mixEntries st
- in
+ in
( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-- notice that F and T are reversed,
-- because we are building the list in
@@ -1087,14 +1080,14 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
- matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
+ matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
\end{code}
\begin{code}
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
--- For the hash value, we hash everything: the file name,
+-- For the hash value, we hash everything: the file name,
-- the timestamp of the original source file, the tab stop,
-- and the mix entries. We cheat, and hash the show'd string.
-- This hash only has to be hashed at Mix creation time,
@@ -1102,13 +1095,13 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
mixHash file tm tabstop entries = fromIntegral $ hashString
- (show $ Mix file tm 0 tabstop entries)
+ (show $ Mix file tm 0 tabstop entries)
\end{code}
%************************************************************************
-%* *
+%* *
%* initialisation
-%* *
+%* *
%************************************************************************
Each module compiled with -fhpc declares an initialisation function of
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 0c0b3d9097..df85d06f1b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1266,7 +1266,7 @@ hscGenHardCode cgguts mod_summary = do
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
- let prof_init = profilingInitCode platform this_mod cost_centre_info
+ let prof_init = profilingInitCode this_mod cost_centre_info
foreign_stubs = foreign_stubs0 `appendStubC` prof_init
------------------ Code generation ------------------
@@ -1355,11 +1355,10 @@ 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 platform prog)
+ (pprCmms 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.
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 15dd2dc90a..93e282ffe6 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -375,7 +375,7 @@ cmmNativeGen dflags ncgImpl us cmm count
let (withLiveness, usLive) =
{-# SCC "regLiveness" #-}
initUs usGen
- $ mapUs regLiveness
+ $ mapM regLiveness
$ map natCmmTopToLive native
dumpIfSet_dyn dflags
@@ -434,7 +434,7 @@ cmmNativeGen dflags ncgImpl us cmm count
= {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
- $ mapUs (Linear.regAlloc dflags) withLiveness
+ $ mapM (Linear.regAlloc dflags) withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 9f366b9945..dcc348a6fc 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -63,7 +63,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
pprSectionHeader platform Text $$
(
(if platformHasSubsectionsViaSymbols platform
- then pprCLabel platform (mkDeadStripPreventer info_lbl) <> char ':'
+ then ppr (mkDeadStripPreventer info_lbl) <> char ':'
else empty) $$
vcat (map (pprData platform) info) $$
pprLabel platform info_lbl
@@ -80,9 +80,9 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
-- so that the linker will not think it is unreferenced and dead-strip
-- it. That's why the label is called a DeadStripPreventer (_dsp).
text "\t.long "
- <+> pprCLabel platform info_lbl
+ <+> ppr info_lbl
<+> char '-'
- <+> pprCLabel platform (mkDeadStripPreventer info_lbl)
+ <+> ppr (mkDeadStripPreventer info_lbl)
else empty)
@@ -104,23 +104,23 @@ pprData platform (CmmUninitialised bytes) = ptext (sLit keyword) <> int bytes
_ -> ".skip "
pprData platform (CmmStaticLit lit) = pprDataItem platform lit
-pprGloblDecl :: Platform -> CLabel -> SDoc
-pprGloblDecl platform lbl
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
| not (externallyVisibleCLabel lbl) = empty
- | otherwise = ptext (sLit ".globl ") <> pprCLabel platform lbl
+ | otherwise = ptext (sLit ".globl ") <> ppr lbl
pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc
pprTypeAndSizeDecl platform lbl
| platformOS platform == OSLinux && externallyVisibleCLabel lbl
= ptext (sLit ".type ") <>
- pprCLabel platform lbl <> ptext (sLit ", @object")
+ ppr lbl <> ptext (sLit ", @object")
pprTypeAndSizeDecl _ _
= empty
pprLabel :: Platform -> CLabel -> SDoc
-pprLabel platform lbl = pprGloblDecl platform lbl
+pprLabel platform lbl = pprGloblDecl lbl
$$ pprTypeAndSizeDecl platform lbl
- $$ (pprCLabel platform lbl <> char ':')
+ $$ (ppr lbl <> char ':')
pprASCII :: [Word8] -> SDoc
@@ -223,8 +223,8 @@ pprImm :: Platform -> Imm -> SDoc
pprImm _ (ImmInt i) = int i
pprImm _ (ImmInteger i) = integer i
-pprImm platform (ImmCLbl l) = pprCLabel platform l
-pprImm platform (ImmIndex l i) = pprCLabel platform l <> char '+' <> int i
+pprImm _ (ImmCLbl l) = ppr l
+pprImm _ (ImmIndex l i) = ppr l <> char '+' <> int i
pprImm _ (ImmLit s) = s
pprImm _ (ImmFloat _) = ptext (sLit "naughty float immediate")
@@ -466,16 +466,16 @@ pprInstr platform (CMPL sz reg ri) = hcat [
RIReg _ -> empty
RIImm _ -> char 'i'
]
-pprInstr platform (BCC cond blockid) = hcat [
+pprInstr _ (BCC cond blockid) = hcat [
char '\t',
ptext (sLit "b"),
pprCond cond,
char '\t',
- pprCLabel platform lbl
+ ppr lbl
]
where lbl = mkAsmTempLabel (getUnique blockid)
-pprInstr platform (BCCFAR cond blockid) = vcat [
+pprInstr _ (BCCFAR cond blockid) = vcat [
hcat [
ptext (sLit "\tb"),
pprCond (condNegate cond),
@@ -483,16 +483,16 @@ pprInstr platform (BCCFAR cond blockid) = vcat [
],
hcat [
ptext (sLit "\tb\t"),
- pprCLabel platform lbl
+ ppr lbl
]
]
where lbl = mkAsmTempLabel (getUnique blockid)
-pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
+pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
char '\t',
ptext (sLit "b"),
char '\t',
- pprCLabel platform lbl
+ ppr lbl
]
pprInstr platform (MTCTR reg) = hcat [
@@ -505,9 +505,9 @@ pprInstr _ (BCTR _ _) = hcat [
char '\t',
ptext (sLit "bctr")
]
-pprInstr platform (BL lbl _) = hcat [
+pprInstr _ (BL lbl _) = hcat [
ptext (sLit "\tbl\t"),
- pprCLabel platform lbl
+ ppr lbl
]
pprInstr _ (BCTRL _) = hcat [
char '\t',
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 88023ec47f..5ceee3e242 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -667,11 +667,11 @@ regLiveness
-> UniqSM (LiveCmmDecl statics instr)
regLiveness (CmmData i d)
- = returnUs $ CmmData i d
+ = return $ CmmData i d
regLiveness (CmmProc info lbl [])
| LiveInfo static mFirst _ _ <- info
- = returnUs $ CmmProc
+ = return $ CmmProc
(LiveInfo static mFirst (Just mapEmpty) Map.empty)
lbl []
@@ -679,7 +679,7 @@ regLiveness (CmmProc info lbl sccs)
| LiveInfo static mFirst _ liveSlotsOnEntry <- info
= let (ann_sccs, block_live) = computeLiveness sccs
- in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
+ in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
lbl ann_sccs
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 0f3041e9a9..e0656db9db 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -61,10 +61,7 @@ cmmTopCodeGen :: RawCmmDecl
-> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab (ListGraph blocks))
- = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
- (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks
+ = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
let tops = proc : concat statics
@@ -80,12 +77,11 @@ cmmTopCodeGen (CmmData sec dat) = do
-- are indicated by the NEWBLOCK instruction. We must split up the
-- instruction stream into basic blocks again. Also, we extract
-- LDATAs here too.
-basicBlockCodeGen :: Platform
- -> CmmBasicBlock
+basicBlockCodeGen :: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl CmmStatics Instr])
-basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do
+basicBlockCodeGen cmm@(BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
let
(top,other_blocks,statics)
@@ -102,7 +98,7 @@ basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do
-- do intra-block sanity checking
blocksChecked
- = map (checkBlock platform cmm)
+ = map (checkBlock cmm)
$ BasicBlock id top : other_blocks
return (blocksChecked, statics)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
index 3eea016124..7eb8bb4a53 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -22,17 +22,15 @@ import Instruction
import OldCmm
import Outputable
-import Platform
-- | Enforce intra-block invariants.
--
-checkBlock :: Platform
- -> CmmBasicBlock
+checkBlock :: CmmBasicBlock
-> NatBasicBlock Instr
-> NatBasicBlock Instr
-checkBlock _ cmm block@(BasicBlock _ instrs)
+checkBlock cmm block@(BasicBlock _ instrs)
| checkBlockInstrs instrs
= block
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
index 6934a079b5..7e223f80e9 100644
--- a/compiler/profiling/ProfInit.hs
+++ b/compiler/profiling/ProfInit.hs
@@ -11,7 +11,6 @@ module ProfInit (profilingInitCode) where
import CLabel
import CostCentre
import Outputable
-import Platform
import StaticFlags
import FastString
import Module
@@ -22,8 +21,8 @@ import Module
-- We must produce declarations for the cost-centres defined in this
-- module;
-profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc
-profilingInitCode _ this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
+profilingInitCode :: Module -> CollectedCCs -> SDoc
+profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
| not opt_SccProfilingOn = empty
| otherwise
= vcat
View Lorry Controller Status