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