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

-- Temp Jan08
import SMRep


pprCmms :: (Outputable info, Outputable g)
        => [GenCmmGroup CmmStatics info g] -> SDoc
pprCmms :: [GenCmmGroup CmmStatics info g] -> SDoc
pprCmms cmms :: [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 "-------------------" 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 dflags :: DynFlags
dflags handle :: Handle
handle cmms :: [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 t :: 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 tops :: 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
info lbl :: CLabel
lbl live :: [GlobalReg]
live graph :: 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
<+> String -> SDoc
text "// " SDoc -> SDoc -> SDoc
<+> [GlobalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalReg]
live
         , Int -> SDoc -> SDoc
nest 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 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
section ds :: d
ds) =
    (SDoc -> Int -> SDoc -> SDoc
hang (Section -> SDoc
pprSection Section
section SDoc -> SDoc -> SDoc
<+> SDoc
lbrace) 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 "label: " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl
         , String -> SDoc
text "rep: " SDoc -> SDoc -> SDoc
<> SMRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr SMRep
rep
         , case ProfilingInfo
prof_info of
             NoProfilingInfo -> SDoc
empty
             ProfilingInfo ct :: [Word8]
ct cd :: [Word8]
cd ->
               [SDoc] -> SDoc
vcat [ String -> SDoc
text "type: " SDoc -> SDoc -> SDoc
<> [Word8] -> SDoc
pprWord8String [Word8]
ct
                    , String -> SDoc
text "desc: " SDoc -> SDoc -> SDoc
<> [Word8] -> SDoc
pprWord8String [Word8]
cd ]
         , String -> SDoc
text "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 NoHint     = SDoc
empty
  ppr SignedHint = SDoc -> SDoc
quotes(String -> SDoc
text "signed")
--  ppr AddrHint   = quotes(text "address")
-- Temp Jan08
  ppr AddrHint   = (String -> SDoc
text "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 lbl :: CLabel
lbl ds :: [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 s :: CmmStatic
s = case CmmStatic
s of
    CmmStaticLit lit :: CmmLit
lit   -> Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "const" SDoc -> SDoc -> SDoc
<+> CmmLit -> SDoc
pprLit CmmLit
lit SDoc -> SDoc -> SDoc
<> SDoc
semi
    CmmUninitialised i :: Int
i -> Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "I8" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Int -> SDoc
int Int
i)
    CmmString s' :: [Word8]
s'       -> Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "I8[]" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text ([Word8] -> String
forall a. Show a => a -> String
show [Word8]
s')

-- --------------------------------------------------------------------------
-- data sections
--
pprSection :: Section -> SDoc
pprSection :: Section -> SDoc
pprSection (Section t :: SectionType
t suffix :: CLabel
suffix) =
  SDoc
section SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (SectionType -> SDoc
pprSectionType SectionType
t SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char '.' SDoc -> SDoc -> SDoc
<+> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
suffix)
  where
    section :: SDoc
section = String -> SDoc
text "section"

pprSectionType :: SectionType -> SDoc
pprSectionType :: SectionType -> SDoc
pprSectionType s :: SectionType
s = SDoc -> SDoc
doubleQuotes (PtrString -> SDoc
ptext PtrString
t)
 where
  t :: PtrString
t = case SectionType
s of
    Text              -> String -> PtrString
sLit "text"
    Data              -> String -> PtrString
sLit "data"
    ReadOnlyData      -> String -> PtrString
sLit "readonly"
    ReadOnlyData16    -> String -> PtrString
sLit "readonly16"
    RelocatableReadOnlyData
                      -> String -> PtrString
sLit "relreadonly"
    UninitialisedData -> String -> PtrString
sLit "uninitialised"
    CString           -> String -> PtrString
sLit "cstring"
    OtherSection s' :: String
s'   -> String -> PtrString
sLit String
s' -- Not actually a literal though.