summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMax Bolingbroke <batterseapower@hotmail.com>2011-07-05 09:23:58 +0100
committerMax Bolingbroke <batterseapower@hotmail.com>2011-07-05 09:53:57 +0100
commit54843b5bfdc81b7af6df36a06f7f434c7b74f796 (patch)
tree5e87d9d92707d9a955559b15b6e849fb0594a0e1
parente01fffc60ba6a71487f0402f6c79ba2f0a684765 (diff)
downloadhaskell-54843b5bfdc81b7af6df36a06f7f434c7b74f796.tar.gz
Refactoring: use a structured CmmStatics type rather than [CmmStatic]
I observed that the [CmmStatics] within CmmData uses the list in a very stylised way. The first item in the list is almost invariably a CmmDataLabel. Many parts of the compiler pattern match on this list and fail if this is not true. This patch makes the invariant explicit by introducing a structured type CmmStatics that holds the label and the list of remaining [CmmStatic]. There is one wrinkle: the x86 backend sometimes wants to output an alignment directive just before the label. However, this can be easily fixed up by parameterising the native codegen over the type of CmmStatics (though the GenCmmTop parameterisation) and using a pair (Alignment, CmmStatics) there instead. As a result, I think we will be able to remove CmmAlign and CmmDataLabel from the CmmStatic data type, thus nuking a lot of code and failing pattern matches. This change will come as part of my next patch.
-rw-r--r--compiler/basicTypes/BasicTypes.lhs14
-rw-r--r--compiler/cmm/Cmm.hs4
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs4
-rw-r--r--compiler/cmm/CmmDecl.hs8
-rw-r--r--compiler/cmm/CmmParse.y17
-rw-r--r--compiler/cmm/OldCmm.hs8
-rw-r--r--compiler/cmm/PprC.hs18
-rw-r--r--compiler/cmm/PprCmmDecl.hs12
-rw-r--r--compiler/codeGen/CgHpc.hs6
-rw-r--r--compiler/codeGen/CgMonad.lhs2
-rw-r--r--compiler/codeGen/CgUtils.hs14
-rw-r--r--compiler/codeGen/CodeGen.lhs2
-rw-r--r--compiler/codeGen/StgCmm.hs2
-rw-r--r--compiler/codeGen/StgCmmHpc.hs11
-rw-r--r--compiler/codeGen/StgCmmMonad.hs2
-rw-r--r--compiler/codeGen/StgCmmUtils.hs14
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs6
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs4
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs82
-rw-r--r--compiler/nativeGen/Instruction.hs6
-rw-r--r--compiler/nativeGen/PIC.hs11
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs19
-rw-r--r--compiler/nativeGen/PPC/Instr.hs2
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs8
-rw-r--r--compiler/nativeGen/PPC/RegInfo.hs22
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Coalesce.hs6
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Main.hs12
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Spill.hs12
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillClean.hs10
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillCost.hs2
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Stats.hs32
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs4
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Stats.hs4
-rw-r--r--compiler/nativeGen/RegAlloc/Liveness.hs36
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs8
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Expand.hs2
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Gen32.hs10
-rw-r--r--compiler/nativeGen/SPARC/Instr.hs2
-rw-r--r--compiler/nativeGen/SPARC/Ppr.hs7
-rw-r--r--compiler/nativeGen/SPARC/ShortcutJump.hs23
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs17
-rw-r--r--compiler/nativeGen/X86/Instr.hs22
-rw-r--r--compiler/nativeGen/X86/Ppr.hs8
45 files changed, 277 insertions, 242 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 5c931d9d3a..a380b742f6 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -19,7 +19,9 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
- Arity,
+ Arity,
+
+ Alignment,
FunctionOrData(..),
@@ -96,6 +98,16 @@ type Arity = Int
%************************************************************************
%* *
+\subsection[Alignment]{Alignment}
+%* *
+%************************************************************************
+
+\begin{code}
+type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
+\end{code}
+
+%************************************************************************
+%* *
\subsection[FunctionOrData]{FunctionOrData}
%* *
%************************************************************************
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..fc7e488103 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)
diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs
index 542e390128..a04491e10e 100644
--- a/compiler/cmm/CmmDecl.hs
+++ b/compiler/cmm/CmmDecl.hs
@@ -11,11 +11,12 @@ module CmmDecl (
CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
ProfilingInfo(..), ClosureTypeTag,
CmmActual, CmmFormal, ForeignHint(..),
- CmmStatic(..), Section(..),
+ CmmStatics(..), CmmStatic(..), Section(..),
) where
#include "HsVersions.h"
+import BasicTypes (Alignment)
import CmmExpr
import CLabel
import SMRep
@@ -60,7 +61,7 @@ data GenCmmTop d h g
| CmmData -- Static data
Section
- [d]
+ d
-----------------------------------------------------------------------------
@@ -132,10 +133,11 @@ data CmmStatic
-- a literal value, size given by cmmLitRep of the literal.
| CmmUninitialised Int
-- uninitialised data, N bytes long
- | CmmAlign Int
+ | CmmAlign Alignment
-- 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/CmmParse.y b/compiler/cmm/CmmParse.y
index 60f3bb5623..eceff8350d 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -188,21 +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 '{' static_label statics '}'
+ { do lbl <- $4;
+ ss <- sequence $5;
+ code (emitData (section $2) (Statics lbl $ concat ss)) }
statics :: { [ExtFCode [CmmStatic]] }
: {- empty -} { [] }
| static statics { $1 : $2 }
+static_label :: { ExtFCode CLabel }
+ : NAME ':'
+ {% withThisPackage $ \pkg ->
+ return (mkCmmDataLabel pkg $1) }
+
-- 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)] }
-
+ : static_label { liftM (\x -> [CmmDataLabel x]) $1 }
| type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index de1a8e0dcb..5ba78dcc7e 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -73,12 +73,12 @@ 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)
+type RawCmm = GenCmm CmmStatics [CmmStatic] (ListGraph CmmStmt)
+type RawCmmTop = GenCmmTop CmmStatics [CmmStatic] (ListGraph CmmStmt)
-- A basic block containing a single label, at the beginning.
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index c405b650a6..b12d172a74 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -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.
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 1f520bfc90..ed143f3908 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -54,12 +54,12 @@ import ClosureInfo
#include "../includes/rts/storage/FunTypes.h"
-pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
+pprCmms :: (Outputable info, Outputable g) => [GenCmm 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) => Handle -> [GenCmm CmmStatic info g] -> IO ()
+writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatics info g] -> IO ()
writeCmms handle cmms = printForC handle (pprCmms cmms)
-----------------------------------------------------------------------------
@@ -72,6 +72,9 @@ instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmTop d info i) where
ppr t = pprTop t
+instance Outputable CmmStatics where
+ ppr e = pprStatics e
+
instance Outputable CmmStatic where
ppr e = pprStatic e
@@ -103,7 +106,7 @@ pprTop (CmmProc info lbl graph)
-- section "data" { ... }
--
pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
+ (hang (pprSection section <+> lbrace) 4 (ppr ds))
$$ rbrace
-- --------------------------------------------------------------------------
@@ -171,6 +174,9 @@ 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 (map ppr (CmmDataLabel lbl:ds))
+
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index 48756505c3..a134f00067 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -12,6 +12,7 @@ import OldCmm
import CLabel
import Module
import OldCmmUtils
+import CgUtils
import CgMonad
import HscTypes
@@ -30,9 +31,8 @@ cgTickBox mod n = do
hpcTable :: Module -> HpcInfo -> Code
hpcTable this_mod (HpcInfo hpc_tickCount _) = do
- emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
- ] ++
- [ CmmStaticLit (CmmInt 0 W64)
+ emitDataLits (mkHpcTicksLabel this_mod) $
+ [ CmmInt 0 W64
| _ <- take hpc_tickCount [0::Int ..]
]
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 9b195bfab2..273c1bf16e 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -736,7 +736,7 @@ emitCgStmt stmt
; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
}
-emitData :: Section -> [CmmStatic] -> Code
+emitData :: Section -> CmmStatics -> Code
emitData sect lits
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 63d99a629f..effa7a42d6 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -545,26 +545,26 @@ baseRegOffset _ = panic "baseRegOffset:other"
emitDataLits :: CLabel -> [CmmLit] -> Code
-- Emit a data-segment data block
emitDataLits lbl lits
- = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+ = emitData Data (Statics lbl $ map CmmStaticLit lits)
-mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph
-- Emit a data-segment data block
mkDataLits lbl lits
- = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+ = CmmData Data (Statics lbl $ map CmmStaticLit lits)
emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
-- Emit a read-only data block
emitRODataLits caller lbl lits
- = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ = emitData section (Statics lbl $ map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph
mkRODataLits lbl lits
- = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ = CmmData section (Statics lbl $ map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
@@ -580,7 +580,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit
mkByteStringCLit bytes
= do { uniq <- newUnique
; let lbl = mkStringLitLabel uniq
- ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
+ ; emitData ReadOnlyData $ Statics lbl [CmmString bytes]
; return (CmmLabel lbl) }
-------------------------------------------------------------------------
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 7a7bf48b92..1825c97256 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
- ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ]
+ ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) []
; whenC (this_mod == mainModIs dflags) $
emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 2bfe1876ba..0404258446 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -182,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info
; initCostCentres cost_centre_info
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
- ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ]
+ ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) []
}
---------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index fae3bef016..4465e30b04 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -11,11 +11,11 @@ module StgCmmHpc ( initHpc, mkTickBox ) where
import StgCmmMonad
import MkGraph
-import CmmDecl
import CmmExpr
import CLabel
import Module
import CmmUtils
+import StgCmmUtils
import HscTypes
import StaticFlags
@@ -36,9 +36,8 @@ initHpc _ (NoHpcInfo {})
= return ()
initHpc this_mod (HpcInfo tickCount _hashNo)
= whenC opt_Hpc $
- do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
- ] ++
- [ CmmStaticLit (CmmInt 0 W64)
- | _ <- take tickCount [0::Int ..]
- ]
+ do { emitDataLits (mkHpcTicksLabel this_mod)
+ [ (CmmInt 0 W64)
+ | _ <- take tickCount [0::Int ..]
+ ]
}
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index f92b3cde27..d06b581f26 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -593,7 +593,7 @@ emit ag
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
-emitData :: Section -> [CmmStatic] -> FCode ()
+emitData :: Section -> CmmStatics -> FCode ()
emitData sect lits
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 558b7fdeaa..74da7317d4 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -508,26 +508,26 @@ baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a data-segment data block
emitDataLits lbl lits
- = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+ = emitData Data (Statics lbl $ map CmmStaticLit lits)
-mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt
-- Emit a data-segment data block
mkDataLits lbl lits
- = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+ = CmmData Data (Statics lbl $ map CmmStaticLit lits)
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a read-only data block
emitRODataLits lbl lits
- = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ = emitData section (Statics lbl $ map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt
mkRODataLits lbl lits
- = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ = CmmData section (Statics lbl $ map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
@@ -543,7 +543,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit
mkByteStringCLit bytes
= do { uniq <- newUnique
; let lbl = mkStringLitLabel uniq
- ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
+ ; emitData ReadOnlyData $ Statics lbl [CmmString bytes]
; return (CmmLabel lbl) }
-------------------------------------------------------------------------
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 56d8386431..21d463e5c5 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -62,7 +62,7 @@ llvmCodeGen dflags h us cmms
-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
--
-cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])]
+cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
-> [LlvmUnresData] -> IO ( LlvmEnv )
cmmDataLlvmGens dflags h env [] lmdata
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 59cdad4918..e73f41cde1 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -41,7 +41,7 @@ import Unique
-- * Some Data Types
--
-type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement)
+type LlvmCmmTop = GenCmmTop [LlvmData] [CmmStatic] (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
-- | Unresolved code.
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 3e486a544f..7cca522d39 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -37,8 +37,8 @@ structStr = fsLit "_struct"
-- complete this completely though as we need to pass all CmmStatic
-- sections before all references can be resolved. This last step is
-- done by 'resolveLlvmData'.
-genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData
-genLlvmData (sec, CmmDataLabel lbl:xs) =
+genLlvmData :: (Section, CmmStatics) -> LlvmUnresData
+genLlvmData (sec, Statics lbl xs) =
let static = map genData xs
label = strCLabel_llvm lbl
@@ -50,8 +50,6 @@ genLlvmData (sec, CmmDataLabel lbl:xs) =
alias = LMAlias ((label `appendFS` structStr), strucTy)
in (lbl, sec, alias, static)
-genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!"
-
resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData]
-> (LlvmEnv, [LlvmData])
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 9f25c08826..48a0d6967c 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -83,7 +83,7 @@ pprLlvmCmmTop _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
- = let static = CmmDataLabel lbl : info
+ = let static = Statics lbl info
(idoc, ivar) = if not (null info)
then pprInfoTable env count lbl static
else (empty, [])
@@ -103,7 +103,7 @@ pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
-- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar])
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar])
pprInfoTable env count lbl stat
= let unres = genLlvmData (Text, stat)
(_, (ldata, ltypes)) = resolveLlvmData env unres
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index ff18615b1a..bfeaf9e8e3 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -62,6 +62,7 @@ import DynFlags
import StaticFlags
import Util
+import BasicTypes ( Alignment )
import Digraph
import Pretty (Doc)
import qualified Pretty
@@ -131,31 +132,32 @@ The machine-dependent bits break down as follows:
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
-data NcgImpl instr jumpDest = NcgImpl {
- cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr],
- generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
+data NcgImpl statics instr jumpDest = NcgImpl {
+ cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr],
+ generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
- shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
+ shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
- pprNatCmmTop :: NatCmmTop instr -> Doc,
+ pprNatCmmTop :: NatCmmTop statics instr -> Doc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
- ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr],
- ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr],
+ ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr],
ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
}
--------------------
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen dflags h us cmms
- = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ = let 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
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
- ,shortcutStatic = X86.Instr.shortcutStatic
+ ,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmTop = X86.Ppr.pprNatCmmTop
,maxSpillSlots = X86.Instr.maxSpillSlots
@@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
- ,shortcutStatic = PPC.RegInfo.shortcutStatic
+ ,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmTop = PPC.Ppr.pprNatCmmTop
,maxSpillSlots = PPC.Instr.maxSpillSlots
@@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
- ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic
+ ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop
,maxSpillSlots = SPARC.Instr.maxSpillSlots
@@ -204,9 +206,9 @@ nativeCodeGen dflags h us cmms
ArchUnknown ->
panic "nativeCodeGen: No NCG for unknown arch"
-nativeCodeGen' :: (Instruction instr, Outputable instr)
+nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
- -> NcgImpl instr jumpDest
+ -> NcgImpl statics instr jumpDest
-> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen' dflags ncgImpl h us cmms
= do
@@ -270,20 +272,20 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- | Do native code generation on all these cmms.
--
-cmmNativeGens :: (Instruction instr, Outputable instr)
+cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
- -> NcgImpl instr jumpDest
+ -> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> [RawCmmTop]
-> [[CLabel]]
- -> [ ([NatCmmTop instr],
- Maybe [Color.RegAllocStats instr],
+ -> [ ([NatCmmTop statics instr],
+ Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats]) ]
-> Int
-> IO ( [[CLabel]],
- [([NatCmmTop instr],
- Maybe [Color.RegAllocStats instr],
+ [([NatCmmTop statics instr],
+ Maybe [Color.RegAllocStats statics instr],
Maybe [Linear.RegAllocStats])] )
cmmNativeGens _ _ _ _ [] impAcc profAcc _
@@ -325,17 +327,17 @@ 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
- :: (Instruction instr, Outputable instr)
+ :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
- -> NcgImpl instr jumpDest
+ -> NcgImpl statics instr jumpDest
-> UniqSupply
-> RawCmmTop -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply
- , [NatCmmTop instr] -- native code
- , [CLabel] -- things imported by this cmm
- , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator
- , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+ , [NatCmmTop statics instr] -- native code
+ , [CLabel] -- things imported by this cmm
+ , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
+ , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
cmmNativeGen dflags ncgImpl us cmm count
= do
@@ -483,7 +485,7 @@ cmmNativeGen dflags ncgImpl us cmm count
, ppr_raStatsLinear)
-x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
+x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
@@ -556,7 +558,7 @@ makeImportsDoc dflags imports
sequenceTop
:: Instruction instr
- => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
+ => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr
sequenceTop _ top@(CmmData _ _) = top
sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
@@ -670,8 +672,8 @@ makeFarBranches blocks
-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
- :: NcgImpl instr jumpDest
- -> [NatCmmTop instr] -> [NatCmmTop instr]
+ :: NcgImpl statics instr jumpDest
+ -> [NatCmmTop statics instr] -> [NatCmmTop statics instr]
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
@@ -682,9 +684,9 @@ generateJumpTables ncgImpl xs = concatMap f xs
shortcutBranches
:: DynFlags
- -> NcgImpl instr jumpDest
- -> [NatCmmTop instr]
- -> [NatCmmTop instr]
+ -> NcgImpl statics instr jumpDest
+ -> [NatCmmTop statics instr]
+ -> [NatCmmTop statics instr]
shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops -- only with -O or higher
@@ -693,7 +695,7 @@ shortcutBranches dflags ncgImpl tops
(tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
mapping = foldr plusUFM emptyUFM mappings
-build_mapping :: NcgImpl instr jumpDest
+build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmTop d t (ListGraph instr)
-> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
@@ -723,14 +725,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
-apply_mapping :: NcgImpl instr jumpDest
+apply_mapping :: NcgImpl statics instr jumpDest
-> UniqFM jumpDest
- -> GenCmmTop CmmStatic h (ListGraph instr)
- -> GenCmmTop CmmStatic h (ListGraph instr)
+ -> GenCmmTop statics h (ListGraph instr)
+ -> GenCmmTop statics h (ListGraph instr)
apply_mapping ncgImpl ufm (CmmData sec statics)
- = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics)
- -- we need to get the jump tables, so apply the mapping to the entries
- -- of a CmmData too.
+ = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
= CmmProc info lbl (ListGraph $ map short_bb blocks)
where
@@ -761,10 +761,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
genMachCode
:: DynFlags
- -> (RawCmmTop -> NatM [NatCmmTop instr])
+ -> (RawCmmTop -> NatM [NatCmmTop statics instr])
-> RawCmmTop
-> UniqSM
- ( [NatCmmTop instr]
+ ( [NatCmmTop statics instr]
, [CLabel])
genMachCode dflags cmmTopCodeGen cmm_top
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 918198cb9c..5c85101e8e 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -37,13 +37,13 @@ noUsage = RU [] []
-- Type synonyms for Cmm populated with native code
type NatCmm instr
= GenCmm
- CmmStatic
+ CmmStatics
[CmmStatic]
(ListGraph instr)
-type NatCmmTop instr
+type NatCmmTop statics instr
= GenCmmTop
- CmmStatic
+ statics
[CmmStatic]
(ListGraph instr)
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
index c375ab4707..7f59fd6fc9 100644
--- a/compiler/nativeGen/PIC.hs
+++ b/compiler/nativeGen/PIC.hs
@@ -709,8 +709,8 @@ pprImportedSymbol _ _ _
initializePicBase_ppc
:: Arch -> OS -> Reg
- -> [NatCmmTop PPC.Instr]
- -> NatM [NatCmmTop PPC.Instr]
+ -> [NatCmmTop CmmStatics PPC.Instr]
+ -> NatM [NatCmmTop CmmStatics PPC.Instr]
initializePicBase_ppc ArchPPC os picReg
(CmmProc info lab (ListGraph blocks) : statics)
@@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg
gotOffLabel <- getNewLabelNat
tmp <- getNewRegNat $ intSize wordWidth
let
- gotOffset = CmmData Text [
- CmmDataLabel gotOffLabel,
+ gotOffset = CmmData Text $ Statics gotOffLabel [
CmmStaticLit (CmmLabelDiffOff gotLabel
mkPicBaseLabel
0)
@@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _
initializePicBase_x86
:: Arch -> OS -> Reg
- -> [NatCmmTop X86.Instr]
- -> NatM [NatCmmTop X86.Instr]
+ -> [NatCmmTop (Alignment, CmmStatics) X86.Instr]
+ -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr]
initializePicBase_x86 ArchX86 os picReg
(CmmProc info lab (ListGraph blocks) : statics)
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index f4c972e4b0..84737310aa 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -67,7 +67,7 @@ import FastString
cmmTopCodeGen
:: RawCmmTop
- -> NatM [NatCmmTop Instr]
+ -> NatM [NatCmmTop CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
@@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do
basicBlockCodeGen
:: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
- , [NatCmmTop Instr])
+ , [NatCmmTop CmmStatics Instr])
basicBlockCodeGen (BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
@@ -557,8 +557,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do
Amode addr addr_code <- getAmode dynRef
let size = floatSize frep
code dst =
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f frep)]
+ LDATA ReadOnlyData (Statics lbl
+ [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD size dst addr)
return (Any size code)
@@ -1180,7 +1180,7 @@ genSwitch expr ids
]
return code
-generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr)
generateJumpTableForInstr (BCTR ids (Just lbl)) =
let jumpTable
| opt_PIC = map jumpTableEntryRel ids
@@ -1190,7 +1190,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) =
jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
where blockLabel = mkAsmTempLabel (getUnique blockid)
- in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+ in Just (CmmData ReadOnlyData (Statics lbl jumpTable))
generateJumpTableForInstr _ = Nothing
-- -----------------------------------------------------------------------------
@@ -1362,10 +1362,9 @@ coerceInt2FP fromRep toRep x = do
Amode addr addr_code <- getAmode dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
- LDATA ReadOnlyData
- [CmmDataLabel lbl,
- CmmStaticLit (CmmInt 0x43300000 W32),
- CmmStaticLit (CmmInt 0x80000000 W32)],
+ LDATA ReadOnlyData $ Statics lbl
+ [CmmStaticLit (CmmInt 0x43300000 W32),
+ CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
ST II32 itmp (spRel 3),
LIS itmp (ImmInt 0x4330),
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 0288f1bf02..d13d6afca6 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -75,7 +75,7 @@ data Instr
-- some static data spat out during code
-- generation. Will be extracted before
-- pretty-printing.
- | LDATA Section [CmmStatic]
+ | LDATA Section CmmStatics
-- start a new basic block. Useful during
-- codegen, removed later. Preceding
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index bd12a8188c..6750985f16 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -49,9 +49,9 @@ import Data.Bits
-- -----------------------------------------------------------------------------
-- Printing this stuff out
-pprNatCmmTop :: NatCmmTop Instr -> Doc
+pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc
pprNatCmmTop (CmmData section dats) =
- pprSectionHeader section $$ vcat (map pprData dats)
+ pprSectionHeader section $$ pprDatas dats
-- special case for split markers:
pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
@@ -93,6 +93,10 @@ pprBasicBlock (BasicBlock blockid instrs) =
vcat (map pprInstr instrs)
+
+pprDatas :: CmmStatics -> Doc
+pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats))
+
pprData :: CmmStatic -> Doc
pprData (CmmAlign bytes) = pprAlign bytes
pprData (CmmDataLabel lbl) = pprLabel lbl
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index bfc712af86..2a30087ab7 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -11,7 +11,7 @@ module PPC.RegInfo (
canShortcut,
shortcutJump,
- shortcutStatic
+ shortcutStatics
)
where
@@ -43,18 +43,24 @@ shortcutJump _ other = other
-- Here because it knows about JumpDest
-shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+ = Statics lbl $ map (shortcutStatic fn) statics
+ -- we need to get the jump tables, so apply the mapping to the entries
+ -- of a CmmData too.
-shortcutStatic fn (CmmStaticLit (CmmLabel lab))
- | Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq)))
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+ | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
+ | otherwise = lab
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+ = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
- | Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
-
shortcutStatic _ other_static
= other_static
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 1eaf00f3a2..a499e1d562 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -27,8 +27,8 @@ import Data.List
-- the same and the move instruction safely erased.
regCoalesce
:: Instruction instr
- => [LiveCmmTop instr]
- -> UniqSM [LiveCmmTop instr]
+ => [LiveCmmTop statics instr]
+ -> UniqSM [LiveCmmTop statics instr]
regCoalesce code
= do
@@ -61,7 +61,7 @@ sinkReg fm r
-- then we can rename the two regs to the same thing and eliminate the move.
slurpJoinMovs
:: Instruction instr
- => LiveCmmTop instr
+ => LiveCmmTop statics instr
-> Bag (Reg, Reg)
slurpJoinMovs live
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index cdbe98755a..298b5673d4 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -44,12 +44,12 @@ maxSpinCount = 10
-- | The top level of the graph coloring register allocator.
regAlloc
- :: (Outputable 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.
- -> [LiveCmmTop instr] -- ^ code annotated with liveness information.
- -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
+ -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information.
+ -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] )
-- ^ code with registers allocated and stats for each stage of
-- allocation
@@ -239,7 +239,7 @@ regAlloc_spin
-- | Build a graph from the liveness and coalesce information in this code.
buildGraph
:: Instruction instr
- => [LiveCmmTop instr]
+ => [LiveCmmTop statics instr]
-> UniqSM (Color.Graph VirtualReg RegClass RealReg)
buildGraph code
@@ -320,9 +320,9 @@ graphAddCoalesce _ _
-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
- :: (Outputable instr, Instruction instr)
+ :: (Outputable statics, Outputable instr, Instruction instr)
=> Color.Graph VirtualReg RegClass RealReg
- -> LiveCmmTop instr -> LiveCmmTop instr
+ -> LiveCmmTop statics instr -> LiveCmmTop statics instr
patchRegsFromGraph graph code
= let
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 4eabb3b0b4..c4fb783688 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -41,13 +41,13 @@ import qualified Data.Set as Set
--
regSpill
:: Instruction instr
- => [LiveCmmTop instr] -- ^ the code
+ => [LiveCmmTop statics instr] -- ^ the code
-> UniqSet Int -- ^ available stack slots
-> UniqSet VirtualReg -- ^ the regs to spill
-> UniqSM
- ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added.
- , UniqSet Int -- left over slots
- , SpillStats ) -- stats about what happened during spilling
+ ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added.
+ , UniqSet Int -- left over slots
+ , SpillStats ) -- stats about what happened during spilling
regSpill code slotsFree regs
@@ -81,8 +81,8 @@ regSpill code slotsFree regs
regSpill_top
:: Instruction instr
=> RegMap Int -- ^ map of vregs to slots they're being spilled to.
- -> LiveCmmTop instr -- ^ the top level thing.
- -> SpillM (LiveCmmTop instr)
+ -> LiveCmmTop statics instr -- ^ the top level thing.
+ -> SpillM (LiveCmmTop statics instr)
regSpill_top regSlotMap cmm
= case cmm of
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 38c33b708a..710055c045 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -54,7 +54,7 @@ type Slot = Int
-- | Clean out unneeded spill\/reloads from this top level thing.
cleanSpills
:: Instruction instr
- => LiveCmmTop instr -> LiveCmmTop instr
+ => LiveCmmTop statics instr -> LiveCmmTop statics instr
cleanSpills cmm
= evalState (cleanSpin 0 cmm) initCleanS
@@ -63,8 +63,8 @@ cleanSpills cmm
cleanSpin
:: Instruction instr
=> Int
- -> LiveCmmTop instr
- -> CleanM (LiveCmmTop instr)
+ -> LiveCmmTop statics instr
+ -> CleanM (LiveCmmTop statics instr)
{-
cleanSpin spinCount code
@@ -282,8 +282,8 @@ cleanReload _ _ _
--
cleanTopBackward
:: Instruction instr
- => LiveCmmTop instr
- -> CleanM (LiveCmmTop instr)
+ => LiveCmmTop statics instr
+ -> CleanM (LiveCmmTop statics instr)
cleanTopBackward cmm
= case cmm of
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 330a410312..8a16b25187 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -64,7 +64,7 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
--
slurpSpillCostInfo
:: (Outputable instr, Instruction instr)
- => LiveCmmTop instr
+ => LiveCmmTop statics instr
-> SpillCostInfo
slurpSpillCostInfo cmm
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 5ff7bff91a..f24e876cb2 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -36,36 +36,36 @@ import State
import Data.List
-data RegAllocStats instr
+data RegAllocStats statics instr
-- initial graph
= RegAllocStatsStart
- { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness
+ { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness
, raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph
, raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
-- a spill stage
| RegAllocStatsSpill
- { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for
+ { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for
, raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph
, raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
, raSpillStats :: SpillStats -- ^ spiller stats
, raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
- , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added
+ , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added
-- a successful coloring
| RegAllocStatsColored
- { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for
+ { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for
, raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph
, raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph
, raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
- , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied
- , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs
- , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out
- , raFinal :: [NatCmmTop instr] -- ^ final code
+ , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied
+ , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs
+ , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out
+ , raFinal :: [NatCmmTop statics instr] -- ^ final code
, raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code
-instance Outputable instr => Outputable (RegAllocStats instr) where
+instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where
ppr (s@RegAllocStatsStart{})
= text "# Start"
@@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where
-- | Do all the different analysis on this list of RegAllocStats
pprStats
- :: [RegAllocStats instr]
+ :: [RegAllocStats statics instr]
-> Color.Graph VirtualReg RegClass RealReg
-> SDoc
@@ -162,7 +162,7 @@ pprStats stats graph
-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
pprStatsSpills
- :: [RegAllocStats instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsSpills stats
= let
@@ -180,7 +180,7 @@ pprStatsSpills stats
-- | Dump a table of how long vregs tend to live for in the initial code.
pprStatsLifetimes
- :: [RegAllocStats instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes stats
= let info = foldl' plusSpillCostInfo zeroSpillCostInfo
@@ -208,7 +208,7 @@ binLifetimeCount fm
-- | Dump a table of how many conflicts vregs tend to have in the initial code.
pprStatsConflict
- :: [RegAllocStats instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsConflict stats
= let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
@@ -225,7 +225,7 @@ pprStatsConflict stats
-- | For every vreg, dump it's how many conflicts it has and its lifetime
-- good for making a scatter plot.
pprStatsLifeConflict
- :: [RegAllocStats instr]
+ :: [RegAllocStats statics instr]
-> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
-> SDoc
@@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph
-- Lets us see how well the register allocator has done.
countSRMs
:: Instruction instr
- => LiveCmmTop instr -> (Int, Int, Int)
+ => LiveCmmTop statics instr -> (Int, Int, Int)
countSRMs cmm
= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 3682ffbe1d..4e54b4744d 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -129,8 +129,8 @@ import Control.Monad
regAlloc
:: (Outputable instr, Instruction instr)
=> DynFlags
- -> LiveCmmTop instr
- -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
+ -> LiveCmmTop statics instr
+ -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats)
regAlloc _ (CmmData sec d)
= return
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
index c80f77f893..0c059eac27 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -37,7 +37,7 @@ binSpillReasons reasons
-- | Count reg-reg moves remaining in this code.
countRegRegMovesNat
:: Instruction instr
- => NatCmmTop instr -> Int
+ => NatCmmTop statics instr -> Int
countRegRegMovesNat cmm
= execState (mapGenBlockTopM countBlock cmm) 0
@@ -58,7 +58,7 @@ countRegRegMovesNat cmm
-- | Pretty print some RegAllocStats
pprStats
:: Instruction instr
- => [NatCmmTop instr] -> [RegAllocStats] -> SDoc
+ => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc
pprStats code statss
= let -- sum up all the instrs inserted by the spiller
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index a2030fafa9..a6a3724bfa 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -66,9 +66,9 @@ type BlockMap a = BlockEnv a
-- | A top level thing which carries liveness information.
-type LiveCmmTop instr
+type LiveCmmTop statics instr
= GenCmmTop
- CmmStatic
+ statics
LiveInfo
[SCC (LiveBasicBlock instr)]
@@ -224,7 +224,7 @@ instance Outputable LiveInfo where
--
mapBlockTop
:: (LiveBasicBlock instr -> LiveBasicBlock instr)
- -> LiveCmmTop instr -> LiveCmmTop instr
+ -> LiveCmmTop statics instr -> LiveCmmTop statics instr
mapBlockTop f cmm
= evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
@@ -235,7 +235,7 @@ mapBlockTop f cmm
mapBlockTopM
:: Monad m
=> (LiveBasicBlock instr -> m (LiveBasicBlock instr))
- -> LiveCmmTop instr -> m (LiveCmmTop instr)
+ -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr)
mapBlockTopM _ cmm@(CmmData{})
= return cmm
@@ -283,7 +283,7 @@ mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
--
slurpConflicts
:: Instruction instr
- => LiveCmmTop instr
+ => LiveCmmTop statics instr
-> (Bag (UniqSet Reg), Bag (Reg, Reg))
slurpConflicts live
@@ -357,8 +357,8 @@ slurpConflicts live
--
--
slurpReloadCoalesce
- :: forall instr. Instruction instr
- => LiveCmmTop instr
+ :: forall statics instr. Instruction instr
+ => LiveCmmTop statics instr
-> Bag (Reg, Reg)
slurpReloadCoalesce live
@@ -458,9 +458,9 @@ slurpReloadCoalesce live
-- | Strip away liveness information, yielding NatCmmTop
stripLive
- :: (Outputable instr, Instruction instr)
- => LiveCmmTop instr
- -> NatCmmTop instr
+ :: (Outputable statics, Outputable instr, Instruction instr)
+ => LiveCmmTop statics instr
+ -> NatCmmTop statics instr
stripLive live
= stripCmm live
@@ -525,8 +525,8 @@ stripLiveBlock (BasicBlock i lis)
eraseDeltasLive
:: Instruction instr
- => LiveCmmTop instr
- -> LiveCmmTop instr
+ => LiveCmmTop statics instr
+ -> LiveCmmTop statics instr
eraseDeltasLive cmm
= mapBlockTop eraseBlock cmm
@@ -543,7 +543,7 @@ eraseDeltasLive cmm
patchEraseLive
:: Instruction instr
=> (Reg -> Reg)
- -> LiveCmmTop instr -> LiveCmmTop instr
+ -> LiveCmmTop statics instr -> LiveCmmTop statics instr
patchEraseLive patchF cmm
= patchCmm cmm
@@ -620,8 +620,8 @@ patchRegsLiveInstr patchF li
natCmmTopToLive
:: Instruction instr
- => NatCmmTop instr
- -> LiveCmmTop instr
+ => NatCmmTop statics instr
+ -> LiveCmmTop statics instr
natCmmTopToLive (CmmData i d)
= CmmData i d
@@ -658,8 +658,8 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
--
regLiveness
:: (Outputable instr, Instruction instr)
- => LiveCmmTop instr
- -> UniqSM (LiveCmmTop instr)
+ => LiveCmmTop statics instr
+ -> UniqSM (LiveCmmTop statics instr)
regLiveness (CmmData i d)
= returnUs $ CmmData i d
@@ -720,7 +720,7 @@ checkIsReverseDependent sccs'
-- | If we've compute liveness info for this code already we have to reverse
-- the SCCs in each top to get them back to the right order so we can do it again.
-reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
+reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr
reverseBlocksInTops top
= case top of
CmmData{} -> top
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index a4dbbe8771..72e4649eca 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -51,7 +51,7 @@ import Control.Monad ( mapAndUnzipM )
-- | Top level code generation
cmmTopCodeGen
:: RawCmmTop
- -> NatM [NatCmmTop Instr]
+ -> NatM [NatCmmTop CmmStatics Instr]
cmmTopCodeGen
(CmmProc info lab (ListGraph blocks))
@@ -75,7 +75,7 @@ cmmTopCodeGen (CmmData sec dat) = do
basicBlockCodeGen
:: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
- , [NatCmmTop Instr])
+ , [NatCmmTop CmmStatics Instr])
basicBlockCodeGen cmm@(BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
@@ -313,8 +313,8 @@ genSwitch expr ids
, JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
, NOP ]
-generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr)
generateJumpTableForInstr (JMP_TBL _ ids label) =
let jumpTable = map jumpTableEntry ids
- in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+ in Just (CmmData ReadOnlyData (Statics label jumpTable))
generateJumpTableForInstr _ = Nothing
diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
index d4500e8a8e..3e49f5c025 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
@@ -21,7 +21,7 @@ import Outputable
import OrdList
-- | Expand out synthetic instructions in this top level thing
-expandTop :: NatCmmTop Instr -> NatCmmTop Instr
+expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr
expandTop top@(CmmData{})
= top
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
index 9d6aa5e646..ddeed0508b 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
@@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do
let code dst = toOL [
-- the data area
- LDATA ReadOnlyData
- [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f W32)],
+ LDATA ReadOnlyData $ Statics lbl
+ [CmmStaticLit (CmmFloat f W32)],
-- load the literal
SETHI (HI (ImmCLbl lbl)) tmp,
@@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do
lbl <- getNewLabelNat
tmp <- getNewRegNat II32
let code dst = toOL [
- LDATA ReadOnlyData
- [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat d W64)],
+ LDATA ReadOnlyData $ Statics lbl
+ [CmmStaticLit (CmmFloat d W64)],
SETHI (HI (ImmCLbl lbl)) tmp,
LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
return (Any FF64 code)
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 93f4d27444..816af9ba2a 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -112,7 +112,7 @@ data Instr
-- some static data spat out during code generation.
-- Will be extracted before pretty-printing.
- | LDATA Section [CmmStatic]
+ | LDATA Section CmmStatics
-- Start a new basic block. Useful during codegen, removed later.
-- Preceding instruction should be a jump, as per the invariants
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index d78d1a760e..8563aab4fe 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -47,9 +47,9 @@ import Data.Word
-- -----------------------------------------------------------------------------
-- Printing this stuff out
-pprNatCmmTop :: NatCmmTop Instr -> Doc
+pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc
pprNatCmmTop (CmmData section dats) =
- pprSectionHeader section $$ vcat (map pprData dats)
+ pprSectionHeader section $$ pprDatas dats
-- special case for split markers:
pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
@@ -91,6 +91,9 @@ pprBasicBlock (BasicBlock blockid instrs) =
vcat (map pprInstr instrs)
+pprDatas :: CmmStatics -> Doc
+pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats))
+
pprData :: CmmStatic -> Doc
pprData (CmmAlign bytes) = pprAlign bytes
pprData (CmmDataLabel lbl) = pprLabel lbl
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
index 30e48bb377..10e2e9fbaa 100644
--- a/compiler/nativeGen/SPARC/ShortcutJump.hs
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -3,7 +3,7 @@ module SPARC.ShortcutJump (
JumpDest(..), getJumpDestBlockId,
canShortcut,
shortcutJump,
- shortcutStatic,
+ shortcutStatics,
shortBlockId
)
@@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump _ other = other
-shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
-shortcutStatic fn (CmmStaticLit (CmmLabel lab))
- | Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq)))
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+ = Statics lbl $ map (shortcutStatic fn) statics
+ -- we need to get the jump tables, so apply the mapping to the entries
+ -- of a CmmData too.
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
- | Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off)
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+ | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
+ | otherwise = lab
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+ = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
+ = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
shortcutStatic _ other_static
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index d191733af1..49ac543e65 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do
cmmTopCodeGen
:: RawCmmTop
- -> NatM [NatCmmTop Instr]
+ -> NatM [NatCmmTop (Alignment, CmmStatics) Instr]
cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
@@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
Nothing -> return tops
cmmTopCodeGen (CmmData sec dat) = do
- return [CmmData sec dat] -- no translation, we just use CmmStatic
+ return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic
basicBlockCodeGen
:: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
- , [NatCmmTop Instr])
+ , [NatCmmTop (Alignment, CmmStatics) Instr])
basicBlockCodeGen (BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
@@ -1123,10 +1123,7 @@ memConstant align lit = do
return (addr, addr_code)
else return (ripRel (ImmCLbl lbl), nilOL)
let code =
- LDATA ReadOnlyData
- [CmmAlign align,
- CmmDataLabel lbl,
- CmmStaticLit lit]
+ LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit])
`consOL` addr_code
return (Amode addr code)
@@ -2041,11 +2038,11 @@ genSwitch expr ids
-- in
return code
-generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr)
generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
generateJumpTableForInstr _ = Nothing
-createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g
+createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g
createJumpTable ids section lbl
= let jumpTable
| opt_PIC =
@@ -2056,7 +2053,7 @@ createJumpTable ids section lbl
where blockLabel = mkAsmTempLabel (getUnique blockid)
in map jumpTableEntryRel ids
| otherwise = map jumpTableEntry ids
- in CmmData section (CmmDataLabel lbl : jumpTable)
+ in CmmData section (1, Statics lbl jumpTable)
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index b9c851a859..0e70dbb503 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -27,6 +27,7 @@ import FastBool
import Outputable
import Constants (rESERVED_C_STACK_BYTES)
+import BasicTypes (Alignment)
import CLabel
import UniqSet
import Unique
@@ -151,7 +152,6 @@ bit precision.
--SDM 1/2003
-}
-
data Instr
-- comment pseudo-op
= COMMENT FastString
@@ -159,7 +159,7 @@ data Instr
-- some static data spat out during code
-- generation. Will be extracted before
-- pretty-printing.
- | LDATA Section [CmmStatic]
+ | LDATA Section (Alignment, CmmStatics)
-- start a new basic block. Useful during
-- codegen, removed later. Preceding
@@ -805,16 +805,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn
shortcutJump' _ _ other = other
-- Here because it knows about JumpDest
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
+shortcutStatics fn (align, Statics lbl statics)
+ = (align, Statics lbl $ map (shortcutStatic fn) statics)
+ -- we need to get the jump tables, so apply the mapping to the entries
+ -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+ | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq)
+ | otherwise = lab
+
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
- | Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq)))
+ = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
- | Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
-
shortcutStatic _ other_static
= other_static
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 769057ae02..676e4c828b 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -31,6 +31,7 @@ import Reg
import PprBase
+import BasicTypes (Alignment)
import OldCmm
import CLabel
import Unique ( pprUnique, Uniquable(..) )
@@ -48,9 +49,9 @@ import Data.Bits
-- -----------------------------------------------------------------------------
-- Printing this stuff out
-pprNatCmmTop :: NatCmmTop Instr -> Doc
+pprNatCmmTop :: NatCmmTop (Alignment, CmmStatics) Instr -> Doc
pprNatCmmTop (CmmData section dats) =
- pprSectionHeader section $$ vcat (map pprData dats)
+ pprSectionHeader section $$ pprDatas dats
-- special case for split markers:
pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
@@ -102,6 +103,9 @@ pprBasicBlock (BasicBlock blockid instrs) =
vcat (map pprInstr instrs)
+pprDatas :: (Alignment, CmmStatics) -> Doc
+pprDatas (align, (Statics lbl dats)) = vcat (map pprData (CmmAlign align:CmmDataLabel lbl:dats)) -- TODO: could remove if align == 1
+
pprData :: CmmStatic -> Doc
pprData (CmmAlign bytes) = pprAlign bytes
pprData (CmmDataLabel lbl) = pprLabel lbl