--- /dev/null
+----------------------------------------------------------------------------
+--
+-- 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.cminusminus.org/. 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
+--
+
+module PprCmmDecl
+ ( writeCmms, pprCmms, pprCmm, pprSection, pprStatic
+ )
+where
+
+import CmmDecl
+import CLabel
+import PprCmmExpr
+
+
+import Outputable
+import FastString
+
+import Data.List
+import System.IO
+
+-- Temp Jan08
+import SMRep
+import ClosureInfo
+#include "../includes/rts/storage/FunTypes.h"
+
+
+pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+ where
+ separator = space $$ ptext (sLit "-------------------") $$ space
+
+writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO ()
+writeCmms handle cmms = printForC handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance (Outputable d, Outputable info, Outputable g)
+ => Outputable (GenCmm d info g) where
+ ppr c = pprCmm c
+
+instance (Outputable d, Outputable info, Outputable i)
+ => Outputable (GenCmmTop d info i) where
+ ppr t = pprTop t
+
+instance Outputable CmmStatic where
+ ppr e = pprStatic e
+
+instance Outputable CmmInfoTable where
+ ppr e = pprInfoTable e
+
+
+-----------------------------------------------------------------------------
+
+pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
+pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
+
+pprTop (CmmProc info lbl graph)
+
+ = vcat [ pprCLabel lbl <> lparen <> rparen
+ , nest 8 $ lbrace <+> ppr info $$ rbrace
+ , nest 4 $ ppr graph
+ , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+-- section "data" { ... }
+--
+pprTop (CmmData section ds) =
+ (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
+ $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables.
+
+pprInfoTable :: CmmInfoTable -> SDoc
+pprInfoTable CmmNonInfoTable = empty
+pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
+ vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+>
+ ptext (sLit "type: ") <> pprLit closure_type,
+ ptext (sLit "desc: ") <> pprLit closure_desc,
+ ptext (sLit "tag: ") <> integer (toInteger tag),
+ pprTypeInfo info]
+
+pprTypeInfo :: ClosureTypeInfo -> SDoc
+pprTypeInfo (ConstrInfo layout constr descr) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "constructor: ") <> integer (toInteger constr),
+ pprLit descr]
+pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt,
+-- Temp Jan08
+ ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
+
+ ptext (sLit "arity: ") <> integer (toInteger arity),
+ --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
+ ptext (sLit "slow: ") <> pprLit slow_entry
+ ]
+pprTypeInfo (ThunkInfo layout srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ThunkSelectorInfo offset srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ContInfo stack srt) =
+ vcat [ptext (sLit "stack: ") <> ppr stack,
+ ptext (sLit "srt: ") <> ppr srt]
+
+-- Temp Jan08
+argDescrType :: ArgDescr -> StgHalfWord
+-- The "argument type" RTS field type
+argDescrType (ArgSpec n) = n
+argDescrType (ArgGen liveness)
+ | isBigLiveness liveness = ARG_GEN_BIG
+ | otherwise = ARG_GEN
+
+-- Temp Jan08
+isBigLiveness :: Liveness -> Bool
+isBigLiveness (BigLiveness _) = True
+isBigLiveness (SmallLiveness _) = False
+
+instance Outputable ForeignHint where
+ ppr NoHint = empty
+ ppr SignedHint = quotes(text "signed")
+-- ppr AddrHint = quotes(text "address")
+-- Temp Jan08
+ ppr AddrHint = (text "PtrHint")
+
+-- --------------------------------------------------------------------------
+-- Static data.
+-- Strings are printed as C strings, and we print them as I8[],
+-- following C--
+--
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+ CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
+ CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+ CmmAlign i -> nest 4 $ text "align" <+> int i
+ CmmDataLabel clbl -> pprCLabel clbl <> colon
+ CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection s = case s of
+ Text -> section <+> doubleQuotes (ptext (sLit "text"))
+ Data -> section <+> doubleQuotes (ptext (sLit "data"))
+ ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
+ ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
+ RelocatableReadOnlyData
+ -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
+ UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
+ OtherSection s' -> section <+> doubleQuotes (text s')
+ where
+ section = ptext (sLit "section")
projects / ghc-hetmet.git / blobdiff