compiler/cmm/PprCmmExpr.hs

   1 ----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing of common Cmm types
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 --
  10 -- This is where we walk over Cmm emitting an external representation,
  11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
  12 -- is the "External Core" for the Cmm layer.
  13 --
  14 -- As such, this should be a well-defined syntax: we want it to look nice.
  15 -- Thus, we try wherever possible to use syntax defined in [1],
  16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
  17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
  18 -- than C--'s bits8 .. bits64.
  19 --
  20 -- We try to ensure that all information available in the abstract
  21 -- syntax is reproduced, or reproducible, in the concrete syntax.
  22 -- Data that is not in printed out can be reconstructed according to
  23 -- conventions used in the pretty printer. There are at least two such
  24 -- cases:
  25 --      1) if a value has wordRep type, the type is not appended in the
  26 --      output.
  27 --      2) MachOps that operate over wordRep type are printed in a
  28 --      C-style, rather than as their internal MachRep name.
  29 --
  30 -- These conventions produce much more readable Cmm output.
  31 --
  32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
  33 --
  34
  35 module PprCmmExpr
  36     ( pprExpr, pprLit
  37     , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -}
  38     )
  39 where
  40
  41 import CmmExpr
  42 import CLabel
  43
  44 import Outputable
  45 import FastString
  46
  47 import Data.Maybe
  48
  49 -----------------------------------------------------------------------------
  50
  51 instance Outputable CmmExpr where
  52     ppr e = pprExpr e
  53
  54 instance Outputable CmmReg where
  55     ppr e = pprReg e
  56
  57 instance Outputable CmmLit where
  58     ppr l = pprLit l
  59
  60 instance Outputable LocalReg where
  61     ppr e = pprLocalReg e
  62
  63 instance Outputable Area where
  64     ppr e = pprArea e
  65
  66 instance Outputable GlobalReg where
  67     ppr e = pprGlobalReg e
  68
  69 -- --------------------------------------------------------------------------
  70 -- Expressions
  71 --
  72
  73 pprExpr :: CmmExpr -> SDoc
  74 pprExpr e
  75     = case e of
  76         CmmRegOff reg i ->
  77                 pprExpr (CmmMachOp (MO_Add rep)
  78                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
  79                 where rep = typeWidth (cmmRegType reg)
  80         CmmLit lit -> pprLit lit
  81         _other     -> pprExpr1 e
  82
  83 -- Here's the precedence table from CmmParse.y:
  84 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
  85 -- %left '|'
  86 -- %left '^'
  87 -- %left '&'
  88 -- %left '>>' '<<'
  89 -- %left '-' '+'
  90 -- %left '/' '*' '%'
  91 -- %right '~'
  92
  93 -- We just cope with the common operators for now, the rest will get
  94 -- a default conservative behaviour.
  95
  96 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
  97 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
  98 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
  99    = pprExpr7 x <+> doc <+> pprExpr7 y
 100 pprExpr1 e = pprExpr7 e
 101
 102 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
 103
 104 infixMachOp1 (MO_Eq     _) = Just (ptext (sLit "=="))
 105 infixMachOp1 (MO_Ne     _) = Just (ptext (sLit "!="))
 106 infixMachOp1 (MO_Shl    _) = Just (ptext (sLit "<<"))
 107 infixMachOp1 (MO_U_Shr  _) = Just (ptext (sLit ">>"))
 108 infixMachOp1 (MO_U_Ge   _) = Just (ptext (sLit ">="))
 109 infixMachOp1 (MO_U_Le   _) = Just (ptext (sLit "<="))
 110 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 111 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 112 infixMachOp1 _             = Nothing
 113
 114 -- %left '-' '+'
 115 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 116    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 117 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 118    = pprExpr7 x <+> doc <+> pprExpr8 y
 119 pprExpr7 e = pprExpr8 e
 120
 121 infixMachOp7 (MO_Add _)  = Just (char '+')
 122 infixMachOp7 (MO_Sub _)  = Just (char '-')
 123 infixMachOp7 _           = Nothing
 124
 125 -- %left '/' '*' '%'
 126 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 127    = pprExpr8 x <+> doc <+> pprExpr9 y
 128 pprExpr8 e = pprExpr9 e
 129
 130 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 131 infixMachOp8 (MO_Mul _)    = Just (char '*')
 132 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 133 infixMachOp8 _             = Nothing
 134
 135 pprExpr9 :: CmmExpr -> SDoc
 136 pprExpr9 e =
 137    case e of
 138         CmmLit    lit       -> pprLit1 lit
 139         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 140         CmmReg    reg       -> ppr reg
 141         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
 142         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
 143         CmmMachOp mop args  -> genMachOp mop args
 144
 145 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 146 genMachOp mop args
 147    | Just doc <- infixMachOp mop = case args of
 148         -- dyadic
 149         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 150
 151         -- unary
 152         [x]   -> doc <> pprExpr9 x
 153
 154         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 155                           (pprMachOp mop <+>
 156                             parens (hcat $ punctuate comma (map pprExpr args)))
 157                           empty
 158
 159    | isJust (infixMachOp1 mop)
 160    || isJust (infixMachOp7 mop)
 161    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 162
 163    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 164         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 165                                  (show mop))
 166                 -- replace spaces in (show mop) with underscores,
 167
 168 --
 169 -- Unsigned ops on the word size of the machine get nice symbols.
 170 -- All else get dumped in their ugly format.
 171 --
 172 infixMachOp :: MachOp -> Maybe SDoc
 173 infixMachOp mop
 174         = case mop of
 175             MO_And    _ -> Just $ char '&'
 176             MO_Or     _ -> Just $ char '|'
 177             MO_Xor    _ -> Just $ char '^'
 178             MO_Not    _ -> Just $ char '~'
 179             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 180             _ -> Nothing
 181
 182 -- --------------------------------------------------------------------------
 183 -- Literals.
 184 --  To minimise line noise we adopt the convention that if the literal
 185 --  has the natural machine word size, we do not append the type
 186 --
 187 pprLit :: CmmLit -> SDoc
 188 pprLit lit = case lit of
 189     CmmInt i rep ->
 190         hcat [ (if i < 0 then parens else id)(integer i)
 191              , ppUnless (rep == wordWidth) $
 192                space <> dcolon <+> ppr rep ]
 193
 194     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 195     CmmLabel clbl      -> pprCLabel clbl
 196     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 197     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 198                                   <> pprCLabel clbl2 <> ppr_offset i
 199     CmmBlock id        -> ppr id
 200     CmmHighStackMark -> text "<highSp>"
 201
 202 pprLit1 :: CmmLit -> SDoc
 203 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
 204 pprLit1 lit                  = pprLit lit
 205
 206 ppr_offset :: Int -> SDoc
 207 ppr_offset i
 208     | i==0      = empty
 209     | i>=0      = char '+' <> int i
 210     | otherwise = char '-' <> int (-i)
 211
 212 -- --------------------------------------------------------------------------
 213 -- Registers, whether local (temps) or global
 214 --
 215 pprReg :: CmmReg -> SDoc
 216 pprReg r
 217     = case r of
 218         CmmLocal  local  -> pprLocalReg  local
 219         CmmGlobal global -> pprGlobalReg global
 220
 221 --
 222 -- We only print the type of the local reg if it isn't wordRep
 223 --
 224 pprLocalReg :: LocalReg -> SDoc
 225 pprLocalReg (LocalReg uniq rep)
 226 --   = ppr rep <> char '_' <> ppr uniq
 227 -- Temp Jan08
 228    = char '_' <> ppr uniq <>
 229        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
 230                     then dcolon <> ptr <> ppr rep
 231                     else dcolon <> ptr <> ppr rep)
 232    where
 233      ptr = empty
 234          --if isGcPtrType rep
 235          --      then doubleQuotes (text "ptr")
 236          --      else empty
 237
 238 -- Stack areas
 239 pprArea :: Area -> SDoc
 240 pprArea (RegSlot r)   = hcat [ text "slot<", ppr r, text ">" ]
 241 pprArea (CallArea id) = pprAreaId id
 242
 243 pprAreaId :: AreaId -> SDoc
 244 pprAreaId Old        = text "old"
 245 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
 246
 247 -- needs to be kept in syn with CmmExpr.hs.GlobalReg
 248 --
 249 pprGlobalReg :: GlobalReg -> SDoc
 250 pprGlobalReg gr
 251     = case gr of
 252         VanillaReg n _ -> char 'R' <> int n
 253 -- Temp Jan08
 254 --        VanillaReg n VNonGcPtr -> char 'R' <> int n
 255 --        VanillaReg n VGcPtr    -> char 'P' <> int n
 256         FloatReg   n   -> char 'F' <> int n
 257         DoubleReg  n   -> char 'D' <> int n
 258         LongReg    n   -> char 'L' <> int n
 259         Sp             -> ptext (sLit "Sp")
 260         SpLim          -> ptext (sLit "SpLim")
 261         Hp             -> ptext (sLit "Hp")
 262         HpLim          -> ptext (sLit "HpLim")
 263         CurrentTSO     -> ptext (sLit "CurrentTSO")
 264         CurrentNursery -> ptext (sLit "CurrentNursery")
 265         HpAlloc        -> ptext (sLit "HpAlloc")
 266         EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 267         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 268         GCFun          -> ptext (sLit "stg_gc_fun")
 269         BaseReg        -> ptext (sLit "BaseReg")
 270         PicBaseReg     -> ptext (sLit "PicBaseReg")
 271
 272 -----------------------------------------------------------------------------
 273
 274 commafy :: [SDoc] -> SDoc
 275 commafy xs = fsep $ punctuate comma xs