----------------------------------------------------------------------------
--
-- 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 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

-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
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 ]

-- --------------------------------------------------------------------------
-- 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 [ 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 AddrHint   = quotes(text "address")
-- Temp Jan08
  ppr ForeignHint
AddrHint   = (String -> SDoc
text String
"PtrHint")

-- --------------------------------------------------------------------------
-- Static data.
--      Strings are printed as C strings, and we print them as I8[],
--      following C--
--
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')

-- --------------------------------------------------------------------------
-- 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 = 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' -- Not actually a literal though.