module PprCmmDecl
( writeCmms, pprCmms, pprCmm, pprSection, pprStatic
)
where
import CmmDecl
import CLabel
import PprCmmExpr
import Outputable
import Platform
import FastString
import Data.List
import System.IO
import SMRep
import ClosureInfo
#include "../includes/rts/storage/FunTypes.h"
pprCmms :: (Outputable info, PlatformOutputable g)
=> Platform -> [GenCmm CmmStatics info g] -> SDoc
pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms))
where
separator = space $$ ptext (sLit "-------------------") $$ space
writeCmms :: (Outputable info, PlatformOutputable g)
=> Platform -> Handle -> [GenCmm CmmStatics info g] -> IO ()
writeCmms platform handle cmms = printForC handle (pprCmms platform cmms)
instance (Outputable d, Outputable info, PlatformOutputable g)
=> PlatformOutputable (GenCmm d info g) where
pprPlatform platform c = pprCmm platform c
instance (Outputable d, Outputable info, PlatformOutputable i)
=> PlatformOutputable (GenCmmTop d info i) where
pprPlatform platform t = pprTop platform t
instance Outputable CmmStatics where
ppr e = pprStatics e
instance Outputable CmmStatic where
ppr e = pprStatic e
instance Outputable CmmInfoTable where
ppr e = pprInfoTable e
pprCmm :: (Outputable d, Outputable info, PlatformOutputable g)
=> Platform -> GenCmm d info g -> SDoc
pprCmm platform (Cmm tops)
= vcat $ intersperse blankLine $ map (pprTop platform) tops
pprTop :: (Outputable d, Outputable info, PlatformOutputable i)
=> Platform -> GenCmmTop d info i -> SDoc
pprTop platform (CmmProc info lbl graph)
= vcat [ pprCLabel lbl <> lparen <> rparen
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ pprPlatform platform graph
, rbrace ]
pprTop _ (CmmData section ds) =
(hang (pprSection section <+> lbrace) 4 (ppr ds))
$$ rbrace
pprInfoTable :: CmmInfoTable -> SDoc
pprInfoTable CmmNonInfoTable = empty
pprInfoTable (CmmInfoTable is_local stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
vcat [ptext (sLit "is local: ") <> ppr is_local <+>
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,
ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
ptext (sLit "arity: ") <> integer (toInteger arity),
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]
argDescrType :: ArgDescr -> StgHalfWord
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
| isBigLiveness liveness = ARG_GEN_BIG
| otherwise = ARG_GEN
isBigLiveness :: Liveness -> Bool
isBigLiveness (BigLiveness _) = True
isBigLiveness (SmallLiveness _) = False
instance Outputable ForeignHint where
ppr NoHint = empty
ppr SignedHint = quotes(text "signed")
ppr AddrHint = (text "PtrHint")
pprStatics :: CmmStatics -> SDoc
pprStatics (Statics lbl ds) = vcat ((pprCLabel lbl <> colon) : map ppr ds)
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)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
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")