{-# OPTIONS_GHC -fno-warn-orphans #-}
module PprCmmDecl
( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
)
where
import GhcPrelude
import PprCmmExpr
import Cmm
import DynFlags
import Outputable
import FastString
import Data.List
import System.IO
import qualified Data.ByteString as BS
pprCmms :: (Outputable info, Outputable g)
=> [GenCmmGroup CmmStatics info g] -> SDoc
pprCmms :: [GenCmmGroup CmmStatics info g] -> SDoc
pprCmms [GenCmmGroup CmmStatics info g]
cmms = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle ([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
separator ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (GenCmmGroup CmmStatics info g -> SDoc)
-> [GenCmmGroup CmmStatics info g] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenCmmGroup CmmStatics info g -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenCmmGroup CmmStatics info g]
cmms))
where
separator :: SDoc
separator = SDoc
space SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"-------------------" SDoc -> SDoc -> SDoc
$$ SDoc
space
writeCmms :: (Outputable info, Outputable g)
=> DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
writeCmms :: DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
writeCmms DynFlags
dflags Handle
handle [GenCmmGroup CmmStatics info g]
cmms = DynFlags -> Handle -> SDoc -> IO ()
printForC DynFlags
dflags Handle
handle ([GenCmmGroup CmmStatics info g] -> SDoc
forall info g.
(Outputable info, Outputable g) =>
[GenCmmGroup CmmStatics info g] -> SDoc
pprCmms [GenCmmGroup CmmStatics info g]
cmms)
instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmDecl d info i) where
ppr :: GenCmmDecl d info i -> SDoc
ppr GenCmmDecl d info i
t = GenCmmDecl d info i -> SDoc
forall d info i.
(Outputable d, Outputable info, Outputable i) =>
GenCmmDecl d info i -> SDoc
pprTop GenCmmDecl d info i
t
instance Outputable CmmStatics where
ppr :: CmmStatics -> SDoc
ppr = CmmStatics -> SDoc
pprStatics
instance Outputable CmmStatic where
ppr :: CmmStatic -> SDoc
ppr = CmmStatic -> SDoc
pprStatic
instance Outputable CmmInfoTable where
ppr :: CmmInfoTable -> SDoc
ppr = CmmInfoTable -> SDoc
pprInfoTable
pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
=> GenCmmGroup d info g -> SDoc
pprCmmGroup :: GenCmmGroup d info g -> SDoc
pprCmmGroup GenCmmGroup d info g
tops
= [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
blankLine ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (GenCmmDecl d info g -> SDoc) -> GenCmmGroup d info g -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenCmmDecl d info g -> SDoc
forall d info i.
(Outputable d, Outputable info, Outputable i) =>
GenCmmDecl d info i -> SDoc
pprTop GenCmmGroup d info g
tops
pprTop :: (Outputable d, Outputable info, Outputable i)
=> GenCmmDecl d info i -> SDoc
pprTop :: GenCmmDecl d info i -> SDoc
pprTop (CmmProc info
info CLabel
lbl [GlobalReg]
live i
graph)
= [SDoc] -> SDoc
vcat [ CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<> SDoc
rparen SDoc -> SDoc -> SDoc
<+> SDoc
lbrace SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"// " SDoc -> SDoc -> SDoc
<+> [GlobalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
live
, Int -> SDoc -> SDoc
nest Int
8 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
lbrace SDoc -> SDoc -> SDoc
<+> info -> SDoc
forall a. Outputable a => a -> SDoc
ppr info
info SDoc -> SDoc -> SDoc
$$ SDoc
rbrace
, Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ i -> SDoc
forall a. Outputable a => a -> SDoc
ppr i
graph
, SDoc
rbrace ]
pprTop (CmmData Section
section d
ds) =
(SDoc -> Int -> SDoc -> SDoc
hang (Section -> SDoc
pprSection Section
section SDoc -> SDoc -> SDoc
<+> SDoc
lbrace) Int
4 (d -> SDoc
forall a. Outputable a => a -> SDoc
ppr d
ds))
SDoc -> SDoc -> SDoc
$$ SDoc
rbrace
pprInfoTable :: CmmInfoTable -> SDoc
pprInfoTable :: CmmInfoTable -> SDoc
pprInfoTable (CmmInfoTable { cit_lbl :: CmmInfoTable -> CLabel
cit_lbl = CLabel
lbl, cit_rep :: CmmInfoTable -> SMRep
cit_rep = SMRep
rep
, cit_prof :: CmmInfoTable -> ProfilingInfo
cit_prof = ProfilingInfo
prof_info
, cit_srt :: CmmInfoTable -> Maybe CLabel
cit_srt = Maybe CLabel
srt })
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"label: " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl
, String -> SDoc
text String
"rep: " SDoc -> SDoc -> SDoc
<> SMRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr SMRep
rep
, case ProfilingInfo
prof_info of
ProfilingInfo
NoProfilingInfo -> SDoc
empty
ProfilingInfo ByteString
ct ByteString
cd ->
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"type: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text ([Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
BS.unpack ByteString
ct))
, String -> SDoc
text String
"desc: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text ([Word8] -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
BS.unpack ByteString
cd)) ]
, String -> SDoc
text String
"srt: " SDoc -> SDoc -> SDoc
<> Maybe CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe CLabel
srt ]
instance Outputable ForeignHint where
ppr :: ForeignHint -> SDoc
ppr ForeignHint
NoHint = SDoc
empty
ppr ForeignHint
SignedHint = SDoc -> SDoc
quotes(String -> SDoc
text String
"signed")
ppr ForeignHint
AddrHint = (String -> SDoc
text String
"PtrHint")
pprStatics :: CmmStatics -> SDoc
pprStatics :: CmmStatics -> SDoc
pprStatics (Statics CLabel
lbl [CmmStatic]
ds) = [SDoc] -> SDoc
vcat ((CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl SDoc -> SDoc -> SDoc
<> SDoc
colon) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (CmmStatic -> SDoc) -> [CmmStatic] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmStatic]
ds)
pprStatic :: CmmStatic -> SDoc
pprStatic :: CmmStatic -> SDoc
pprStatic CmmStatic
s = case CmmStatic
s of
CmmStaticLit CmmLit
lit -> Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"const" SDoc -> SDoc -> SDoc
<+> CmmLit -> SDoc
pprLit CmmLit
lit SDoc -> SDoc -> SDoc
<> SDoc
semi
CmmUninitialised Int
i -> Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"I8" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Int -> SDoc
int Int
i)
CmmString ByteString
s' -> Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"I8[]" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (ByteString -> String
forall a. Show a => a -> String
show ByteString
s')
pprSection :: Section -> SDoc
pprSection :: Section -> SDoc
pprSection (Section SectionType
t CLabel
suffix) =
SDoc
section SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (SectionType -> SDoc
pprSectionType SectionType
t SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'.' SDoc -> SDoc -> SDoc
<+> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
suffix)
where
section :: SDoc
section = String -> SDoc
text String
"section"
pprSectionType :: SectionType -> SDoc
pprSectionType :: SectionType -> SDoc
pprSectionType SectionType
s = SDoc -> SDoc
doubleQuotes (PtrString -> SDoc
ptext PtrString
t)
where
t :: PtrString
t = case SectionType
s of
SectionType
Text -> String -> PtrString
sLit String
"text"
SectionType
Data -> String -> PtrString
sLit String
"data"
SectionType
ReadOnlyData -> String -> PtrString
sLit String
"readonly"
SectionType
ReadOnlyData16 -> String -> PtrString
sLit String
"readonly16"
SectionType
RelocatableReadOnlyData
-> String -> PtrString
sLit String
"relreadonly"
SectionType
UninitialisedData -> String -> PtrString
sLit String
"uninitialised"
SectionType
CString -> String -> PtrString
sLit String
"cstring"
OtherSection String
s' -> String -> PtrString
sLit String
s'