summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2011-10-02 01:31:05 +0100
committerIan Lynagh <igloo@earth.li>2011-10-02 16:39:08 +0100
commitac7a7eb93397a2343402f77f1a8a8b4a0e0298df (patch)
tree86fae1d7598b2ddb94b1c00906468eb54af9a48e /compiler/cmm
parentd8d161749c8b13c3db802f348761cff662741c53 (diff)
downloadhaskell-ac7a7eb93397a2343402f77f1a8a8b4a0e0298df.tar.gz
More CPP removal: pprDynamicLinkerAsmLabel in CLabel
And some knock-on changes
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs193
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs30
-rw-r--r--compiler/cmm/CmmInfo.hs27
-rw-r--r--compiler/cmm/CmmLint.hs113
-rw-r--r--compiler/cmm/CmmPipeline.hs9
-rw-r--r--compiler/cmm/OldCmm.hs11
-rw-r--r--compiler/cmm/OldPprCmm.hs100
-rw-r--r--compiler/cmm/PprC.hs253
-rw-r--r--compiler/cmm/PprCmm.hs83
-rw-r--r--compiler/cmm/PprCmmDecl.hs64
-rw-r--r--compiler/cmm/PprCmmExpr.hs87
11 files changed, 482 insertions, 488 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 76d5e79a21..de27f18a71 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -263,23 +263,23 @@ data ForeignLabelSource
-- We can't make a Show instance for CLabel because lots of its components don't have instances.
-- The regular Outputable instance only shows the label name, and not its other info.
--
-pprDebugCLabel :: CLabel -> SDoc
-pprDebugCLabel lbl
+pprDebugCLabel :: Platform -> CLabel -> SDoc
+pprDebugCLabel platform lbl
= case lbl of
- IdLabel{} -> ppr lbl <> (parens $ text "IdLabel")
+ IdLabel{} -> pprPlatform platform lbl <> (parens $ text "IdLabel")
CmmLabel pkg name _info
- -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+ -> pprPlatform platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
- RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel")
+ RtsLabel{} -> pprPlatform platform lbl <> (parens $ text "RtsLabel")
ForeignLabel name mSuffix src funOrData
- -> ppr lbl <> (parens
+ -> pprPlatform platform lbl <> (parens
$ text "ForeignLabel"
<+> ppr mSuffix
<+> ppr src
<+> ppr funOrData)
- _ -> ppr lbl <> (parens $ text "other CLabel)")
+ _ -> pprPlatform platform lbl <> (parens $ text "other CLabel)")
-- True if a local IdLabel that we won't mark as exported
@@ -509,38 +509,38 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-- -----------------------------------------------------------------------------
-- Convert between different kinds of label
-toClosureLbl :: CLabel -> CLabel
-toClosureLbl (IdLabel n c _) = IdLabel n c Closure
-toClosureLbl l = pprPanic "toClosureLbl" (pprCLabel l)
-
-toSlowEntryLbl :: CLabel -> CLabel
-toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow
-toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (pprCLabel l)
-
-toRednCountsLbl :: CLabel -> CLabel
-toRednCountsLbl (IdLabel n c _) = IdLabel n c RednCounts
-toRednCountsLbl l = pprPanic "toRednCountsLbl" (pprCLabel l)
-
-toEntryLbl :: CLabel -> CLabel
-toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
-toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
-toEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
-toEntryLbl (IdLabel n c _) = IdLabel n c Entry
-toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
-toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
-toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet
-toEntryLbl l = pprPanic "toEntryLbl" (pprCLabel l)
-
-toInfoLbl :: CLabel -> CLabel
-toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
-toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable
-toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
-toInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
-toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable
-toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
-toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo
-toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo
-toInfoLbl l = pprPanic "CLabel.toInfoLbl" (pprCLabel l)
+toClosureLbl :: Platform -> CLabel -> CLabel
+toClosureLbl _ (IdLabel n c _) = IdLabel n c Closure
+toClosureLbl platform l = pprPanic "toClosureLbl" (pprCLabel platform l)
+
+toSlowEntryLbl :: Platform -> CLabel -> CLabel
+toSlowEntryLbl _ (IdLabel n c _) = IdLabel n c Slow
+toSlowEntryLbl platform l = pprPanic "toSlowEntryLbl" (pprCLabel platform l)
+
+toRednCountsLbl :: Platform -> CLabel -> CLabel
+toRednCountsLbl _ (IdLabel n c _) = IdLabel n c RednCounts
+toRednCountsLbl platform l = pprPanic "toRednCountsLbl" (pprCLabel platform l)
+
+toEntryLbl :: Platform -> CLabel -> CLabel
+toEntryLbl _ (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
+toEntryLbl _ (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
+toEntryLbl _ (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
+toEntryLbl _ (IdLabel n c _) = IdLabel n c Entry
+toEntryLbl _ (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+toEntryLbl _ (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
+toEntryLbl _ (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet
+toEntryLbl platform l = pprPanic "toEntryLbl" (pprCLabel platform l)
+
+toInfoLbl :: Platform -> CLabel -> CLabel
+toInfoLbl _ (IdLabel n c Entry) = IdLabel n c InfoTable
+toInfoLbl _ (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable
+toInfoLbl _ (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
+toInfoLbl _ (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
+toInfoLbl _ (IdLabel n c _) = IdLabel n c InfoTable
+toInfoLbl _ (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+toInfoLbl _ (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo
+toInfoLbl _ (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo
+toInfoLbl platform l = pprPanic "CLabel.toInfoLbl" (pprCLabel platform l)
-- -----------------------------------------------------------------------------
-- Does a CLabel refer to a CAF?
@@ -891,14 +891,12 @@ Not exporting these Just_info labels reduces the number of symbols
somewhat.
-}
-instance Outputable CLabel where
- ppr = pprCLabel
instance PlatformOutputable CLabel where
- pprPlatform _ = pprCLabel
+ pprPlatform = pprCLabel
-pprCLabel :: CLabel -> SDoc
+pprCLabel :: Platform -> CLabel -> SDoc
-pprCLabel (AsmTempLabel u)
+pprCLabel _ (AsmTempLabel u)
| cGhcWithNativeCodeGen == "YES"
= getPprStyle $ \ sty ->
if asmStyle sty then
@@ -906,19 +904,19 @@ pprCLabel (AsmTempLabel u)
else
char '_' <> pprUnique u
-pprCLabel (DynamicLinkerLabel info lbl)
+pprCLabel platform (DynamicLinkerLabel info lbl)
| cGhcWithNativeCodeGen == "YES"
- = pprDynamicLinkerAsmLabel info lbl
+ = pprDynamicLinkerAsmLabel platform info lbl
-pprCLabel PicBaseLabel
+pprCLabel _ PicBaseLabel
| cGhcWithNativeCodeGen == "YES"
= ptext (sLit "1b")
-pprCLabel (DeadStripPreventer lbl)
+pprCLabel platform (DeadStripPreventer lbl)
| cGhcWithNativeCodeGen == "YES"
- = pprCLabel lbl <> ptext (sLit "_dsp")
+ = pprCLabel platform lbl <> ptext (sLit "_dsp")
-pprCLabel lbl
+pprCLabel _ lbl
= getPprStyle $ \ sty ->
if cGhcWithNativeCodeGen == "YES" && asmStyle sty
then maybe_underscore (pprAsmCLbl lbl)
@@ -1072,63 +1070,40 @@ asmTempLabelPrefix =
(sLit ".L")
#endif
-pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo lbl
+ = if platform == Platform ArchX86_64 OSDarwin
+ then case dllInfo of
+ CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub"
+ SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr"
+ GotSymbolPtr -> pprCLabel platform lbl <> text "@GOTPCREL"
+ GotSymbolOffset -> pprCLabel platform lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else if platformOS platform == OSDarwin
+ then case dllInfo of
+ CodeStub -> char 'L' <> pprCLabel platform lbl <> text "$stub"
+ SymbolPtr -> char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr"
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else if platformArch platform == ArchPPC && osElfTarget (platformOS platform)
+ then case dllInfo of
+ CodeStub -> pprCLabel platform lbl <> text "@plt"
+ SymbolPtr -> text ".LC_" <> pprCLabel platform lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else if platformArch platform == ArchX86_64 && osElfTarget (platformOS platform)
+ then case dllInfo of
+ CodeStub -> pprCLabel platform lbl <> text "@plt"
+ GotSymbolPtr -> pprCLabel platform lbl <> text "@gotpcrel"
+ GotSymbolOffset -> pprCLabel platform lbl
+ SymbolPtr -> text ".LC_" <> pprCLabel platform lbl
+ else if osElfTarget (platformOS platform)
+ then case dllInfo of
+ CodeStub -> pprCLabel platform lbl <> text "@plt"
+ SymbolPtr -> text ".LC_" <> pprCLabel platform lbl
+ GotSymbolPtr -> pprCLabel platform lbl <> text "@got"
+ GotSymbolOffset -> pprCLabel platform lbl <> text "@gotoff"
+ else if platformOS platform == OSMinGW32
+ then case dllInfo of
+ SymbolPtr -> text "__imp_" <> pprCLabel platform lbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ else panic "pprDynamicLinkerAsmLabel"
-#if x86_64_TARGET_ARCH && darwin_TARGET_OS
-pprDynamicLinkerAsmLabel CodeStub lbl
- = char 'L' <> pprCLabel lbl <> text "$stub"
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
-pprDynamicLinkerAsmLabel GotSymbolPtr lbl
- = pprCLabel lbl <> text "@GOTPCREL"
-pprDynamicLinkerAsmLabel GotSymbolOffset lbl
- = pprCLabel lbl
-pprDynamicLinkerAsmLabel _ _
- = panic "pprDynamicLinkerAsmLabel"
-
-#elif darwin_TARGET_OS
-pprDynamicLinkerAsmLabel CodeStub lbl
- = char 'L' <> pprCLabel lbl <> text "$stub"
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
-pprDynamicLinkerAsmLabel _ _
- = panic "pprDynamicLinkerAsmLabel"
-
-#elif powerpc_TARGET_ARCH && elf_OBJ_FORMAT
-pprDynamicLinkerAsmLabel CodeStub lbl
- = pprCLabel lbl <> text "@plt"
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = text ".LC_" <> pprCLabel lbl
-pprDynamicLinkerAsmLabel _ _
- = panic "pprDynamicLinkerAsmLabel"
-
-#elif x86_64_TARGET_ARCH && elf_OBJ_FORMAT
-pprDynamicLinkerAsmLabel CodeStub lbl
- = pprCLabel lbl <> text "@plt"
-pprDynamicLinkerAsmLabel GotSymbolPtr lbl
- = pprCLabel lbl <> text "@gotpcrel"
-pprDynamicLinkerAsmLabel GotSymbolOffset lbl
- = pprCLabel lbl
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = text ".LC_" <> pprCLabel lbl
-
-#elif elf_OBJ_FORMAT
-pprDynamicLinkerAsmLabel CodeStub lbl
- = pprCLabel lbl <> text "@plt"
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = text ".LC_" <> pprCLabel lbl
-pprDynamicLinkerAsmLabel GotSymbolPtr lbl
- = pprCLabel lbl <> text "@got"
-pprDynamicLinkerAsmLabel GotSymbolOffset lbl
- = pprCLabel lbl <> text "@gotoff"
-
-#elif mingw32_TARGET_OS
-pprDynamicLinkerAsmLabel SymbolPtr lbl
- = text "__imp_" <> pprCLabel lbl
-pprDynamicLinkerAsmLabel _ _
- = panic "pprDynamicLinkerAsmLabel"
-
-#else
-pprDynamicLinkerAsmLabel _ _
- = panic "pprDynamicLinkerAsmLabel"
-#endif
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 699f1003b6..0301deb593 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -44,6 +44,7 @@ import Control.Monad
import Name
import OptimizationFuel
import Outputable
+import Platform
import SMRep
import UniqSupply
@@ -193,8 +194,8 @@ cafLattice = DataflowLattice "live cafs" Map.empty add
where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
new' -> (changeIf $ Map.size new' > Map.size old, new')
-cafTransfers :: BwdTransfer CmmNode CAFSet
-cafTransfers = mkBTransfer3 first middle last
+cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
+cafTransfers platform = mkBTransfer3 first middle last
where first _ live = live
middle m live = foldExpDeep addCaf m live
last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
@@ -203,10 +204,12 @@ cafTransfers = mkBTransfer3 first middle last
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
- add l s = if hasCAF l then Map.insert (toClosureLbl l) () s else s
+ add l s = if hasCAF l then Map.insert (toClosureLbl platform l) () s
+ else s
-cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
-cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
+cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv
+cafAnal platform g
+ = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice (cafTransfers platform)
-----------------------------------------------------------------------
-- Building the SRTs
@@ -218,9 +221,12 @@ data TopSRT = TopSRT { lbl :: CLabel
, rev_elts :: [CLabel]
, elt_map :: Map CLabel Int }
-- map: CLabel -> its last entry in the table
-instance Outputable TopSRT where
- ppr (TopSRT lbl next elts eltmap) =
- text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap
+instance PlatformOutputable TopSRT where
+ pprPlatform platform (TopSRT lbl next elts eltmap) =
+ text "TopSRT:" <+> pprPlatform platform lbl
+ <+> ppr next
+ <+> pprPlatform platform elts
+ <+> pprPlatform platform eltmap
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
@@ -335,13 +341,13 @@ to_SRT top_srt off len bmp
-- keep its CAFs live.)
-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
-localCAFInfo _ (CmmData _ _) = Nothing
-localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
+localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
+localCAFInfo _ _ (CmmData _ _) = Nothing
+localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of
CmmInfoTable { cit_rep = rep }
| not (isStaticRep rep)
- -> Just (toClosureLbl top_l,
+ -> Just (toClosureLbl platform top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index a11b61cb91..15f255472f 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -16,6 +16,7 @@ import Bitmap
import Maybes
import Constants
import Panic
+import Platform
import StaticFlags
import UniqSupply
import MonadUtils
@@ -30,10 +31,10 @@ mkEmptyContInfoTable info_lbl
, cit_prof = NoProfilingInfo
, cit_srt = NoC_SRT }
-cmmToRawCmm :: [Old.CmmGroup] -> IO [Old.RawCmmGroup]
-cmmToRawCmm cmms
+cmmToRawCmm :: Platform -> [Old.CmmGroup] -> IO [Old.RawCmmGroup]
+cmmToRawCmm platform cmms
= do { uniqs <- mkSplitUniqSupply 'i'
- ; return (initUs_ uniqs (mapM (concatMapM mkInfoTable) cmms)) }
+ ; return (initUs_ uniqs (mapM (concatMapM (mkInfoTable platform)) cmms)) }
-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
@@ -68,16 +69,16 @@ cmmToRawCmm cmms
--
-- * The SRT slot is only there if there is SRT info to record
-mkInfoTable :: CmmDecl -> UniqSM [RawCmmDecl]
-mkInfoTable (CmmData sec dat)
+mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
-mkInfoTable (CmmProc (CmmInfo _ _ info) entry_label blocks)
+mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks)
| CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info
- = do { (top_decls, info_cts) <- mkInfoTableContents info Nothing
+ = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
@@ -88,18 +89,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part
, [CmmLit] ) -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them
-mkInfoTableContents :: CmmInfoTable
+mkInfoTableContents :: Platform
+ -> CmmInfoTable
-> Maybe StgHalfWord -- Override default RTS type tag?
-> UniqSM ([RawCmmDecl], -- Auxiliary top decls
InfoTableContents) -- Info tbl + extra bits
-mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl
+mkInfoTableContents platform
+ info@(CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep
, cit_prof = prof
, cit_srt = srt })
mb_rts_tag
| RTSRep rts_tag rep <- smrep
- = mkInfoTableContents info{cit_rep = rep} (Just rts_tag)
+ = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag)
-- Completely override the rts_tag that mkInfoTableContents would
-- otherwise compute, with the rts_tag stored in the RTSRep
-- (which in turn came from a handwritten .cmm file)
@@ -156,7 +159,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl
, srt_lit, liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
where
- slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+ slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
srt_lit = case srt_label of
[] -> mkIntCLit 0
(lit:_rest) -> ASSERT( null _rest ) lit
@@ -164,7 +167,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl
mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
-mkInfoTableContents _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
+mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
mkSRTLit :: C_SRT
-> ([CmmLit], -- srt_label, if any
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 8229d33f00..ff41d58a32 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -30,13 +30,13 @@ import Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
-cmmLint :: (Outputable d, Outputable h)
+cmmLint :: (PlatformOutputable d, PlatformOutputable h)
=> Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
+cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops
-cmmLintTop :: (Outputable d, Outputable h)
+cmmLintTop :: (PlatformOutputable d, PlatformOutputable h)
=> Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop platform top = runCmmLint platform lintCmmDecl top
+cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top
runCmmLint :: PlatformOutputable a
=> Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
@@ -48,19 +48,19 @@ runCmmLint platform l p =
nest 2 (pprPlatform platform p)])
Right _ -> Nothing
-lintCmmDecl :: (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmDecl (CmmProc _ lbl (ListGraph blocks))
- = addLintInfo (text "in proc " <> pprCLabel lbl) $
+lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
+lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks))
+ = addLintInfo (text "in proc " <> pprCLabel platform lbl) $
let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
- in mapM_ (lintCmmBlock labels) blocks
+ in mapM_ (lintCmmBlock platform labels) blocks
-lintCmmDecl (CmmData {})
+lintCmmDecl _ (CmmData {})
= return ()
-lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
-lintCmmBlock labels (BasicBlock id stmts)
+lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
+lintCmmBlock platform labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr id) $
- mapM_ (lintCmmStmt labels) stmts
+ mapM_ (lintCmmStmt platform labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
@@ -68,24 +68,24 @@ lintCmmBlock labels (BasicBlock id stmts)
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
-lintCmmExpr :: CmmExpr -> CmmLint CmmType
-lintCmmExpr (CmmLoad expr rep) = do
- _ <- lintCmmExpr expr
+lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType
+lintCmmExpr platform (CmmLoad expr rep) = do
+ _ <- lintCmmExpr platform expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return rep
-lintCmmExpr expr@(CmmMachOp op args) = do
- tys <- mapM lintCmmExpr args
+lintCmmExpr platform expr@(CmmMachOp op args) = do
+ tys <- mapM (lintCmmExpr platform) args
if map (typeWidth . cmmExprType) args == machOpArgReps op
then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
-lintCmmExpr (CmmRegOff reg offset)
- = lintCmmExpr (CmmMachOp (MO_Add rep)
+ else cmmLintMachOpErr platform expr (map cmmExprType args) (machOpArgReps op)
+lintCmmExpr platform (CmmRegOff reg offset)
+ = lintCmmExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType reg)
-lintCmmExpr expr =
+lintCmmExpr _ expr =
return (cmmExprType expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
@@ -102,14 +102,14 @@ isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
-_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+_cmmCheckWordAddress :: Platform -> CmmExpr -> CmmLint ()
+_cmmCheckWordAddress platform e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
- = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+ = cmmLintDubiousWordOffset platform e
+_cmmCheckWordAddress platform e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
- = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress _
+ = cmmLintDubiousWordOffset platform e
+_cmmCheckWordAddress _ _
= return ()
-- No warnings for unaligned arithmetic with the node register,
@@ -118,46 +118,47 @@ notNodeReg :: CmmExpr -> Bool
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
-lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
-lintCmmStmt labels = lint
+lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
+lintCmmStmt platform labels = lint
where lint (CmmNop) = return ()
lint (CmmComment {}) = return ()
lint stmt@(CmmAssign reg expr) = do
- erep <- lintCmmExpr expr
+ erep <- lintCmmExpr platform expr
let reg_ty = cmmRegType reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
- else cmmLintAssignErr stmt erep reg_ty
+ else cmmLintAssignErr platform stmt erep reg_ty
lint (CmmStore l r) = do
- _ <- lintCmmExpr l
- _ <- lintCmmExpr r
+ _ <- lintCmmExpr platform l
+ _ <- lintCmmExpr platform r
return ()
lint (CmmCall target _res args _ _) =
- lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
- lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
+ lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
+ lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
- erep <- lintCmmExpr e
+ erep <- lintCmmExpr platform e
if (erep `cmmEqType_ignoring_ptrhood` bWord)
then return ()
- else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
+ else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
text " :: " <> ppr erep)
- lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
- lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
+ lint (CmmJump e args) = lintCmmExpr platform e >> mapM_ (lintCmmExpr platform . hintlessCmm) args
+ lint (CmmReturn ress) = mapM_ (lintCmmExpr platform . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-lintTarget :: CmmCallTarget -> CmmLint ()
-lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
-lintTarget (CmmPrim {}) = return ()
+lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
+lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
+lintTarget _ (CmmPrim {}) = return ()
-checkCond :: CmmExpr -> CmmLint ()
-checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
-checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
- (ppr expr))
+checkCond :: Platform -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
+checkCond platform expr
+ = cmmLintErr (hang (text "expression is not a conditional:") 2
+ (pprPlatform platform expr))
-- -----------------------------------------------------------------------------
-- CmmLint monad
@@ -181,23 +182,23 @@ addLintInfo info thing = CmmLint $
Left err -> Left (hang info 2 err)
Right a -> Right a
-cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
-cmmLintMachOpErr expr argsRep opExpectsRep
+cmmLintMachOpErr :: Platform -> CmmExpr -> [CmmType] -> [Width] -> CmmLint a
+cmmLintMachOpErr platform expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
- nest 2 (ppr expr) $$
+ nest 2 (pprPlatform platform expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
-cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
-cmmLintAssignErr stmt e_ty r_ty
+cmmLintAssignErr :: Platform -> CmmStmt -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr platform stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
- nest 2 (vcat [ppr stmt,
+ nest 2 (vcat [pprPlatform platform stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
-cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
-cmmLintDubiousWordOffset expr
+cmmLintDubiousWordOffset :: Platform -> CmmExpr -> CmmLint a
+cmmLintDubiousWordOffset platform expr
= cmmLintErr (text "offset is not a multiple of words: " $$
- nest 2 (ppr expr))
+ nest 2 (pprPlatform platform expr))
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 3c7e3ed6a2..8ab1601e2c 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -70,7 +70,8 @@ cmmPipeline hsc_env (topSRT, rst) prog =
-- folding over the groups
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
- let cmms = reverse (concat tops)
+ let cmms :: CmmGroup
+ cmms = reverse (concat tops)
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
@@ -148,9 +149,9 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
- cafEnv <- run $ cafAnal g
- let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
- mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+ cafEnv <- run $ cafAnal platform g
+ let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
+ mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 36d00bd991..6b71fd66a8 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -12,7 +12,6 @@ module OldCmm (
CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..),
CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
cmmMapGraph, cmmTopMapGraph,
- cmmMapGraphM, cmmTopMapGraphM,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
HintedCmmFormal, HintedCmmActual,
@@ -35,7 +34,6 @@ import BlockId
import CmmExpr
import ForeignCall
import ClosureInfo
-import Outputable
import FastString
@@ -121,19 +119,10 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g'
cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
-cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmGroup d h g -> m (GenCmmGroup d h g')
-cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmDecl d h g -> m (GenCmmDecl d h g')
-
cmmMapGraph f tops = map (cmmTopMapGraph f) tops
cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g)
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
-cmmMapGraphM f tops = mapM (cmmTopMapGraphM f) tops
-cmmTopMapGraphM f (CmmProc h l g) =
- f (showSDoc $ ppr l) g >>= return . CmmProc h l
-cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds
-
-
data CmmReturnInfo = CmmMayReturn
| CmmNeverReturns
deriving ( Eq )
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
index b31cc96dbc..d2f03f78b7 100644
--- a/compiler/cmm/OldPprCmm.hs
+++ b/compiler/cmm/OldPprCmm.hs
@@ -63,20 +63,18 @@ instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
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
+ pprPlatform = pprStmt
-instance Outputable CmmInfo where
- ppr e = pprInfo e
+instance PlatformOutputable CmmInfo where
+ pprPlatform = pprInfo
-- --------------------------------------------------------------------------
-instance Outputable CmmSafety where
- ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
- ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
- ppr (CmmSafe srt) = ppr srt
+instance PlatformOutputable CmmSafety where
+ pprPlatform _ CmmUnsafe = ptext (sLit "_unsafe_call_")
+ pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_")
+ pprPlatform platform (CmmSafe srt) = pprPlatform platform srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
@@ -85,13 +83,15 @@ instance Outputable CmmSafety where
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
-pprInfo :: CmmInfo -> SDoc
-pprInfo (CmmInfo _gc_target update_frame info_table) =
+pprInfo :: Platform -> CmmInfo -> SDoc
+pprInfo platform (CmmInfo _gc_target update_frame info_table) =
vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) ppr gc_target,-}
ptext (sLit "update_frame: ") <>
- maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
- ppr info_table]
+ maybe (ptext (sLit "<none>"))
+ (pprUpdateFrame platform)
+ update_frame,
+ pprPlatform platform info_table]
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
@@ -103,8 +103,8 @@ pprBBlock platform (BasicBlock ident stmts) =
-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
--
-pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
+pprStmt :: Platform -> CmmStmt -> SDoc
+pprStmt platform stmt = case stmt of
-- ;
CmmNop -> semi
@@ -113,10 +113,10 @@ pprStmt stmt = case stmt of
CmmComment s -> text "//" <+> ftext s
-- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+ CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi
-- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi
where
rep = ppr ( cmmExprType expr )
@@ -124,9 +124,9 @@ pprStmt stmt = case stmt of
-- ToDo ppr volatile
CmmCall (CmmCallee fn cconv) results args safety ret ->
sep [ pp_lhs <+> pp_conv
- , nest 2 (pprExpr9 fn <>
+ , nest 2 (pprExpr9 platform fn <>
parens (commafy (map ppr_ar args)))
- <> brackets (ppr safety)
+ <> brackets (pprPlatform platform safety)
, case ret of CmmMayReturn -> empty
CmmNeverReturns -> ptext $ sLit (" never returns")
] <> semi
@@ -135,16 +135,16 @@ pprStmt stmt = case stmt of
| otherwise = commafy (map ppr_ar results) <+> equals
-- Don't print the hints on a native C-- call
ppr_ar (CmmHinted ar k) = case cconv of
- CmmCallConv -> ppr ar
- _ -> ppr (ar,k)
+ CmmCallConv -> pprPlatform platform ar
+ _ -> pprPlatform platform (ar,k)
pp_conv = case cconv of
CmmCallConv -> empty
_ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
CmmCall (CmmPrim op) results args safety ret ->
- pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
- results args safety ret)
+ pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+ results args safety ret)
where
-- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
-- use one to get the label printed.
@@ -153,27 +153,29 @@ pprStmt stmt = case stmt of
Nothing ForeignLabelInThisPackage IsFunction)
CmmBranch ident -> genBranch ident
- CmmCondBranch expr ident -> genCondBranch expr ident
- CmmJump expr params -> genJump expr params
- CmmReturn params -> genReturn params
- CmmSwitch arg ids -> genSwitch arg ids
+ CmmCondBranch expr ident -> genCondBranch platform expr ident
+ CmmJump expr params -> genJump platform expr params
+ CmmReturn params -> genReturn platform params
+ CmmSwitch arg ids -> genSwitch platform arg ids
-- Just look like a tuple, since it was a tuple before
-- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k)
+instance (PlatformOutputable a) => PlatformOutputable (CmmHinted a) where
+ pprPlatform platform (CmmHinted a k) = pprPlatform platform (a, k)
-pprUpdateFrame :: UpdateFrame -> SDoc
-pprUpdateFrame (UpdateFrame expr args) =
+pprUpdateFrame :: Platform -> UpdateFrame -> SDoc
+pprUpdateFrame platform (UpdateFrame expr args) =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
- then pprExpr expr
+ then pprExpr platform expr
else case expr of
- CmmLoad (CmmReg _) _ -> pprExpr expr
- _ -> parens (pprExpr expr)
+ CmmLoad (CmmReg _) _ -> pprExpr platform expr
+ _ -> parens (pprExpr platform expr)
, space
- , parens ( commafy $ map ppr args ) ]
+ , parens ( commafy $ map (pprPlatform platform) args ) ]
-- --------------------------------------------------------------------------
@@ -190,10 +192,10 @@ genBranch ident =
--
-- if (expr) { goto lbl; }
--
-genCondBranch :: CmmExpr -> BlockId -> SDoc
-genCondBranch expr ident =
+genCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc
+genCondBranch platform expr ident =
hsep [ ptext (sLit "if")
- , parens(ppr expr)
+ , parens(pprPlatform platform expr)
, ptext (sLit "goto")
, ppr ident <> semi ]
@@ -202,17 +204,17 @@ genCondBranch expr ident =
--
-- jump foo(a, b, c);
--
-genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
-genJump expr args =
+genJump :: Platform -> CmmExpr -> [CmmHinted CmmExpr] -> SDoc
+genJump platform expr args =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
- then pprExpr expr
+ then pprExpr platform expr
else case expr of
- CmmLoad (CmmReg _) _ -> pprExpr expr
- _ -> parens (pprExpr expr)
+ CmmLoad (CmmReg _) _ -> pprExpr platform expr
+ _ -> parens (pprExpr platform expr)
, space
- , parens ( commafy $ map ppr args )
+ , parens ( commafy $ map (pprPlatform platform) args )
, semi ]
@@ -221,11 +223,11 @@ genJump expr args =
--
-- return (a, b, c);
--
-genReturn :: [CmmHinted CmmExpr] -> SDoc
-genReturn args =
+genReturn :: Platform -> [CmmHinted CmmExpr] -> SDoc
+genReturn platform args =
hcat [ ptext (sLit "return")
, space
- , parens ( commafy $ map ppr args )
+ , parens ( commafy $ map (pprPlatform platform) args )
, semi ]
-- --------------------------------------------------------------------------
@@ -235,8 +237,8 @@ genReturn args =
--
-- switch [0 .. n] (expr) { case ... ; }
--
-genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
-genSwitch expr maybe_ids
+genSwitch :: Platform -> CmmExpr -> [Maybe BlockId] -> SDoc
+genSwitch platform expr maybe_ids
= let pairs = groupBy snds (zip [0 .. ] maybe_ids )
@@ -244,8 +246,8 @@ genSwitch expr maybe_ids
, int (length maybe_ids - 1)
, ptext (sLit "] ")
, if isTrivialCmmExpr expr
- then pprExpr expr
- else parens (pprExpr expr)
+ then pprExpr platform expr
+ else parens (pprExpr platform expr)
, ptext (sLit " {")
])
4 (vcat ( map caseify pairs )) $$ rbrace
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 3afdaf1100..78cd6990ba 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -36,6 +36,7 @@ import Unique
import UniqSet
import FastString
import Outputable
+import Platform
import Constants
import Util
@@ -67,7 +68,7 @@ import Control.Monad.ST
pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
pprCs dflags cmms
- = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC (targetPlatform dflags) c) cmms)
where
split_marker
| dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
@@ -83,57 +84,57 @@ writeCs dflags handle cmms
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: RawCmmGroup -> SDoc
-pprC tops = vcat $ intersperse blankLine $ map pprTop tops
+pprC :: Platform -> RawCmmGroup -> SDoc
+pprC platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops
--
-- top level procs
--
-pprTop :: RawCmmDecl -> SDoc
-pprTop (CmmProc mb_info clbl (ListGraph blocks)) =
+pprTop :: Platform -> RawCmmDecl -> SDoc
+pprTop platform (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) $$
+ Just (Statics info_clbl info_dat) -> pprDataExterns platform info_dat $$
+ pprWordArray platform info_clbl info_dat) $$
(vcat [
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
- then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
+ then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
nest 8 temp_decls,
nest 8 mkFB_,
case blocks of
[] -> empty
-- the first block doesn't get a label:
(BasicBlock _ stmts : rest) ->
- nest 8 (vcat (map pprStmt stmts)) $$
- vcat (map pprBBlock rest),
+ nest 8 (vcat (map (pprStmt platform) stmts)) $$
+ vcat (map (pprBBlock platform) rest),
nest 8 mkFE_,
rbrace ]
)
where
- (temp_decls, extern_decls) = pprTempAndExternDecls blocks
+ (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
-- Chunks of static data.
-- We only handle (a) arrays of word-sized things and (b) strings.
-pprTop (CmmData _section (Statics lbl [CmmString str])) =
+pprTop platform (CmmData _section (Statics lbl [CmmString str])) =
hcat [
- pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
+ pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
ptext (sLit "[] = "), pprStringInCStyle str, semi
]
-pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
+pprTop platform (CmmData _section (Statics lbl [CmmUninitialised size])) =
hcat [
- pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
+ pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
brackets (int size), semi
]
-pprTop (CmmData _section (Statics lbl lits)) =
- pprDataExterns lits $$
- pprWordArray lbl lits
+pprTop platform (CmmData _section (Statics lbl lits)) =
+ pprDataExterns platform lits $$
+ pprWordArray platform lbl lits
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
@@ -142,24 +143,24 @@ pprTop (CmmData _section (Statics lbl lits)) =
-- as many jumps as possible into fall throughs.
--
-pprBBlock :: CmmBasicBlock -> SDoc
-pprBBlock (BasicBlock lbl stmts) =
+pprBBlock :: Platform -> CmmBasicBlock -> SDoc
+pprBBlock platform (BasicBlock lbl stmts) =
if null stmts then
pprTrace "pprC.pprBBlock: curious empty code block for"
(pprBlockId lbl) empty
else
nest 4 (pprBlockId lbl <> colon) $$
- nest 8 (vcat (map pprStmt stmts))
+ nest 8 (vcat (map (pprStmt platform) stmts))
-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach
-pprWordArray :: CLabel -> [CmmStatic] -> SDoc
-pprWordArray lbl ds
+pprWordArray :: Platform -> CLabel -> [CmmStatic] -> SDoc
+pprWordArray platform lbl ds
= hcat [ pprLocalness lbl, ptext (sLit "StgWord")
- , space, pprCLabel lbl, ptext (sLit "[] = {") ]
- $$ nest 8 (commafy (pprStatics ds))
+ , space, pprCLabel platform lbl, ptext (sLit "[] = {") ]
+ $$ nest 8 (commafy (pprStatics platform ds))
$$ ptext (sLit "};")
--
@@ -173,9 +174,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
-- Statements.
--
-pprStmt :: CmmStmt -> SDoc
+pprStmt :: Platform -> CmmStmt -> SDoc
-pprStmt stmt = case stmt of
+pprStmt platform stmt = case stmt of
CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away"
CmmNop -> empty
CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
@@ -184,16 +185,16 @@ pprStmt stmt = case stmt of
-- some debugging option is on. They can get quite
-- large.
- CmmAssign dest src -> pprAssign dest src
+ CmmAssign dest src -> pprAssign platform dest src
CmmStore dest src
| typeWidth rep == W64 && wordWidth /= W64
-> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
else ptext (sLit ("ASSIGN_Word64"))) <>
- parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+ parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi
| otherwise
- -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+ -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]
where
rep = cmmExprType src
@@ -201,14 +202,14 @@ pprStmt stmt = case stmt of
maybe_proto $$
fnCall
where
- cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+ cast_fn = parens (cCast platform (pprCFunType (char '*') cconv results args) fn)
real_fun_proto lbl = char ';' <>
- pprCFunType (pprCLabel lbl) cconv results args <>
+ pprCFunType (pprCLabel platform lbl) cconv results args <>
noreturn_attr <> semi
fun_proto lbl = ptext (sLit ";EF_(") <>
- pprCLabel lbl <> char ')' <> semi
+ pprCLabel platform lbl <> char ')' <> semi
noreturn_attr = case ret of
CmmNeverReturns -> text "__attribute__ ((noreturn))"
@@ -219,7 +220,7 @@ pprStmt stmt = case stmt of
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- let myCall = pprCall (pprCLabel lbl) cconv results args safety
+ let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
in (real_fun_proto lbl, myCall)
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
@@ -227,22 +228,22 @@ pprStmt stmt = case stmt of
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
- let myCall = pprCall (pprCLabel lbl) cconv results args safety
+ let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
- $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
+ $$ pprCall platform (text "ghcFunPtr") cconv results args safety <> semi
)
in (fun_proto lbl, myCall)
_ ->
(empty {- no proto -},
- pprCall cast_fn cconv results args safety <> semi)
+ pprCall platform cast_fn cconv results args safety <> semi)
-- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim op) results args safety _ret ->
- pprCall ppr_fn CCallConv results args' safety
+ pprCall platform ppr_fn CCallConv results args' safety
where
ppr_fn = pprCallishMachOp_for_C op
-- The mem primops carry an extra alignment arg, must drop it.
@@ -251,9 +252,9 @@ pprStmt stmt = case stmt of
| otherwise = args
CmmBranch ident -> pprBranch ident
- CmmCondBranch expr ident -> pprCondBranch expr ident
- CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
- CmmSwitch arg ids -> pprSwitch arg ids
+ CmmCondBranch expr ident -> pprCondBranch platform expr ident
+ CmmJump lbl _params -> mkJMP_(pprExpr platform lbl) <> semi
+ CmmSwitch arg ids -> pprSwitch platform arg ids
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
@@ -275,9 +276,9 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
-- ---------------------------------------------------------------------
-- conditional branches to local labels
-pprCondBranch :: CmmExpr -> BlockId -> SDoc
-pprCondBranch expr ident
- = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
+pprCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc
+pprCondBranch platform expr ident
+ = hsep [ ptext (sLit "if") , parens(pprExpr platform expr) ,
ptext (sLit "goto") , (pprBlockId ident) <> semi ]
@@ -290,12 +291,12 @@ pprCondBranch expr ident
-- 'undefined'. However, they may be defined one day, so we better
-- document this behaviour.
--
-pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
-pprSwitch e maybe_ids
+pprSwitch :: Platform -> CmmExpr -> [ Maybe BlockId ] -> SDoc
+pprSwitch platform e maybe_ids
= let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
in
- (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
+ (hang (ptext (sLit "switch") <+> parens ( pprExpr platform e ) <+> lbrace)
4 (vcat ( map caseify pairs2 )))
$$ rbrace
@@ -329,12 +330,12 @@ pprSwitch e maybe_ids
--
-- (similar invariants apply to the rest of the pretty printer).
-pprExpr :: CmmExpr -> SDoc
-pprExpr e = case e of
- CmmLit lit -> pprLit lit
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e = case e of
+ CmmLit lit -> pprLit platform lit
- CmmLoad e ty -> pprLoad e ty
+ CmmLoad e ty -> pprLoad platform e ty
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
@@ -344,17 +345,17 @@ pprExpr e = case e of
where
pprRegOff op i' = pprCastReg reg <> op <> int i'
- CmmMachOp mop args -> pprMachOpApp mop args
+ CmmMachOp mop args -> pprMachOpApp platform mop args
CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"
-pprLoad :: CmmExpr -> CmmType -> SDoc
-pprLoad e ty
+pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc
+pprLoad platform e ty
| width == W64, wordWidth /= W64
= (if isFloatType ty then ptext (sLit "PK_DBL")
else ptext (sLit "PK_Word64"))
- <> parens (mkP_ <> pprExpr1 e)
+ <> parens (mkP_ <> pprExpr1 platform e)
| otherwise
= case e of
@@ -370,32 +371,32 @@ pprLoad e ty
-- (For tagging to work, I had to avoid unaligned loads. --ARY)
-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
- _other -> cLoad e ty
+ _other -> cLoad platform e ty
where
width = typeWidth ty
-pprExpr1 :: CmmExpr -> SDoc
-pprExpr1 (CmmLit lit) = pprLit1 lit
-pprExpr1 e@(CmmReg _reg) = pprExpr e
-pprExpr1 other = parens (pprExpr other)
+pprExpr1 :: Platform -> CmmExpr -> SDoc
+pprExpr1 platform (CmmLit lit) = pprLit1 platform lit
+pprExpr1 platform e@(CmmReg _reg) = pprExpr platform e
+pprExpr1 platform other = parens (pprExpr platform other)
-- --------------------------------------------------------------------------
-- MachOp applications
-pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp op args
+pprMachOpApp platform op args
| isMulMayOfloOp op
- = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
+ = ptext (sLit "mulIntMayOflo") <> parens (commafy (map (pprExpr platform) args))
where isMulMayOfloOp (MO_U_MulMayOflo _) = True
isMulMayOfloOp (MO_S_MulMayOflo _) = True
isMulMayOfloOp _ = False
-pprMachOpApp mop args
+pprMachOpApp platform mop args
| Just ty <- machOpNeedsCast mop
- = ty <> parens (pprMachOpApp' mop args)
+ = ty <> parens (pprMachOpApp' platform mop args)
| otherwise
- = pprMachOpApp' mop args
+ = pprMachOpApp' platform mop args
-- Comparisons in C have type 'int', but we want type W_ (this is what
-- resultRepOfMachOp says). The other C operations inherit their type
@@ -405,8 +406,8 @@ machOpNeedsCast mop
| isComparisonMachOp mop = Just mkW_
| otherwise = Nothing
-pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp' mop args
+pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp' platform mop args
= case args of
-- dyadic
[x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
@@ -418,9 +419,9 @@ pprMachOpApp' mop args
where
-- Cast needed for signed integer ops
- pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e
- | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e
- | otherwise = pprExpr1 e
+ pprArg e | signedOp mop = cCast platform (machRep_S_CType (typeWidth (cmmExprType e))) e
+ | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType e))) e
+ | otherwise = pprExpr1 platform e
needsFCasts (MO_F_Eq _) = False
needsFCasts (MO_F_Ne _) = False
needsFCasts (MO_F_Neg _) = True
@@ -430,8 +431,8 @@ pprMachOpApp' mop args
-- --------------------------------------------------------------------------
-- Literals
-pprLit :: CmmLit -> SDoc
-pprLit lit = case lit of
+pprLit :: Platform -> CmmLit -> SDoc
+pprLit platform lit = case lit of
CmmInt i rep -> pprHexVal i rep
CmmFloat f w -> parens (machRep_F_CType w) <> str
@@ -457,54 +458,54 @@ pprLit lit = case lit of
-> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
where
- pprCLabelAddr lbl = char '&' <> pprCLabel lbl
+ pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
-pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
-pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
-pprLit1 other = pprLit other
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff _ _) = parens (pprLit platform lit)
+pprLit1 platform lit@(CmmLabelDiffOff _ _ _) = parens (pprLit platform lit)
+pprLit1 platform lit@(CmmFloat _ _) = parens (pprLit platform lit)
+pprLit1 platform other = pprLit platform other
-- ---------------------------------------------------------------------------
-- Static data
-pprStatics :: [CmmStatic] -> [SDoc]
-pprStatics [] = []
-pprStatics (CmmStaticLit (CmmFloat f W32) : rest)
+pprStatics :: Platform -> [CmmStatic] -> [SDoc]
+pprStatics _ [] = []
+pprStatics platform (CmmStaticLit (CmmFloat f W32) : rest)
-- floats are padded to a word, see #1852
| wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
- = pprLit1 (floatToWord f) : pprStatics rest'
+ = pprLit1 platform (floatToWord f) : pprStatics platform rest'
| wORD_SIZE == 4
- = pprLit1 (floatToWord f) : pprStatics rest
+ = pprLit1 platform (floatToWord f) : pprStatics platform rest
| otherwise
= pprPanic "pprStatics: float" (vcat (map ppr' rest))
where ppr' (CmmStaticLit l) = ppr (cmmLitType l)
ppr' _other = ptext (sLit "bad static!")
-pprStatics (CmmStaticLit (CmmFloat f W64) : rest)
- = map pprLit1 (doubleToWords f) ++ pprStatics rest
-pprStatics (CmmStaticLit (CmmInt i W64) : rest)
+pprStatics platform (CmmStaticLit (CmmFloat f W64) : rest)
+ = map (pprLit1 platform) (doubleToWords f) ++ pprStatics platform rest
+pprStatics platform (CmmStaticLit (CmmInt i W64) : rest)
| wordWidth == W32
#ifdef WORDS_BIGENDIAN
- = pprStatics (CmmStaticLit (CmmInt q W32) :
+ = pprStatics platform (CmmStaticLit (CmmInt q W32) :
CmmStaticLit (CmmInt r W32) : rest)
#else
- = pprStatics (CmmStaticLit (CmmInt r W32) :
+ = pprStatics platform (CmmStaticLit (CmmInt r W32) :
CmmStaticLit (CmmInt q W32) : rest)
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
-pprStatics (CmmStaticLit (CmmInt _ w) : _)
+pprStatics _ (CmmStaticLit (CmmInt _ w) : _)
| w /= wordWidth
= panic "pprStatics: cannot emit a non-word-sized static literal"
-pprStatics (CmmStaticLit lit : rest)
- = pprLit1 lit : pprStatics rest
-pprStatics (other : _)
- = pprPanic "pprWord" (pprStatic other)
+pprStatics platform (CmmStaticLit lit : rest)
+ = pprLit1 platform lit : pprStatics platform rest
+pprStatics platform (other : _)
+ = pprPanic "pprWord" (pprStatic platform other)
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
- CmmStaticLit lit -> nest 4 (pprLit lit)
+ CmmStaticLit lit -> nest 4 (pprLit platform lit)
CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-- these should be inlined, like the old .hc
@@ -691,15 +692,15 @@ mkP_ = ptext (sLit "(P_)") -- StgWord*
--
-- Generating assignments is what we're all about, here
--
-pprAssign :: CmmReg -> CmmExpr -> SDoc
+pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc
-- dest is a reg, rhs is a reg
-pprAssign r1 (CmmReg r2)
+pprAssign _ r1 (CmmReg r2)
| isPtrReg r1 && isPtrReg r2
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
-- dest is a reg, rhs is a CmmRegOff
-pprAssign r1 (CmmRegOff r2 off)
+pprAssign _ r1 (CmmRegOff r2 off)
| isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
where
@@ -711,10 +712,10 @@ pprAssign r1 (CmmRegOff r2 off)
-- dest is a reg, rhs is anything.
-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
-pprAssign r1 r2
- | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
- | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
- | otherwise = mkAssign (pprExpr r2)
+pprAssign platform r1 r2
+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2)
+ | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)
+ | otherwise = mkAssign (pprExpr platform r2)
where mkAssign x = if r1 == CmmGlobal BaseReg
then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
else pprReg r1 <> ptext (sLit " = ") <> x <> semi
@@ -810,10 +811,11 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
- -> SDoc
+pprCall :: Platform -> SDoc -> CCallConv
+ -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
+ -> SDoc
-pprCall ppr_fn cconv results args _
+pprCall platform ppr_fn cconv results args _
| not (is_cishCC cconv)
= panic $ "pprCall: unknown calling convention"
@@ -828,12 +830,12 @@ pprCall ppr_fn cconv results args _
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (CmmHinted expr AddrHint)
- = cCast (ptext (sLit "void *")) expr
+ = cCast platform (ptext (sLit "void *")) expr
-- see comment by machRepHintCType below
pprArg (CmmHinted expr SignedHint)
- = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
+ = cCast platform (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
pprArg (CmmHinted expr _other)
- = pprExpr expr
+ = pprExpr platform expr
pprUnHint AddrHint rep = parens (machRepCType rep)
pprUnHint SignedHint rep = parens (machRepCType rep)
@@ -851,29 +853,30 @@ is_cishCC PrimCallConv = False
-- Find and print local and external declarations for a list of
-- Cmm statements.
--
-pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
-pprTempAndExternDecls stmts
+pprTempAndExternDecls :: Platform -> [CmmBasicBlock]
+ -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls platform stmts
= (vcat (map pprTempDecl (uniqSetToList temps)),
- vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
+ vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls)))
where (temps, lbls) = runTE (mapM_ te_BB stmts)
-pprDataExterns :: [CmmStatic] -> SDoc
-pprDataExterns statics
- = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
+pprDataExterns :: Platform -> [CmmStatic] -> SDoc
+pprDataExterns platform statics
+ = vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls))
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
pprTempDecl l@(LocalReg _ rep)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
-pprExternDecl :: Bool -> CLabel -> SDoc
-pprExternDecl _in_srt lbl
+pprExternDecl :: Platform -> Bool -> CLabel -> SDoc
+pprExternDecl platform _in_srt lbl
-- do not print anything for "known external" things
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
hcat [ visibility, label_type lbl,
- lparen, pprCLabel lbl, text ");" ]
+ lparen, pprCLabel platform lbl, text ");" ]
where
label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
| otherwise = ptext (sLit "I_")
@@ -886,7 +889,7 @@ pprExternDecl _in_srt lbl
-- we must generate an appropriate prototype for it, so that the C compiler will
-- add the @n suffix to the label (#2276)
stdcall_decl sz =
- ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
+ ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel platform lbl
<> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
<> semi
@@ -945,19 +948,19 @@ te_Reg _ = return ()
-- ---------------------------------------------------------------------
-- C types for MachReps
-cCast :: SDoc -> CmmExpr -> SDoc
-cCast ty expr = parens ty <> pprExpr1 expr
+cCast :: Platform -> SDoc -> CmmExpr -> SDoc
+cCast platform ty expr = parens ty <> pprExpr1 platform expr
-cLoad :: CmmExpr -> CmmType -> SDoc
+cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
#ifdef BEWARE_LOAD_STORE_ALIGNMENT
-cLoad expr rep =
+cLoad platform expr rep =
let decl = machRepCType rep <+> ptext (sLit "x") <> semi
struct = ptext (sLit "struct") <+> braces (decl)
packed_attr = ptext (sLit "__attribute__((packed))")
cast = parens (struct <+> packed_attr <> char '*')
in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
#else
-cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
+cLoad platform expr rep = char '*' <> parens (cCast platform (machRepPtrCType rep) expr)
#endif
isCmmWordType :: CmmType -> Bool
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 521ab059b7..d32f129247 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -59,12 +59,12 @@ import Prelude hiding (succ)
instance Outputable CmmStackInfo where
ppr = pprStackInfo
-instance Outputable CmmTopInfo where
- ppr = pprTopInfo
+instance PlatformOutputable CmmTopInfo where
+ pprPlatform = pprTopInfo
-instance Outputable (CmmNode e x) where
- ppr = pprNode
+instance PlatformOutputable (CmmNode e x) where
+ pprPlatform = pprNode
instance Outputable Convention where
ppr = pprConvention
@@ -72,18 +72,18 @@ instance Outputable Convention where
instance Outputable ForeignConvention where
ppr = pprForeignConvention
-instance Outputable ForeignTarget where
- ppr = pprForeignTarget
+instance PlatformOutputable ForeignTarget where
+ pprPlatform = pprForeignTarget
instance PlatformOutputable (Block CmmNode C C) where
- pprPlatform _ = pprBlock
+ pprPlatform = pprBlock
instance PlatformOutputable (Block CmmNode C O) where
- pprPlatform _ = pprBlock
+ pprPlatform = pprBlock
instance PlatformOutputable (Block CmmNode O C) where
- pprPlatform _ = pprBlock
+ pprPlatform = pprBlock
instance PlatformOutputable (Block CmmNode O O) where
- pprPlatform _ = pprBlock
+ pprPlatform = pprBlock
instance PlatformOutputable (Graph CmmNode e x) where
pprPlatform = pprGraph
@@ -99,22 +99,23 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
ptext (sLit "arg_space: ") <> ppr arg_space <+>
ptext (sLit "updfr_space: ") <> ppr updfr_space
-pprTopInfo :: CmmTopInfo -> SDoc
-pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
- vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
+pprTopInfo :: Platform -> CmmTopInfo -> SDoc
+pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
+ vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl,
ptext (sLit "stack_info: ") <> ppr stack_info]
----------------------------------------------------------
-- Outputting blocks and graphs
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
- => Block CmmNode e x -> IndexedCO e SDoc SDoc
-pprBlock block = foldBlockNodesB3 ( ($$) . ppr
- , ($$) . (nest 4) . ppr
- , ($$) . (nest 4) . ppr
- )
- block
- empty
+ => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock platform block
+ = foldBlockNodesB3 ( ($$) . pprPlatform platform
+ , ($$) . (nest 4) . pprPlatform platform
+ , ($$) . (nest 4) . pprPlatform platform
+ )
+ block
+ empty
pprGraph :: Platform -> Graph CmmNode e x -> SDoc
pprGraph _ GNil = empty
@@ -152,23 +153,25 @@ pprConvention (Private {}) = text "<private-convention>"
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
-pprForeignTarget :: ForeignTarget -> SDoc
-pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
+pprForeignTarget :: Platform -> ForeignTarget -> SDoc
+pprForeignTarget platform (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
where ppr_fc :: ForeignConvention -> SDoc
ppr_fc (ForeignConvention c args res) =
doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
ppr_target :: CmmExpr -> SDoc
- ppr_target t@(CmmLit _) = ppr t
- ppr_target fn' = parens (ppr fn')
+ ppr_target t@(CmmLit _) = pprPlatform platform t
+ ppr_target fn' = parens (pprPlatform platform fn')
-pprForeignTarget (PrimTarget op)
+pprForeignTarget platform (PrimTarget op)
-- HACK: We're just using a ForeignLabel to get this printed, the label
-- might not really be foreign.
- = ppr (CmmLabel (mkForeignLabel
- (mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction))
-pprNode :: CmmNode e x -> SDoc
-pprNode node = pp_node <+> pp_debug
+ = pprPlatform platform
+ (CmmLabel (mkForeignLabel
+ (mkFastString (show op))
+ Nothing ForeignLabelInThisPackage IsFunction))
+
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
where
pp_node :: SDoc
pp_node = case node of
@@ -179,10 +182,10 @@ pprNode node = pp_node <+> pp_debug
CmmComment s -> text "//" <+> ftext s
-- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+ CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi
-- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi
where
rep = ppr ( cmmExprType expr )
@@ -192,7 +195,7 @@ pprNode node = pp_node <+> pp_debug
hsep [ ppUnless (null results) $
parens (commafy $ map ppr results) <+> equals,
ptext $ sLit "call",
- ppr target <> parens (commafy $ map ppr args) <> semi]
+ pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi]
-- goto label;
CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
@@ -200,7 +203,7 @@ pprNode node = pp_node <+> pp_debug
-- if (expr) goto t; else goto f;
CmmCondBranch expr t f ->
hsep [ ptext (sLit "if")
- , parens(ppr expr)
+ , parens(pprPlatform platform expr)
, ptext (sLit "goto")
, ppr t <> semi
, ptext (sLit "else goto")
@@ -211,7 +214,9 @@ pprNode node = pp_node <+> pp_debug
hang (hcat [ ptext (sLit "switch [0 .. ")
, int (length maybe_ids - 1)
, ptext (sLit "] ")
- , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr)
+ , if isTrivialCmmExpr expr
+ then pprPlatform platform expr
+ else parens (pprPlatform platform expr)
, ptext (sLit " {")
])
4 (vcat ( map caseify pairs )) $$ rbrace
@@ -232,15 +237,15 @@ pprNode node = pp_node <+> pp_debug
<+> parens (ppr res)
, ptext (sLit " with update frame") <+> ppr updfr_off
, semi ]
- where pprFun f@(CmmLit _) = ppr f
- pprFun f = parens (ppr f)
+ where pprFun f@(CmmLit _) = pprPlatform platform f
+ pprFun f = parens (pprPlatform platform f)
CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
[ ptext (sLit "foreign call"), space
- , ppr t, ptext (sLit "(...)"), space
+ , pprPlatform platform t, ptext (sLit "(...)"), space
, ptext (sLit "returns to") <+> ppr s
- <+> ptext (sLit "args:") <+> parens (ppr as)
+ <+> ptext (sLit "args:") <+> parens (pprPlatform platform as)
<+> ptext (sLit "ress:") <+> parens (ppr rs)
, ptext (sLit " with update frame") <+> ppr u
, semi ]
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 5cd3501b11..370428d750 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -53,49 +53,51 @@ import SMRep
#include "../includes/rts/storage/FunTypes.h"
-pprCmms :: (Outputable info, PlatformOutputable g)
+pprCmms :: (PlatformOutputable info, PlatformOutputable g)
=> Platform -> [GenCmmGroup 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, PlatformOutputable g)
+writeCmms :: (PlatformOutputable info, PlatformOutputable g)
=> Platform -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
writeCmms platform handle cmms = printForC handle (pprCmms platform cmms)
-----------------------------------------------------------------------------
-instance (Outputable d, Outputable info, PlatformOutputable i)
+instance (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i)
=> PlatformOutputable (GenCmmDecl d info i) where
pprPlatform platform t = pprTop platform t
-instance Outputable CmmStatics where
- ppr e = pprStatics e
+instance PlatformOutputable CmmStatics where
+ pprPlatform = pprStatics
-instance Outputable CmmStatic where
- ppr e = pprStatic e
+instance PlatformOutputable CmmStatic where
+ pprPlatform = pprStatic
-instance Outputable CmmInfoTable where
- ppr e = pprInfoTable e
+instance PlatformOutputable CmmInfoTable where
+ pprPlatform = pprInfoTable
-----------------------------------------------------------------------------
-pprCmmGroup :: (Outputable d, Outputable info, PlatformOutputable g)
- => Platform -> GenCmmGroup d info g -> SDoc
+pprCmmGroup :: (PlatformOutputable d,
+ PlatformOutputable info,
+ PlatformOutputable g)
+ => Platform -> GenCmmGroup d info g -> SDoc
pprCmmGroup platform tops
= vcat $ intersperse blankLine $ map (pprTop platform) tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable d, Outputable info, PlatformOutputable i)
+pprTop :: (PlatformOutputable d, PlatformOutputable info, PlatformOutputable i)
=> Platform -> GenCmmDecl d info i -> SDoc
pprTop platform (CmmProc info lbl graph)
- = vcat [ pprCLabel lbl <> lparen <> rparen
- , nest 8 $ lbrace <+> ppr info $$ rbrace
+ = vcat [ pprCLabel platform lbl <> lparen <> rparen
+ , nest 8 $ lbrace <+> pprPlatform platform info $$ rbrace
, nest 4 $ pprPlatform platform graph
, rbrace ]
@@ -104,30 +106,32 @@ pprTop platform (CmmProc info lbl graph)
--
-- section "data" { ... }
--
-pprTop _ (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (ppr ds))
+pprTop platform (CmmData section ds) =
+ (hang (pprSection section <+> lbrace) 4 (pprPlatform platform ds))
$$ rbrace
-- --------------------------------------------------------------------------
-- Info tables.
-pprInfoTable :: CmmInfoTable -> SDoc
-pprInfoTable CmmNonInfoTable
+pprInfoTable :: Platform -> CmmInfoTable -> SDoc
+pprInfoTable _ CmmNonInfoTable
= empty
-pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+pprInfoTable platform
+ (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, cit_prof = prof_info
, cit_srt = _srt })
- = vcat [ ptext (sLit "label:") <+> ppr lbl
+ = vcat [ ptext (sLit "label:") <+> pprPlatform platform lbl
, ptext (sLit "rep:") <> ppr rep
, case prof_info of
NoProfilingInfo -> empty
ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct
, ptext (sLit "desc: ") <> pprWord8String cd ] ]
-instance Outputable C_SRT where
- ppr (NoC_SRT) = ptext (sLit "_no_srt_")
- ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma
- <> text (show bitmap))
+instance PlatformOutputable C_SRT where
+ pprPlatform _ (NoC_SRT) = ptext (sLit "_no_srt_")
+ pprPlatform platform (C_SRT label off bitmap)
+ = parens (pprPlatform platform label <> comma <> ppr off
+ <> comma <> text (show bitmap))
instance Outputable ForeignHint where
ppr NoHint = empty
@@ -135,18 +139,20 @@ instance Outputable ForeignHint where
-- ppr AddrHint = quotes(text "address")
-- Temp Jan08
ppr AddrHint = (text "PtrHint")
+instance PlatformOutputable ForeignHint where
+ pprPlatform _ = ppr
-- --------------------------------------------------------------------------
-- Static data.
-- 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)
+pprStatics :: Platform -> CmmStatics -> SDoc
+pprStatics platform (Statics lbl ds) = vcat ((pprCLabel platform lbl <> colon) : map (pprPlatform platform) ds)
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
- CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
+ CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit platform lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 763034554f..aa86ca04fc 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -42,6 +42,7 @@ import CmmExpr
import CLabel
import Outputable
+import Platform
import FastString
import Data.Maybe
@@ -49,17 +50,19 @@ import Numeric ( fromRat )
-----------------------------------------------------------------------------
-instance Outputable CmmExpr where
- ppr e = pprExpr e
+instance PlatformOutputable CmmExpr where
+ pprPlatform = pprExpr
instance Outputable CmmReg where
ppr e = pprReg e
-instance Outputable CmmLit where
- ppr l = pprLit l
+instance PlatformOutputable CmmLit where
+ pprPlatform = pprLit
instance Outputable LocalReg where
ppr e = pprLocalReg e
+instance PlatformOutputable LocalReg where
+ pprPlatform _ = ppr
instance Outputable Area where
ppr e = pprArea e
@@ -71,15 +74,15 @@ instance Outputable GlobalReg where
-- Expressions
--
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e
= case e of
CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
+ pprExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
where rep = typeWidth (cmmRegType reg)
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
+ CmmLit lit -> pprLit platform lit
+ _other -> pprExpr1 platform e
-- Here's the precedence table from CmmParse.y:
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
@@ -95,10 +98,10 @@ pprExpr e
-- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
+pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc
+pprExpr1 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+ = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
+pprExpr1 platform e = pprExpr7 platform e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
@@ -113,55 +116,55 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<')
infixMachOp1 _ = Nothing
-- %left '-' '+'
-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+ = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
+pprExpr7 platform e = pprExpr8 platform e
infixMachOp7 (MO_Add _) = Just (char '+')
infixMachOp7 (MO_Sub _) = Just (char '-')
infixMachOp7 _ = Nothing
-- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
+pprExpr8 platform (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
+pprExpr8 platform e = pprExpr9 platform e
infixMachOp8 (MO_U_Quot _) = Just (char '/')
infixMachOp8 (MO_Mul _) = Just (char '*')
infixMachOp8 (MO_U_Rem _) = Just (char '%')
infixMachOp8 _ = Nothing
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
+pprExpr9 :: Platform -> CmmExpr -> SDoc
+pprExpr9 platform e =
case e of
- CmmLit lit -> pprLit1 lit
- CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
+ CmmLit lit -> pprLit1 platform lit
+ CmmLoad expr rep -> ppr rep <> brackets (pprPlatform platform expr)
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp mop args
+ CmmMachOp mop args -> genMachOp platform mop args
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform mop args
| Just doc <- infixMachOp mop = case args of
-- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+ [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
-- unary
- [x] -> doc <> pprExpr9 x
+ [x] -> doc <> pprExpr9 platform x
_ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
(pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))
empty
| isJust (infixMachOp1 mop)
|| isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
- | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
(show mop))
-- replace spaces in (show mop) with underscores,
@@ -185,24 +188,24 @@ infixMachOp mop
-- To minimise line noise we adopt the convention that if the literal
-- has the natural machine word size, we do not append the type
--
-pprLit :: CmmLit -> SDoc
-pprLit lit = case lit of
+pprLit :: Platform -> CmmLit -> SDoc
+pprLit platform lit = case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
, ppUnless (rep == wordWidth) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
- CmmLabel clbl -> pprCLabel clbl
- CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
- CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
- <> pprCLabel clbl2 <> ppr_offset i
+ CmmLabel clbl -> pprCLabel platform clbl
+ CmmLabelOff clbl i -> pprCLabel platform clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel platform clbl1 <> char '-'
+ <> pprCLabel platform clbl2 <> ppr_offset i
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
+pprLit1 platform lit = pprLit platform lit
ppr_offset :: Int -> SDoc
ppr_offset i
View Lorry Controller Status