diff options
Diffstat (limited to 'compiler/cmm/PprCmm.hs')
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 462 |
1 files changed, 462 insertions, 0 deletions
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs new file mode 100644 index 0000000000..6e8367d662 --- /dev/null +++ b/compiler/cmm/PprCmm.hs @@ -0,0 +1,462 @@ +---------------------------------------------------------------------------- +-- +-- 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 + |