+++ /dev/null
-----------------------------------------------------------------------------
---
--- Pretty-printing of Cmm as (a superset of) C--
---
--- (c) The University of Glasgow 2004
---
------------------------------------------------------------------------------
-
---
--- 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 PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
- ) where
-
-#include "HsVersions.h"
-
-import Cmm
-import CmmUtils ( isTrivialCmmExpr )
-import MachOp ( MachOp(..), pprMachOp, MachRep(..), wordRep )
-import CLabel ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
-
-import ForeignCall ( CCallConv(..) )
-import Unique ( getUnique )
-import Outputable
-import FastString ( mkFastString )
-
-import Data.List ( intersperse, groupBy )
-import IO ( Handle )
-import Maybe ( isJust )
-import Data.Char ( chr )
-
-pprCmms :: [Cmm] -> SDoc
-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
- where
- separator = space $$ ptext SLIT("-------------------") $$ space
-
-writeCmms :: Handle -> [Cmm] -> IO ()
-writeCmms handle cmms = printForC handle (pprCmms cmms)
-
------------------------------------------------------------------------------
-
-instance Outputable Cmm where
- ppr c = pprCmm c
-
-instance Outputable CmmTop where
- ppr t = pprTop t
-
-instance Outputable CmmBasicBlock where
- ppr b = pprBBlock b
-
-instance Outputable CmmStmt where
- ppr s = pprStmt s
-
-instance Outputable CmmExpr where
- ppr e = pprExpr e
-
-instance Outputable CmmReg where
- ppr e = pprReg e
-
-instance Outputable GlobalReg where
- ppr e = pprGlobalReg e
-
------------------------------------------------------------------------------
-
-pprCmm :: Cmm -> SDoc
-pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-
--- --------------------------------------------------------------------------
--- Top level `procedure' blocks. The info tables, if not null, are
--- printed in the style of C--'s 'stackdata' declaration, just inside
--- the proc body, and are labelled with the procedure name ++ "_info".
---
-pprTop :: CmmTop -> SDoc
-pprTop (CmmProc info lbl params blocks )
-
- = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
- , nest 8 $ pprInfo info lbl
- , nest 4 $ vcat (map ppr blocks)
- , rbrace ]
-
- where
- pprInfo [] _ = empty
- pprInfo i label =
- (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
- 4 $ vcat (map pprStatic i))
- $$ rbrace
-
--- --------------------------------------------------------------------------
--- We follow [1], 4.5
---
--- section "data" { ... }
---
-pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
- $$ rbrace
-
-
--- --------------------------------------------------------------------------
--- Basic blocks look like assembly blocks.
--- lbl: stmt ; stmt ; ..
-pprBBlock :: CmmBasicBlock -> SDoc
-pprBBlock (BasicBlock ident stmts) =
- hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
-
--- --------------------------------------------------------------------------
--- Statements. C-- usually, exceptions to this should be obvious.
---
-pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
-
- -- ;
- CmmNop -> semi
-
- -- // text
- CmmComment s -> text "//" <+> ftext s
-
- -- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
- -- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
- where
- rep = ppr ( cmmExprRep expr )
-
- -- call "ccall" foo(x, y)[r1, r2];
- -- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args _volatile ->
- hcat [ ptext SLIT("call"), space,
- doubleQuotes(ppr cconv), space,
- target fn, parens ( commafy $ map ppr args ),
- (if null results
- then empty
- else brackets( commafy $ map ppr results)), semi ]
- where
- target (CmmLit lit) = pprLit lit
- target fn' = parens (ppr fn')
-
- CmmCall (CmmPrim op) results args volatile ->
- pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
- results args volatile)
- where
- lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
-
- CmmBranch ident -> genBranch ident
- CmmCondBranch expr ident -> genCondBranch expr ident
- CmmJump expr params -> genJump expr params
- CmmSwitch arg ids -> genSwitch arg ids
-
--- --------------------------------------------------------------------------
--- goto local label. [1], section 6.6
---
--- goto lbl;
---
-genBranch :: BlockId -> SDoc
-genBranch ident =
- ptext SLIT("goto") <+> pprBlockId ident <> semi
-
--- --------------------------------------------------------------------------
--- Conditional. [1], section 6.4
---
--- if (expr) { goto lbl; }
---
-genCondBranch :: CmmExpr -> BlockId -> SDoc
-genCondBranch expr ident =
- hsep [ ptext SLIT("if")
- , parens(ppr expr)
- , ptext SLIT("goto")
- , pprBlockId ident <> semi ]
-
--- --------------------------------------------------------------------------
--- A tail call. [1], Section 6.9
---
--- jump foo(a, b, c);
---
-genJump :: CmmExpr -> [LocalReg] -> SDoc
-genJump expr actuals =
-
- hcat [ ptext SLIT("jump")
- , space
- , if isTrivialCmmExpr expr
- then pprExpr expr
- else case expr of
- CmmLoad (CmmReg _) _ -> pprExpr expr
- _ -> parens (pprExpr expr)
- , pprActuals actuals
- , semi ]
-
- where
- pprActuals [] = empty
- pprActuals as = parens ( commafy $ map pprLocalReg as )
-
--- --------------------------------------------------------------------------
--- Tabled jump to local label
---
--- The syntax is from [1], section 6.5
---
--- switch [0 .. n] (expr) { case ... ; }
---
-genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
-genSwitch expr maybe_ids
-
- = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
-
- in hang (hcat [ ptext SLIT("switch [0 .. ")
- , int (length maybe_ids - 1)
- , ptext SLIT("] ")
- , if isTrivialCmmExpr expr
- then pprExpr expr
- else parens (pprExpr expr)
- , ptext SLIT(" {")
- ])
- 4 (vcat ( map caseify pairs )) $$ rbrace
-
- where
- snds a b = (snd a) == (snd b)
-
- caseify :: [(Int,Maybe BlockId)] -> SDoc
- caseify ixs@((i,Nothing):_)
- = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
- <> ptext SLIT(" */")
- caseify as
- = let (is,ids) = unzip as
- in hsep [ ptext SLIT("case")
- , hcat (punctuate comma (map int is))
- , ptext SLIT(": goto")
- , pprBlockId (head [ id | Just id <- ids]) <> semi ]
-
--- --------------------------------------------------------------------------
--- Expressions
---
-
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
- = case e of
- CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
- [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = cmmRegRep reg
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
-
--- Here's the precedence table from CmmParse.y:
--- %nonassoc '>=' '>' '<=' '<' '!=' '=='
--- %left '|'
--- %left '^'
--- %left '&'
--- %left '>>' '<<'
--- %left '-' '+'
--- %left '/' '*' '%'
--- %right '~'
-
--- We just cope with the common operators for now, the rest will get
--- a default conservative behaviour.
-
--- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
-
-infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
-infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
-infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
-infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
-infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
-infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
-infixMachOp1 (MO_U_Gt _) = Just (char '>')
-infixMachOp1 (MO_U_Lt _) = Just (char '<')
-infixMachOp1 _ = Nothing
-
--- %left '-' '+'
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
-
-infixMachOp7 (MO_Add _) = Just (char '+')
-infixMachOp7 (MO_Sub _) = Just (char '-')
-infixMachOp7 _ = Nothing
-
--- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
-
-infixMachOp8 (MO_U_Quot _) = Just (char '/')
-infixMachOp8 (MO_Mul _) = Just (char '*')
-infixMachOp8 (MO_U_Rem _) = Just (char '%')
-infixMachOp8 _ = Nothing
-
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
- case e of
- CmmLit lit -> pprLit1 lit
- CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
- CmmReg reg -> ppr reg
- CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp mop args
-
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
- | Just doc <- infixMachOp mop = case args of
- -- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
-
- -- unary
- [x] -> doc <> pprExpr9 x
-
- _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
- (pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
- empty
-
- | isJust (infixMachOp1 mop)
- || isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
-
- | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
-
---
--- Unsigned ops on the word size of the machine get nice symbols.
--- All else get dumped in their ugly format.
---
-infixMachOp :: MachOp -> Maybe SDoc
-infixMachOp mop
- = case mop of
- MO_And _ -> Just $ char '&'
- MO_Or _ -> Just $ char '|'
- MO_Xor _ -> Just $ char '^'
- MO_Not _ -> Just $ char '~'
- MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
- _ -> Nothing
-
--- --------------------------------------------------------------------------
--- Literals.
--- To minimise line noise we adopt the convention that if the literal
--- has the natural machine word size, we do not append the type
---
-pprLit :: CmmLit -> SDoc
-pprLit lit = case lit of
- CmmInt i rep ->
- hcat [ (if i < 0 then parens else id)(integer i)
- , (if rep == wordRep
- then empty
- else space <> dcolon <+> ppr rep) ]
-
- CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
- CmmLabel clbl -> pprCLabel clbl
- CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
- CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
- <> pprCLabel clbl2 <> ppr_offset i
-
-pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
-
-ppr_offset :: Int -> SDoc
-ppr_offset i
- | i==0 = empty
- | i>=0 = char '+' <> int i
- | otherwise = char '-' <> int (-i)
-
--- --------------------------------------------------------------------------
--- 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[]" <+>
- doubleQuotes (text (map (chr.fromIntegral) s'))
-
--- --------------------------------------------------------------------------
--- Registers, whether local (temps) or global
---
-pprReg :: CmmReg -> SDoc
-pprReg r
- = case r of
- CmmLocal local -> pprLocalReg local
- CmmGlobal global -> pprGlobalReg global
-
---
--- We only print the type of the local reg if it isn't wordRep
---
-pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep)
- = hcat [ char '_', ppr uniq,
- (if rep == wordRep
- then empty else dcolon <> ppr rep) ]
-
--- needs to be kept in syn with Cmm.hs.GlobalReg
---
-pprGlobalReg :: GlobalReg -> SDoc
-pprGlobalReg gr
- = case gr of
- VanillaReg n -> char 'R' <> int n
- FloatReg n -> char 'F' <> int n
- DoubleReg n -> char 'D' <> int n
- LongReg n -> char 'L' <> int n
- Sp -> ptext SLIT("Sp")
- SpLim -> ptext SLIT("SpLim")
- Hp -> ptext SLIT("Hp")
- HpLim -> ptext SLIT("HpLim")
- CurrentTSO -> ptext SLIT("CurrentTSO")
- CurrentNursery -> ptext SLIT("CurrentNursery")
- HpAlloc -> ptext SLIT("HpAlloc")
- GCEnter1 -> ptext SLIT("stg_gc_enter_1")
- GCFun -> ptext SLIT("stg_gc_fun")
- BaseReg -> ptext SLIT("BaseReg")
- PicBaseReg -> ptext SLIT("PicBaseReg")
-
--- --------------------------------------------------------------------------
--- 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"))
- RelocatableReadOnlyData
- -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
- UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
- OtherSection s' -> section <+> doubleQuotes (text s')
- where
- section = ptext SLIT("section")
-
--- --------------------------------------------------------------------------
--- Basic block ids
---
-pprBlockId :: BlockId -> SDoc
-pprBlockId b = ppr $ getUnique b
-
------------------------------------------------------------------------------
-
-commafy :: [SDoc] -> SDoc
-commafy xs = hsep $ punctuate comma xs
-
projects / ghc-hetmet.git / blobdiff