{-# LANGUAGE GADTs #-}

----------------------------------------------------------------------------
--
-- Pretty-printing of common Cmm types
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

--
-- This is where we walk over Cmm emitting an external representation,
-- suitable for parsing, in a syntax strongly reminiscent of C--. This
-- is the "External Core" for the Cmm layer.
--
-- As such, this should be a well-defined syntax: we want it to look nice.
-- Thus, we try wherever possible to use syntax defined in [1],
-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
-- than C--'s bits8 .. bits64.
--
-- We try to ensure that all information available in the abstract
-- syntax is reproduced, or reproducible, in the concrete syntax.
-- Data that is not in printed out can be reconstructed according to
-- conventions used in the pretty printer. There are at least two such
-- cases:
--      1) if a value has wordRep type, the type is not appended in the
--      output.
--      2) MachOps that operate over wordRep type are printed in a
--      C-style, rather than as their internal MachRep name.
--
-- These conventions produce much more readable Cmm output.
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--

{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Cmm.Ppr.Decl
    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
    )
where

import GHC.Prelude

import GHC.Platform
import GHC.Cmm.Ppr.Expr
import GHC.Cmm

import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Data.FastString

import Data.List
import System.IO

import qualified Data.ByteString as BS


pprCmms :: (Outputable info, Outputable g)
        => [GenCmmGroup RawCmmStatics info g] -> SDoc
pprCmms :: forall info g.
(Outputable info, Outputable g) =>
[GenCmmGroup RawCmmStatics info g] -> SDoc
pprCmms [GenCmmGroup RawCmmStatics 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 RawCmmStatics info g -> SDoc)
-> [GenCmmGroup RawCmmStatics info g] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenCmmGroup RawCmmStatics info g -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenCmmGroup RawCmmStatics info g]
cmms))
        where
          separator :: SDoc
separator = SDoc
space SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"-------------------" SDoc -> SDoc -> SDoc
$$ SDoc
space

writeCmms :: (Outputable info, Outputable g)
          => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
writeCmms :: forall info g.
(Outputable info, Outputable g) =>
DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
writeCmms DynFlags
dflags Handle
handle [GenCmmGroup RawCmmStatics info g]
cmms = DynFlags -> Handle -> SDoc -> IO ()
printForC DynFlags
dflags Handle
handle ([GenCmmGroup RawCmmStatics info g] -> SDoc
forall info g.
(Outputable info, Outputable g) =>
[GenCmmGroup RawCmmStatics info g] -> SDoc
pprCmms [GenCmmGroup RawCmmStatics 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 (GenCmmStatics a) where
    ppr :: GenCmmStatics a -> SDoc
ppr = GenCmmStatics a -> SDoc
forall (a :: Bool). GenCmmStatics a -> SDoc
pprStatics

instance Outputable CmmStatic where
    ppr :: CmmStatic -> SDoc
ppr CmmStatic
e = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
            Platform -> CmmStatic -> SDoc
pprStatic (DynFlags -> Platform
targetPlatform DynFlags
dflags) CmmStatic
e

instance Outputable CmmInfoTable where
    ppr :: CmmInfoTable -> SDoc
ppr = CmmInfoTable -> SDoc
pprInfoTable


-----------------------------------------------------------------------------

pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
            => GenCmmGroup d info g -> SDoc
pprCmmGroup :: forall d info g.
(Outputable d, Outputable info, Outputable g) =>
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

-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
pprTop :: (Outputable d, Outputable info, Outputable i)
       => GenCmmDecl d info i -> SDoc

pprTop :: forall d info i.
(Outputable d, Outputable info, Outputable i) =>
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
<+> FilePath -> SDoc
text FilePath
"// " 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 ]

-- --------------------------------------------------------------------------
-- We follow [1], 4.5
--
--      section "data" { ... }
--
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

-- --------------------------------------------------------------------------
-- Info tables.

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 [ FilePath -> SDoc
text FilePath
"label: " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl
         , FilePath -> SDoc
text FilePath
"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 [ FilePath -> SDoc
text FilePath
"type: " SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text ([Word8] -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> [Word8]
BS.unpack ByteString
ct))
                    , FilePath -> SDoc
text FilePath
"desc: " SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text ([Word8] -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> [Word8]
BS.unpack ByteString
cd)) ]
         , FilePath -> SDoc
text FilePath
"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(FilePath -> SDoc
text FilePath
"signed")
--  ppr AddrHint   = quotes(text "address")
-- Temp Jan08
  ppr ForeignHint
AddrHint   = (FilePath -> SDoc
text FilePath
"PtrHint")

-- --------------------------------------------------------------------------
-- Static data.
--      Strings are printed as C strings, and we print them as I8[],
--      following C--
--

pprStatics :: GenCmmStatics a -> SDoc
pprStatics :: forall (a :: Bool). GenCmmStatics a -> SDoc
pprStatics (CmmStatics CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload) =
  CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> CmmInfoTable -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmInfoTable
itbl SDoc -> SDoc -> SDoc
<+> CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
ccs SDoc -> SDoc -> SDoc
<+> [CmmLit] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmLit]
payload
pprStatics (CmmStaticsRaw 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 :: Platform -> CmmStatic -> SDoc
pprStatic :: Platform -> CmmStatic -> SDoc
pprStatic Platform
platform 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
$ FilePath -> SDoc
text FilePath
"const" SDoc -> SDoc -> SDoc
<+> Platform -> CmmLit -> SDoc
pprLit Platform
platform 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
$ FilePath -> SDoc
text FilePath
"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
$ FilePath -> SDoc
text FilePath
"I8[]" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text (ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
s')
    CmmFileEmbed FilePath
path  -> Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"incbin " SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path)

-- --------------------------------------------------------------------------
-- data sections
--
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 = FilePath -> SDoc
text FilePath
"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              -> FilePath -> PtrString
sLit FilePath
"text"
    SectionType
Data              -> FilePath -> PtrString
sLit FilePath
"data"
    SectionType
ReadOnlyData      -> FilePath -> PtrString
sLit FilePath
"readonly"
    SectionType
ReadOnlyData16    -> FilePath -> PtrString
sLit FilePath
"readonly16"
    SectionType
RelocatableReadOnlyData
                      -> FilePath -> PtrString
sLit FilePath
"relreadonly"
    SectionType
UninitialisedData -> FilePath -> PtrString
sLit FilePath
"uninitialised"
    SectionType
CString           -> FilePath -> PtrString
sLit FilePath
"cstring"
    OtherSection FilePath
s'   -> FilePath -> PtrString
sLit FilePath
s' -- Not actually a literal though.