Fix #11407.
[ghc.git] / compiler / cmm / PprCmmDecl.hs
1 {-# LANGUAGE CPP #-}
2
3 ----------------------------------------------------------------------------
4 --
5 -- Pretty-printing of common Cmm types
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 --
12 -- This is where we walk over Cmm emitting an external representation,
13 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
14 -- is the "External Core" for the Cmm layer.
15 --
16 -- As such, this should be a well-defined syntax: we want it to look nice.
17 -- Thus, we try wherever possible to use syntax defined in [1],
18 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
19 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
20 -- than C--'s bits8 .. bits64.
21 --
22 -- We try to ensure that all information available in the abstract
23 -- syntax is reproduced, or reproducible, in the concrete syntax.
24 -- Data that is not in printed out can be reconstructed according to
25 -- conventions used in the pretty printer. There are at least two such
26 -- cases:
27 -- 1) if a value has wordRep type, the type is not appended in the
28 -- output.
29 -- 2) MachOps that operate over wordRep type are printed in a
30 -- C-style, rather than as their internal MachRep name.
31 --
32 -- These conventions produce much more readable Cmm output.
33 --
34 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
35 --
36
37 {-# OPTIONS_GHC -fno-warn-orphans #-}
38 module PprCmmDecl
39 ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
40 )
41 where
42
43 import PprCmmExpr
44 import Cmm
45
46 import DynFlags
47 import Outputable
48 import FastString
49
50 import Data.List
51 import System.IO
52
53 -- Temp Jan08
54 import SMRep
55 #include "../includes/rts/storage/FunTypes.h"
56
57
58 pprCmms :: (Outputable info, Outputable g)
59 => [GenCmmGroup CmmStatics info g] -> SDoc
60 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
61 where
62 separator = space $$ text "-------------------" $$ space
63
64 writeCmms :: (Outputable info, Outputable g)
65 => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
66 writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
67
68 -----------------------------------------------------------------------------
69
70 instance (Outputable d, Outputable info, Outputable i)
71 => Outputable (GenCmmDecl d info i) where
72 ppr t = pprTop t
73
74 instance Outputable CmmStatics where
75 ppr = pprStatics
76
77 instance Outputable CmmStatic where
78 ppr = pprStatic
79
80 instance Outputable CmmInfoTable where
81 ppr = pprInfoTable
82
83
84 -----------------------------------------------------------------------------
85
86 pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
87 => GenCmmGroup d info g -> SDoc
88 pprCmmGroup tops
89 = vcat $ intersperse blankLine $ map pprTop tops
90
91 -- --------------------------------------------------------------------------
92 -- Top level `procedure' blocks.
93 --
94 pprTop :: (Outputable d, Outputable info, Outputable i)
95 => GenCmmDecl d info i -> SDoc
96
97 pprTop (CmmProc info lbl live graph)
98
99 = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live
100 , nest 8 $ lbrace <+> ppr info $$ rbrace
101 , nest 4 $ ppr graph
102 , rbrace ]
103
104 -- --------------------------------------------------------------------------
105 -- We follow [1], 4.5
106 --
107 -- section "data" { ... }
108 --
109 pprTop (CmmData section ds) =
110 (hang (pprSection section <+> lbrace) 4 (ppr ds))
111 $$ rbrace
112
113 -- --------------------------------------------------------------------------
114 -- Info tables.
115
116 pprInfoTable :: CmmInfoTable -> SDoc
117 pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
118 , cit_prof = prof_info
119 , cit_srt = _srt })
120 = vcat [ text "label:" <+> ppr lbl
121 , text "rep:" <> ppr rep
122 , case prof_info of
123 NoProfilingInfo -> empty
124 ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct
125 , text "desc: " <> pprWord8String cd ] ]
126
127 instance Outputable C_SRT where
128 ppr NoC_SRT = text "_no_srt_"
129 ppr (C_SRT label off bitmap)
130 = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)
131
132 instance Outputable ForeignHint where
133 ppr NoHint = empty
134 ppr SignedHint = quotes(text "signed")
135 -- ppr AddrHint = quotes(text "address")
136 -- Temp Jan08
137 ppr AddrHint = (text "PtrHint")
138
139 -- --------------------------------------------------------------------------
140 -- Static data.
141 -- Strings are printed as C strings, and we print them as I8[],
142 -- following C--
143 --
144 pprStatics :: CmmStatics -> SDoc
145 pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
146
147 pprStatic :: CmmStatic -> SDoc
148 pprStatic s = case s of
149 CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi
150 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
151 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
152
153 -- --------------------------------------------------------------------------
154 -- data sections
155 --
156 pprSection :: Section -> SDoc
157 pprSection (Section t suffix) =
158 section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
159 where
160 section = text "section"
161
162 pprSectionType :: SectionType -> SDoc
163 pprSectionType s = doubleQuotes (ptext t)
164 where
165 t = case s of
166 Text -> sLit "text"
167 Data -> sLit "data"
168 ReadOnlyData -> sLit "readonly"
169 ReadOnlyData16 -> sLit "readonly16"
170 RelocatableReadOnlyData
171 -> sLit "relreadonly"
172 UninitialisedData -> sLit "uninitialised"
173 OtherSection s' -> sLit s' -- Not actually a literal though.