1 files changed, 196 insertions, 0 deletions
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
new file mode 100644
index 0000000000..1f520bfc90
--- /dev/null
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -0,0 +1,196 @@
+----------------------------------------------------------------------------
+--
+-- 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")