compiler/cmm/PprCmmDecl.hs

   1 ----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing of common Cmm types
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 --
  10 -- This is where we walk over Cmm emitting an external representation,
  11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
  12 -- is the "External Core" for the Cmm layer.
  13 --
  14 -- As such, this should be a well-defined syntax: we want it to look nice.
  15 -- Thus, we try wherever possible to use syntax defined in [1],
  16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
  17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
  18 -- than C--'s bits8 .. bits64.
  19 --
  20 -- We try to ensure that all information available in the abstract
  21 -- syntax is reproduced, or reproducible, in the concrete syntax.
  22 -- Data that is not in printed out can be reconstructed according to
  23 -- conventions used in the pretty printer. There are at least two such
  24 -- cases:
  25 --      1) if a value has wordRep type, the type is not appended in the
  26 --      output.
  27 --      2) MachOps that operate over wordRep type are printed in a
  28 --      C-style, rather than as their internal MachRep name.
  29 --
  30 -- These conventions produce much more readable Cmm output.
  31 --
  32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
  33 --
  34
  35 module PprCmmDecl
  36     ( writeCmms, pprCmms, pprCmm, pprSection, pprStatic
  37     )
  38 where
  39
  40 import CmmDecl
  41 import CLabel
  42 import PprCmmExpr
  43
  44
  45 import Outputable
  46 import FastString
  47
  48 import Data.List
  49 import System.IO
  50
  51 -- Temp Jan08
  52 import SMRep
  53 import ClosureInfo
  54 #include "../includes/rts/storage/FunTypes.h"
  55
  56
  57 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
  58 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  59         where
  60           separator = space $$ ptext (sLit "-------------------") $$ space
  61
  62 writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO ()
  63 writeCmms handle cmms = printForC handle (pprCmms cmms)
  64
  65 -----------------------------------------------------------------------------
  66
  67 instance (Outputable d, Outputable info, Outputable g)
  68     => Outputable (GenCmm d info g) where
  69     ppr c = pprCmm c
  70
  71 instance (Outputable d, Outputable info, Outputable i)
  72         => Outputable (GenCmmTop d info i) where
  73     ppr t = pprTop t
  74
  75 instance Outputable CmmStatic where
  76     ppr e = pprStatic e
  77
  78 instance Outputable CmmInfoTable where
  79     ppr e = pprInfoTable e
  80
  81
  82 -----------------------------------------------------------------------------
  83
  84 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
  85 pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
  86
  87 -- --------------------------------------------------------------------------
  88 -- Top level `procedure' blocks.
  89 --
  90 pprTop  :: (Outputable d, Outputable info, Outputable i)
  91         => GenCmmTop d info i -> SDoc
  92
  93 pprTop (CmmProc info lbl graph)
  94
  95   = vcat [ pprCLabel lbl <> lparen <> rparen
  96          , nest 8 $ lbrace <+> ppr info $$ rbrace
  97          , nest 4 $ ppr graph
  98          , rbrace ]
  99
 100 -- --------------------------------------------------------------------------
 101 -- We follow [1], 4.5
 102 --
 103 --      section "data" { ... }
 104 --
 105 pprTop (CmmData section ds) =
 106     (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
 107     $$ rbrace
 108
 109 -- --------------------------------------------------------------------------
 110 -- Info tables.
 111
 112 pprInfoTable :: CmmInfoTable -> SDoc
 113 pprInfoTable CmmNonInfoTable = empty
 114 pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
 115     vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+>
 116           ptext (sLit "type: ") <> pprLit closure_type,
 117           ptext (sLit "desc: ") <> pprLit closure_desc,
 118           ptext (sLit "tag: ") <> integer (toInteger tag),
 119           pprTypeInfo info]
 120
 121 pprTypeInfo :: ClosureTypeInfo -> SDoc
 122 pprTypeInfo (ConstrInfo layout constr descr) =
 123     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 124           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 125           ptext (sLit "constructor: ") <> integer (toInteger constr),
 126           pprLit descr]
 127 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
 128     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 129           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 130           ptext (sLit "srt: ") <> ppr srt,
 131 -- Temp Jan08
 132           ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
 133
 134           ptext (sLit "arity: ") <> integer (toInteger arity),
 135           --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
 136           ptext (sLit "slow: ") <> pprLit slow_entry
 137          ]
 138 pprTypeInfo (ThunkInfo layout srt) =
 139     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 140           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 141           ptext (sLit "srt: ") <> ppr srt]
 142 pprTypeInfo (ThunkSelectorInfo offset srt) =
 143     vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
 144           ptext (sLit "srt: ") <> ppr srt]
 145 pprTypeInfo (ContInfo stack srt) =
 146     vcat [ptext (sLit "stack: ") <> ppr stack,
 147           ptext (sLit "srt: ") <> ppr srt]
 148
 149 -- Temp Jan08
 150 argDescrType :: ArgDescr -> StgHalfWord
 151 -- The "argument type" RTS field type
 152 argDescrType (ArgSpec n) = n
 153 argDescrType (ArgGen liveness)
 154   | isBigLiveness liveness = ARG_GEN_BIG
 155   | otherwise              = ARG_GEN
 156
 157 -- Temp Jan08
 158 isBigLiveness :: Liveness -> Bool
 159 isBigLiveness (BigLiveness _)   = True
 160 isBigLiveness (SmallLiveness _) = False
 161
 162 instance Outputable ForeignHint where
 163   ppr NoHint     = empty
 164   ppr SignedHint = quotes(text "signed")
 165 --  ppr AddrHint   = quotes(text "address")
 166 -- Temp Jan08
 167   ppr AddrHint   = (text "PtrHint")
 168
 169 -- --------------------------------------------------------------------------
 170 -- Static data.
 171 --      Strings are printed as C strings, and we print them as I8[],
 172 --      following C--
 173 --
 174 pprStatic :: CmmStatic -> SDoc
 175 pprStatic s = case s of
 176     CmmStaticLit lit   -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
 177     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 178     CmmAlign i         -> nest 4 $ text "align" <+> int i
 179     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 180     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 181
 182 -- --------------------------------------------------------------------------
 183 -- data sections
 184 --
 185 pprSection :: Section -> SDoc
 186 pprSection s = case s of
 187     Text              -> section <+> doubleQuotes (ptext (sLit "text"))
 188     Data              -> section <+> doubleQuotes (ptext (sLit "data"))
 189     ReadOnlyData      -> section <+> doubleQuotes (ptext (sLit "readonly"))
 190     ReadOnlyData16    -> section <+> doubleQuotes (ptext (sLit "readonly16"))
 191     RelocatableReadOnlyData
 192                       -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
 193     UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
 194     OtherSection s'   -> section <+> doubleQuotes (text s')
 195  where
 196     section = ptext (sLit "section")