summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs49
-rw-r--r--compiler/cmm/Cmm.hs4
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs10
-rw-r--r--compiler/cmm/CmmCvt.hs17
-rw-r--r--compiler/cmm/CmmDecl.hs15
-rw-r--r--compiler/cmm/CmmInfo.hs12
-rw-r--r--compiler/cmm/CmmLint.hs24
-rw-r--r--compiler/cmm/CmmOpt.hs11
-rw-r--r--compiler/cmm/CmmParse.y43
-rw-r--r--compiler/cmm/CmmPipeline.hs35
-rw-r--r--compiler/cmm/CmmProcPoint.hs13
-rw-r--r--compiler/cmm/OldCmm.hs13
-rw-r--r--compiler/cmm/OldPprCmm.hs19
-rw-r--r--compiler/cmm/PprC.hs30
-rw-r--r--compiler/cmm/PprCmm.hs49
-rw-r--r--compiler/cmm/PprCmmDecl.hs54
16 files changed, 214 insertions, 184 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 3451c7d5a9..8828adb0d0 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -100,6 +100,7 @@ module CLabel (
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
+ localiseLabel,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
@@ -278,11 +279,14 @@ pprDebugCLabel lbl
_ -> ppr lbl <> (parens $ text "other CLabel)")
+-- True if a local IdLabel that we won't mark as exported
+type IsLocal = Bool
+
data IdLabelInfo
= Closure -- ^ Label for closure
| SRT -- ^ Static reference table
- | InfoTable -- ^ Info tables for closures; always read-only
- | Entry -- ^ Entry point
+ | InfoTable IsLocal -- ^ Info tables for closures; always read-only
+ | Entry IsLocal -- ^ Entry point
| Slow -- ^ Slow entry point
| RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id
@@ -356,13 +360,13 @@ mkRednCountsLabel name c = IdLabel name c RednCounts
-- These have local & (possibly) external variants:
mkLocalClosureLabel name c = IdLabel name c Closure
-mkLocalInfoTableLabel name c = IdLabel name c InfoTable
-mkLocalEntryLabel name c = IdLabel name c Entry
+mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True)
+mkLocalEntryLabel name c = IdLabel name c (Entry True)
mkLocalClosureTableLabel name c = IdLabel name c ClosureTable
mkClosureLabel name c = IdLabel name c Closure
-mkInfoTableLabel name c = IdLabel name c InfoTable
-mkEntryLabel name c = IdLabel name c Entry
+mkInfoTableLabel name c = IdLabel name c (InfoTable False)
+mkEntryLabel name c = IdLabel name c (Entry False)
mkClosureTableLabel name c = IdLabel name c ClosureTable
mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
mkLocalConEntryLabel c con = IdLabel con c ConEntry
@@ -498,7 +502,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-- Converting between info labels and entry/ret labels.
infoLblToEntryLbl :: CLabel -> CLabel
-infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
+infoLblToEntryLbl (IdLabel n c (InfoTable lcl)) = IdLabel n c (Entry lcl)
infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
@@ -509,7 +513,7 @@ infoLblToEntryLbl _
entryLblToInfoLbl :: CLabel -> CLabel
-entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
+entryLblToInfoLbl (IdLabel n c (Entry lcl)) = IdLabel n c (InfoTable lcl)
entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
@@ -519,8 +523,8 @@ entryLblToInfoLbl l
= pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
-cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
-cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c (InfoTable _)) = IdLabel n c Closure
+cvtToClosureLbl (IdLabel n c (Entry _)) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure
cvtToClosureLbl l@(IdLabel n c Closure) = l
@@ -528,13 +532,18 @@ cvtToClosureLbl l
= pprPanic "cvtToClosureLbl" (pprCLabel l)
-cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c
-cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c (InfoTable _)) = mkSRTLabel n c
+cvtToSRTLbl (IdLabel n c (Entry _)) = mkSRTLabel n c
cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c
cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c
cvtToSRTLbl l
= pprPanic "cvtToSRTLbl" (pprCLabel l)
+localiseLabel :: CLabel -> CLabel
+localiseLabel (IdLabel n c (Entry _)) = IdLabel n c (Entry True)
+localiseLabel (IdLabel n c (InfoTable _)) = IdLabel n c (InfoTable True)
+localiseLabel l = l
+
-- -----------------------------------------------------------------------------
-- Does a CLabel refer to a CAF?
@@ -691,7 +700,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (CmmLabel _ _ _) = True
externallyVisibleCLabel (ForeignLabel{}) = True
-externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
+externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
@@ -699,6 +708,12 @@ externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
+externallyVisibleIdLabel :: IdLabelInfo -> Bool
+externallyVisibleIdLabel SRT = False
+externallyVisibleIdLabel (Entry lcl) = not lcl
+externallyVisibleIdLabel (InfoTable lcl) = not lcl
+externallyVisibleIdLabel _ = True
+
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
@@ -744,7 +759,7 @@ labelType _ = DataLabel
idInfoLabelType info =
case info of
- InfoTable -> DataLabel
+ InfoTable _ -> DataLabel
Closure -> GcPtrLabel
ConInfoTable -> DataLabel
StaticInfoTable -> DataLabel
@@ -847,6 +862,8 @@ entry.
instance Outputable CLabel where
ppr = pprCLabel
+instance PlatformOutputable CLabel where
+ pprPlatform _ = pprCLabel
pprCLabel :: CLabel -> SDoc
@@ -980,8 +997,8 @@ ppIdFlavor x = pp_cSEP <>
(case x of
Closure -> ptext (sLit "closure")
SRT -> ptext (sLit "srt")
- InfoTable -> ptext (sLit "info")
- Entry -> ptext (sLit "entry")
+ InfoTable _ -> ptext (sLit "info")
+ Entry _ -> ptext (sLit "entry")
Slow -> ptext (sLit "slow")
RednCounts -> ptext (sLit "ct")
ConEntry -> ptext (sLit "con_entry")
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index a6b215b38f..e49d960c17 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -53,8 +53,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
-type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph
-type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph
+type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph
+type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph
-------------------------------------------------
-- Manipulating CmmGraphs
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 3d0d6fb426..e74e502727 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -238,7 +238,7 @@ addCAF caf srt =
where last = next_elt srt
srtToData :: TopSRT -> Cmm
-srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
+srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-- Once we have found the CAFs, we need to do two things:
@@ -317,7 +317,7 @@ to_SRT top_srt off len bmp
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
- CmmDataLabel srt_desc_lbl : map CmmStaticLit
+ Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW top_srt off
: mkWordCLit (fromIntegral len)
: map mkWordCLit bmp)
@@ -336,7 +336,7 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of
- CmmInfoTable False _ _ _ ->
+ CmmInfoTable _ False _ _ _ ->
Just (cvtToClosureLbl top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing
@@ -397,8 +397,8 @@ updInfo toVars toSrt (CmmProc top_info top_l g) =
updInfo _ _ t = t
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
-updInfoTbl toVars toSrt (CmmInfoTable s p t typeinfo)
- = CmmInfoTable s p t typeinfo'
+updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo)
+ = CmmInfoTable l s p t typeinfo'
where typeinfo' = case typeinfo of
t@(ConstrInfo _ _ _) -> t
(FunInfo c s a d e) -> FunInfo c (toSrt s) a d e
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 83d72b8f6e..fcb220d74c 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -13,6 +13,7 @@ import CmmExpr
import MkGraph
import qualified OldCmm as Old
import OldPprCmm ()
+import Platform
import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Control.Monad
@@ -21,23 +22,23 @@ import Maybes
import Outputable
import UniqSupply
-cmmToZgraph :: Old.Cmm -> UniqSM Cmm
-cmmOfZgraph :: Cmm -> Old.Cmm
+cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
+cmmOfZgraph :: Cmm -> Old.Cmm
-cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
+cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
- do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
+ do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g
return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
mapTop (CmmData s ds) = return $ CmmData s ds
cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
-toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
-toZgraph _ (Old.ListGraph []) =
+toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
+toZgraph _ _ (Old.ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
-toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
+toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkCallEntry NativeNodeCall [] in
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
@@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
- bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
+ bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g)
mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs
index 542e390128..9bd2386776 100644
--- a/compiler/cmm/CmmDecl.hs
+++ b/compiler/cmm/CmmDecl.hs
@@ -11,7 +11,7 @@ module CmmDecl (
CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
ProfilingInfo(..), ClosureTypeTag,
CmmActual, CmmFormal, ForeignHint(..),
- CmmStatic(..), Section(..),
+ CmmStatics(..), CmmStatic(..), Section(..),
) where
#include "HsVersions.h"
@@ -55,12 +55,12 @@ newtype GenCmm d h g = Cmm [GenCmmTop d h g]
data GenCmmTop d h g
= CmmProc -- A procedure
h -- Extra header such as the info table
- CLabel -- Used to generate both info & entry labels
+ CLabel -- Used to generate both info & entry labels (though the info table label is in 'h' in RawCmmTop)
g -- Control-flow graph for the procedure's code
| CmmData -- Static data
Section
- [d]
+ d
-----------------------------------------------------------------------------
@@ -70,12 +70,16 @@ data GenCmmTop d h g
-- Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable
+ LocalInfoTable
HasStaticClosure
ProfilingInfo
ClosureTypeTag -- Int
ClosureTypeInfo
| CmmNonInfoTable -- Procedure doesn't need an info table
+-- | If the table is local, we don't export its identifier even if the corresponding Id is exported.
+-- It's always safe to say 'False' here, but it might save symbols to say 'True'
+type LocalInfoTable = Bool
type HasStaticClosure = Bool
-- TODO: The GC target shouldn't really be part of CmmInfo
@@ -132,10 +136,7 @@ data CmmStatic
-- a literal value, size given by cmmLitRep of the literal.
| CmmUninitialised Int
-- uninitialised data, N bytes long
- | CmmAlign Int
- -- align to next N-byte boundary (N must be a power of 2).
- | CmmDataLabel CLabel
- -- label the current position in this section.
| CmmString [Word8]
-- string of 8-bit values only, not zero terminated.
+data CmmStatics = Statics CLabel {- Label of statics -} [CmmStatic] {- The static data itself -}
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index a606da2aec..47d0c8b004 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -28,7 +28,7 @@ import Data.Bits
-- When we split at proc points, we need an empty info table.
emptyContInfoTable :: CmmInfoTable
-emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
+emptyContInfoTable = CmmInfoTable False False (ProfilingInfo zero zero) rET_SMALL
(ContInfo [] NoC_SRT)
where zero = CmmInt 0 wordWidth
@@ -78,10 +78,10 @@ mkInfoTable _ (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) =
case info of
-- Code without an info table. Easy.
- CmmNonInfoTable -> [CmmProc [] entry_label blocks]
+ CmmNonInfoTable -> [CmmProc Nothing entry_label blocks]
- CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
- let info_label = entryLblToInfoLbl entry_label
+ CmmInfoTable is_local _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
+ let info_label = (if is_local then localiseLabel else id) $ entryLblToInfoLbl entry_label
ty_prof' = makeRelativeRefTo info_label ty_prof
cl_prof' = makeRelativeRefTo info_label cl_prof
in case type_info of
@@ -153,7 +153,7 @@ mkInfoTableAndCode :: CLabel
-> [RawCmmTop]
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
- = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
+ = [CmmProc (Just (Statics info_lbl $ map CmmStaticLit (reverse extra_bits ++ std_info)))
entry_lbl blocks]
| ListGraph [] <- blocks -- No code; only the info table is significant
@@ -163,7 +163,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks
| otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code
- [CmmProc [] entry_lbl blocks,
+ [CmmProc Nothing entry_lbl blocks,
mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
mkSRTLit :: CLabel
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 32fead337e..15357ecb94 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -23,6 +23,7 @@ import Outputable
import OldPprCmm()
import Constants
import FastString
+import Platform
import Data.Maybe
@@ -30,21 +31,22 @@ import Data.Maybe
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
- => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
+ => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops
cmmLintTop :: (Outputable d, Outputable h)
- => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop top = runCmmLint lintCmmTop top
+ => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
+cmmLintTop platform top = runCmmLint platform lintCmmTop top
-runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint l p =
+runCmmLint :: PlatformOutputable a
+ => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint platform l p =
case unCL (l p) of
- Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
- nest 2 err,
- ptext $ sLit ("Program was:"),
- nest 2 (ppr p)])
- Right _ -> Nothing
+ Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
+ nest 2 err,
+ ptext $ sLit ("Program was:"),
+ nest 2 (pprPlatform platform p)])
+ Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmTop (CmmProc _ lbl (ListGraph blocks))
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 28f21e21f3..5480d9c597 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -673,12 +673,11 @@ exactLog2 x_
-}
cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl
- (ListGraph blocks@(BasicBlock top_id _ : _)))
- | null info = p -- only if there's an info table, ignore case alts
- | otherwise =
+cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
+cmmLoopifyForC p@(CmmProc (Just info@(Statics info_lbl _)) entry_lbl
+ (ListGraph blocks@(BasicBlock top_id _ : _))) =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
- CmmProc info entry_lbl (ListGraph blocks')
+ CmmProc (Just info) entry_lbl (ListGraph blocks')
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
@@ -686,7 +685,7 @@ cmmLoopifyForC p@(CmmProc info entry_lbl
= CmmBranch top_id
do_stmt stmt = stmt
- jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl
+ jump_lbl | tablesNextToCode = info_lbl
| otherwise = entry_lbl
cmmLoopifyForC top = top
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 60f3bb5623..2d59fe751e 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -188,22 +188,24 @@ cmmtop :: { ExtCode }
-- * we can derive closure and info table labels from a single NAME
cmmdata :: { ExtCode }
- : 'section' STRING '{' statics '}'
- { do ss <- sequence $4;
- code (emitData (section $2) (concat ss)) }
+ : 'section' STRING '{' data_label statics '}'
+ { do lbl <- $4;
+ ss <- sequence $5;
+ code (emitData (section $2) (Statics lbl $ concat ss)) }
+
+data_label :: { ExtFCode CLabel }
+ : NAME ':'
+ {% withThisPackage $ \pkg ->
+ return (mkCmmDataLabel pkg $1) }
statics :: { [ExtFCode [CmmStatic]] }
: {- empty -} { [] }
| static statics { $1 : $2 }
-
+
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings. C-- doesn't allow them anyway.
static :: { ExtFCode [CmmStatic] }
- : NAME ':'
- {% withThisPackage $ \pkg ->
- return [CmmDataLabel (mkCmmDataLabel pkg $1)] }
-
- | type expr ';' { do e <- $2;
+ : type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1))] }
@@ -213,7 +215,6 @@ static :: { ExtFCode [CmmStatic] }
| typenot8 '[' INT ']' ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1) *
fromIntegral $3)] }
- | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] }
| 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4;
return $ map CmmStaticLit $
@@ -265,7 +266,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do prof <- profilingInfo $11 $13
return (mkCmmEntryLabel pkg $3,
- CmmInfoTable False prof (fromIntegral $9)
+ CmmInfoTable False False prof (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) }
@@ -274,7 +275,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do prof <- profilingInfo $11 $13
return (mkCmmEntryLabel pkg $3,
- CmmInfoTable False prof (fromIntegral $9)
+ CmmInfoTable False False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
0 -- Arity zero
(ArgSpec (fromIntegral $15))
@@ -289,7 +290,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do prof <- profilingInfo $11 $13
return (mkCmmEntryLabel pkg $3,
- CmmInfoTable False prof (fromIntegral $9)
+ CmmInfoTable False False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
(ArgSpec (fromIntegral $15))
zeroCLit),
@@ -305,7 +306,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13
return (mkCmmEntryLabel pkg $3,
- CmmInfoTable False prof (fromIntegral $11)
+ CmmInfoTable False False prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
@@ -314,7 +315,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do prof <- profilingInfo $9 $11
return (mkCmmEntryLabel pkg $3,
- CmmInfoTable False prof (fromIntegral $7)
+ CmmInfoTable False False prof (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) }
@@ -323,7 +324,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do let infoLabel = mkCmmInfoLabel pkg $3
return (mkCmmRetLabel pkg $3,
- CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+ CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
@@ -332,7 +333,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do live <- sequence (map (liftM Just) $7)
return (mkCmmRetLabel pkg $3,
- CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+ CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
@@ -873,9 +874,8 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
code (emitForeignCall' PlayRisky results
(CmmCallee expr' convention) args vols NoC_SRT ret)
CmmSafe srt ->
- code (emitForeignCall' (PlaySafe unused) results
+ code (emitForeignCall' PlaySafe results
(CmmCallee expr' convention) args vols NoC_SRT ret) where
- unused = panic "not used by emitForeignCall'"
CmmInterruptible ->
code (emitForeignCall' PlayInterruptible results
(CmmCallee expr' convention) args vols NoC_SRT ret)
@@ -910,9 +910,8 @@ primCall results_code name args_code vols safety
code (emitForeignCall' PlayRisky results
(CmmPrim p) args vols NoC_SRT CmmMayReturn)
CmmSafe srt ->
- code (emitForeignCall' (PlaySafe unused) results
+ code (emitForeignCall' PlaySafe results
(CmmPrim p) args vols NoC_SRT CmmMayReturn) where
- unused = panic "not used by emitForeignCall'"
CmmInterruptible ->
code (emitForeignCall' PlayInterruptible results
(CmmPrim p) args vols NoC_SRT CmmMayReturn)
@@ -1076,7 +1075,7 @@ parseCmmFile dflags filename = do
if (errorsFound dflags ms)
then return (ms, Nothing)
else do
- dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
+ dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
return (ms, Just cmm)
where
no_module = panic "parseCmmFile: no module"
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 1e4809d2b2..5effa6ca77 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
let cmms = Cmm (reverse (concat tops))
- dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+ dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
-- SRT is not affected by control flow optimization pass
let prog' = map runCmmContFlowOpts (cmms : rst)
return (topSRT, prog')
@@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Eliminate common blocks -------------------
g <- return $ elimCommonBlocks g
- dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
+ dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
- procPoints <- run $ minimalProcPointSet callPPs g
+ procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
- dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
+ dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <- run $ dualLivenessWithInsertion procPoints g
- dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
+ dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g
----------- Sink and inline assignments -------------------
g <- runOptimization $ rewriteAssignments g
- dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+ dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
----------- Eliminate dead assignments -------------------
g <- runOptimization $ removeDeadAssignments g
- dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
+ dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues
then run $ stubSlotsOnDeath g
else return g
- dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
+ dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
@@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g
- dump Opt_D_dump_cmmz_sp "Post manifestSP" g
+ dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
@@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
- mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
+ mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
@@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
+ mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+ mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
gs <- return $ map (bundleCAFs cafEnv) gs
- mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+ mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
return (localCAFs, gs)
where dflags = hsc_dflags hsc_env
+ platform = targetPlatform dflags
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
- dump f txt g = do
+ dump f = dumpWith ppr f
+ dumpPlatform platform = dumpWith (pprPlatform platform)
+ dumpWith pprFun f txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
- dumpIfSet_dyn dflags f txt (ppr g)
+ dumpIfSet_dyn dflags f txt (pprFun g)
when (not (dopt f dflags)) $
- dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 0527b6eea0..b608b291d4 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -25,6 +25,7 @@ import MkGraph
import Control.Monad
import OptimizationFuel
import Outputable
+import Platform
import UniqSet
import UniqSupply
@@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
CmmForeignCall {succ=k} -> setInsert k set
_ -> set
-minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
-minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
+minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints
procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
@@ -151,8 +152,8 @@ procPointAnalysis procPoints g =
liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
-extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
-extendPPSet g blocks procPoints =
+extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g
let add block pps = let id = entryLabel block
in case mapLookup id env of
@@ -163,7 +164,7 @@ extendPPSet g blocks procPoints =
newPoint = listToMaybe newPoints
ppSuccessor b =
let nreached id = case mapLookup id env `orElse`
- pprPanic "no ppt" (ppr id <+> ppr b) of
+ pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of
ProcPoint -> 1
ReachedBy ps -> setSize ps
block_procpoints = nreached (entryLabel b)
@@ -181,7 +182,7 @@ extendPPSet g blocks procPoints =
-}
case newPoint of Just id ->
if setMember id procPoints' then panic "added old proc pt"
- else extendPPSet g blocks (setInsert id procPoints')
+ else extendPPSet platform g blocks (setInsert id procPoints')
Nothing -> return procPoints'
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index de1a8e0dcb..f691183038 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -73,12 +73,15 @@ newtype ListGraph i = ListGraph [GenBasicBlock i]
-- across a whole compilation unit.
-- | Cmm with the info table as a data type
-type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)
-type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
+type Cmm = GenCmm CmmStatics CmmInfo (ListGraph CmmStmt)
+type CmmTop = GenCmmTop CmmStatics CmmInfo (ListGraph CmmStmt)
--- | Cmm with the info tables converted to a list of 'CmmStatic'
-type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)
-type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
+-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
+-- table label. If we are building without tables-next-to-code there will be no statics
+--
+-- INVARIANT: if there is an info table, it has at least one CmmStatic
+type RawCmm = GenCmm CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt)
+type RawCmmTop = GenCmmTop CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt)
-- A basic block containing a single label, at the beginning.
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
index 4b0db35bd8..4050359710 100644
--- a/compiler/cmm/OldPprCmm.hs
+++ b/compiler/cmm/OldPprCmm.hs
@@ -50,20 +50,23 @@ import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
+import Platform
import FastString
import Data.List
-----------------------------------------------------------------------------
-instance (Outputable instr) => Outputable (ListGraph instr) where
- ppr (ListGraph blocks) = vcat (map ppr blocks)
+instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
+ pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)
-instance (Outputable instr) => Outputable (GenBasicBlock instr) where
- ppr b = pprBBlock b
+instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
+ pprPlatform platform b = pprBBlock platform b
instance Outputable CmmStmt where
ppr s = pprStmt s
+instance PlatformOutputable CmmStmt where
+ pprPlatform _ = ppr
instance Outputable CmmInfo where
ppr e = pprInfo e
@@ -88,7 +91,7 @@ pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
maybe (ptext (sLit "<none>")) ppr gc_target,-}
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
-pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) =
+pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) =
vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) ppr gc_target,-}
ptext (sLit "update_frame: ") <>
@@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) =
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
-pprBBlock (BasicBlock ident stmts) =
- hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
+pprBBlock platform (BasicBlock ident stmts) =
+ hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts))
-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index c405b650a6..b48d2de3c8 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -83,11 +83,11 @@ pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
-- top level procs
--
pprTop :: RawCmmTop -> SDoc
-pprTop (CmmProc info clbl (ListGraph blocks)) =
- (if not (null info)
- then pprDataExterns info $$
- pprWordArray (entryLblToInfoLbl clbl) info
- else empty) $$
+pprTop (CmmProc mb_info clbl (ListGraph blocks)) =
+ (case mb_info of
+ Nothing -> empty
+ Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
+ pprWordArray info_clbl info_dat) $$
(vcat [
blankLine,
extern_decls,
@@ -112,31 +112,21 @@ pprTop (CmmProc info clbl (ListGraph blocks)) =
-- We only handle (a) arrays of word-sized things and (b) strings.
-pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) =
+pprTop (CmmData _section (Statics lbl [CmmString str])) =
hcat [
pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
ptext (sLit "[] = "), pprStringInCStyle str, semi
]
-pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) =
+pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
hcat [
pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
brackets (int size), semi
]
-pprTop (CmmData _section (CmmDataLabel lbl : lits)) =
+pprTop (CmmData _section (Statics lbl lits)) =
pprDataExterns lits $$
- pprWordArray lbl lits
-
--- Floating info table for safe a foreign call.
-pprTop (CmmData _section d@(_ : _))
- | CmmDataLabel lbl : lits <- reverse d =
- let lits' = reverse lits
- in pprDataExterns lits' $$
- pprWordArray lbl lits'
-
--- these shouldn't appear?
-pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
+ pprWordArray lbl lits
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
@@ -508,8 +498,6 @@ pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
CmmStaticLit lit -> nest 4 (pprLit lit)
- CmmAlign i -> nest 4 (ptext (sLit "/* align */") <+> int i)
- CmmDataLabel clbl -> pprCLabel clbl <> colon
CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-- these should be inlined, like the old .hc
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index cede69e06f..43e1c5bb2f 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -49,6 +49,7 @@ import PprCmmExpr
import Util
import BasicTypes
+import Platform
import Compiler.Hoopl
import Data.List
import Prelude hiding (succ)
@@ -76,20 +77,20 @@ instance Outputable ForeignTarget where
ppr = pprForeignTarget
-instance Outputable (Block CmmNode C C) where
- ppr = pprBlock
-instance Outputable (Block CmmNode C O) where
- ppr = pprBlock
-instance Outputable (Block CmmNode O C) where
- ppr = pprBlock
-instance Outputable (Block CmmNode O O) where
- ppr = pprBlock
+instance PlatformOutputable (Block CmmNode C C) where
+ pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode C O) where
+ pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode O C) where
+ pprPlatform _ = pprBlock
+instance PlatformOutputable (Block CmmNode O O) where
+ pprPlatform _ = pprBlock
-instance Outputable (Graph CmmNode e x) where
- ppr = pprGraph
+instance PlatformOutputable (Graph CmmNode e x) where
+ pprPlatform = pprGraph
-instance Outputable CmmGraph where
- ppr = pprCmmGraph
+instance PlatformOutputable CmmGraph where
+ pprPlatform platform = pprCmmGraph platform
----------------------------------------------------------
-- Outputting types Cmm contains
@@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
----------------------------------------------------------
-- Outputting blocks and graphs
-pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+ => Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock block = foldBlockNodesB3 ( ($$) . ppr
, ($$) . (nest 4) . ppr
, ($$) . (nest 4) . ppr
@@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr
block
empty
-pprGraph :: Graph CmmNode e x -> SDoc
-pprGraph GNil = empty
-pprGraph (GUnit block) = ppr block
-pprGraph (GMany entry body exit)
+pprGraph :: Platform -> Graph CmmNode e x -> SDoc
+pprGraph _ GNil = empty
+pprGraph platform (GUnit block) = pprPlatform platform block
+pprGraph platform (GMany entry body exit)
= text "{"
- $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
+ $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
$$ text "}"
- where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
+ where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
+ => MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO NothingO = empty
- pprMaybeO (JustO block) = ppr block
+ pprMaybeO (JustO block) = pprPlatform platform block
-pprCmmGraph :: CmmGraph -> SDoc
-pprCmmGraph g
+pprCmmGraph :: Platform -> CmmGraph -> SDoc
+pprCmmGraph platform g
= text "{" <> text "offset"
- $$ nest 2 (vcat $ map ppr blocks)
+ $$ nest 2 (vcat $ map (pprPlatform platform) blocks)
$$ text "}"
where blocks = postorderDfs g
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 1f520bfc90..f688f211fb 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -43,6 +43,7 @@ import PprCmmExpr
import Outputable
+import Platform
import FastString
import Data.List
@@ -54,23 +55,28 @@ import ClosureInfo
#include "../includes/rts/storage/FunTypes.h"
-pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+pprCmms :: (Outputable info, PlatformOutputable g)
+ => Platform -> [GenCmm CmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms))
where
separator = space $$ ptext (sLit "-------------------") $$ space
-writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO ()
-writeCmms handle cmms = printForC handle (pprCmms cmms)
+writeCmms :: (Outputable info, PlatformOutputable g)
+ => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO ()
+writeCmms platform handle cmms = printForC handle (pprCmms platform cmms)
-----------------------------------------------------------------------------
-instance (Outputable d, Outputable info, Outputable g)
- => Outputable (GenCmm d info g) where
- ppr c = pprCmm c
+instance (Outputable d, Outputable info, PlatformOutputable g)
+ => PlatformOutputable (GenCmm d info g) where
+ pprPlatform platform c = pprCmm platform c
-instance (Outputable d, Outputable info, Outputable i)
- => Outputable (GenCmmTop d info i) where
- ppr t = pprTop t
+instance (Outputable d, Outputable info, PlatformOutputable i)
+ => PlatformOutputable (GenCmmTop d info i) where
+ pprPlatform platform t = pprTop platform t
+
+instance Outputable CmmStatics where
+ ppr e = pprStatics e
instance Outputable CmmStatic where
ppr e = pprStatic e
@@ -81,20 +87,22 @@ instance Outputable CmmInfoTable where
-----------------------------------------------------------------------------
-pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
-pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
+pprCmm :: (Outputable d, Outputable info, PlatformOutputable g)
+ => Platform -> GenCmm d info g -> SDoc
+pprCmm platform (Cmm tops)
+ = vcat $ intersperse blankLine $ map (pprTop platform) tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable d, Outputable info, Outputable i)
- => GenCmmTop d info i -> SDoc
+pprTop :: (Outputable d, Outputable info, PlatformOutputable i)
+ => Platform -> GenCmmTop d info i -> SDoc
-pprTop (CmmProc info lbl graph)
+pprTop platform (CmmProc info lbl graph)
= vcat [ pprCLabel lbl <> lparen <> rparen
, nest 8 $ lbrace <+> ppr info $$ rbrace
- , nest 4 $ ppr graph
+ , nest 4 $ pprPlatform platform graph
, rbrace ]
-- --------------------------------------------------------------------------
@@ -102,8 +110,8 @@ pprTop (CmmProc info lbl graph)
--
-- section "data" { ... }
--
-pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
+pprTop _ (CmmData section ds) =
+ (hang (pprSection section <+> lbrace) 4 (ppr ds))
$$ rbrace
-- --------------------------------------------------------------------------
@@ -111,8 +119,9 @@ pprTop (CmmData section ds) =
pprInfoTable :: CmmInfoTable -> SDoc
pprInfoTable CmmNonInfoTable = empty
-pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
- vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+>
+pprInfoTable (CmmInfoTable is_local stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
+ vcat [ptext (sLit "is local: ") <> ppr is_local <+>
+ ptext (sLit "has static closure: ") <> ppr stat_clos <+>
ptext (sLit "type: ") <> pprLit closure_type,
ptext (sLit "desc: ") <> pprLit closure_desc,
ptext (sLit "tag: ") <> integer (toInteger tag),
@@ -171,12 +180,13 @@ instance Outputable ForeignHint where
-- Strings are printed as C strings, and we print them as I8[],
-- following C--
--
+pprStatics :: CmmStatics -> SDoc
+pprStatics (Statics lbl ds) = vcat ((pprCLabel lbl <> colon) : map ppr ds)
+
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
- CmmAlign i -> nest 4 $ text "align" <+> int i
- CmmDataLabel clbl -> pprCLabel clbl <> colon
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
-- --------------------------------------------------------------------------
View Lorry Controller Status