cmm/PprCmmExpr.hs

    ----------------------------------------------------------------------------
    --
    -- 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
    --

    {-# OPTIONS_GHC -fno-warn-orphans #-}
    module PprCmmExpr
        ( pprExpr, pprLit
        )
    where

    import CmmExpr

    import Outputable

    import Data.Maybe
    import Numeric ( fromRat )

    -----------------------------------------------------------------------------

    instance Outputable CmmExpr where
        ppr e = pprExpr e

    instance Outputable CmmReg where
        ppr e = pprReg e

    instance Outputable CmmLit where
        ppr l = pprLit l

    instance Outputable LocalReg where
        ppr e = pprLocalReg e

    instance Outputable Area where
        ppr e = pprArea e

    instance Outputable GlobalReg where
        ppr e = pprGlobalReg e

    -- --------------------------------------------------------------------------
    -- Expressions
    --

    pprExpr :: CmmExpr -> SDoc
    pprExpr e
        = sdocWithDynFlags $ \dflags ->
          case e of
            CmmRegOff reg i ->
                    pprExpr (CmmMachOp (MO_Add rep)
                               [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
                    where rep = typeWidth (cmmRegType dflags 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, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
    pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
       = pprExpr7 x <+> doc <+> pprExpr7 y
    pprExpr1 e = pprExpr7 e

    infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc

    infixMachOp1 (MO_Eq     _) = Just (text "==")
    infixMachOp1 (MO_Ne     _) = Just (text "!=")
    infixMachOp1 (MO_Shl    _) = Just (text "<<")
    infixMachOp1 (MO_U_Shr  _) = Just (text ">>")
    infixMachOp1 (MO_U_Ge   _) = Just (text ">=")
    infixMachOp1 (MO_U_Le   _) = Just (text "<=")
    infixMachOp1 (MO_U_Gt   _) = Just (char '>')
    infixMachOp1 (MO_U_Lt   _) = Just (char '<')
    infixMachOp1 _             = Nothing

    -- %left '-' '+'
    pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
       = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
    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)
            CmmStackSlot a off  -> parens (ppr a   <+> 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 '%' <> ppr_op <> parens (commafy (map pprExpr args))
            where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
                                     (show mop))
                    -- replace spaces in (show mop) with underscores,

    --
    -- 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 = sdocWithDynFlags $ \dflags ->
                 case lit of
        CmmInt i rep ->
            hcat [ (if i < 0 then parens else id)(integer i)
                 , ppUnless (rep == wordWidth dflags) $
                   space <> dcolon <+> ppr rep ]

        CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]
        CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'
        CmmLabel clbl      -> ppr clbl
        CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
        CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'
                                      <> ppr clbl2 <> ppr_offset i
        CmmBlock id        -> ppr id
        CmmHighStackMark -> text "<highSp>"

    pprLit1 :: CmmLit -> SDoc
    pprLit1 lit@(CmmLabelOff {}) = 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)

    -- --------------------------------------------------------------------------
    -- 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)
    --   = ppr rep <> char '_' <> ppr uniq
    -- Temp Jan08
       = char '_' <> ppr uniq <>
           (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
                        then dcolon <> ptr <> ppr rep
                        else dcolon <> ptr <> ppr rep)
       where
         ptr = empty
             --if isGcPtrType rep
             --      then doubleQuotes (text "ptr")
             --      else empty

    -- Stack areas
    pprArea :: Area -> SDoc
    pprArea Old        = text "old"
    pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]

    -- needs to be kept in syn with CmmExpr.hs.GlobalReg
    --
    pprGlobalReg :: GlobalReg -> SDoc
    pprGlobalReg gr
        = case gr of
            VanillaReg n _ -> char 'R' <> int n
    -- Temp Jan08
    --        VanillaReg n VNonGcPtr -> char 'R' <> int n
    --        VanillaReg n VGcPtr    -> char 'P' <> int n
            FloatReg   n   -> char 'F' <> int n
            DoubleReg  n   -> char 'D' <> int n
            LongReg    n   -> char 'L' <> int n
            XmmReg     n   -> text "XMM" <> int n
            YmmReg     n   -> text "YMM" <> int n
            ZmmReg     n   -> text "ZMM" <> int n
            Sp             -> text "Sp"
            SpLim          -> text "SpLim"
            Hp             -> text "Hp"
            HpLim          -> text "HpLim"
            MachSp         -> text "MachSp"
            UnwindReturnReg-> text "UnwindReturnReg"
            CCCS           -> text "CCCS"
            CurrentTSO     -> text "CurrentTSO"
            CurrentNursery -> text "CurrentNursery"
            HpAlloc        -> text "HpAlloc"
            EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
            GCEnter1       -> text "stg_gc_enter_1"
            GCFun          -> text "stg_gc_fun"
            BaseReg        -> text "BaseReg"
            PicBaseReg     -> text "PicBaseReg"

    -----------------------------------------------------------------------------

    commafy :: [SDoc] -> SDoc
    commafy xs = fsep $ punctuate comma xs