nativeGen/SPARC/Ppr.hs

    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------
    --
    -- Pretty-printing assembly language
    --
    -- (c) The University of Glasgow 1993-2005
    --
    -----------------------------------------------------------------------------

    {-# OPTIONS_GHC -fno-warn-orphans #-}

    module SPARC.Ppr (
            pprNatCmmDecl,
            pprBasicBlock,
            pprData,
            pprInstr,
            pprFormat,
            pprImm,
            pprDataItem
    )

    where

    #include "HsVersions.h"

    import GhcPrelude

    import SPARC.Regs
    import SPARC.Instr
    import SPARC.Cond
    import SPARC.Imm
    import SPARC.AddrMode
    import SPARC.Base
    import Instruction
    import Reg
    import Format
    import PprBase

    import Cmm hiding (topInfoTable)
    import PprCmm() -- For Outputable instances
    import BlockId
    import CLabel
    import Hoopl.Label
    import Hoopl.Collections

    import Unique           ( pprUniqueAlways )
    import Outputable
    import GHC.Platform
    import FastString

    -- -----------------------------------------------------------------------------
    -- Printing this stuff out

    pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
    pprNatCmmDecl (CmmData section dats) =
      pprSectionAlign section $$ pprDatas dats

    pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
      case topInfoTable proc of
        Nothing ->
            -- special case for code without info table:
            pprSectionAlign (Section Text lbl) $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
            vcat (map (pprBasicBlock top_info) blocks)

        Just (Statics info_lbl _) ->
          sdocWithPlatform $ \platform ->
          (if platformHasSubsectionsViaSymbols platform
              then pprSectionAlign dspSection $$
                   ppr (mkDeadStripPreventer info_lbl) <> char ':'
              else empty) $$
          vcat (map (pprBasicBlock top_info) blocks) $$
          -- above: Even the first block gets a label, because with branch-chain
          -- elimination, it might be the target of a goto.
          (if platformHasSubsectionsViaSymbols platform
           then
           -- See Note [Subsections Via Symbols] in X86/Ppr.hs
                    text "\t.long "
                <+> ppr info_lbl
                <+> char '-'
                <+> ppr (mkDeadStripPreventer info_lbl)
           else empty)

    dspSection :: Section
    dspSection = Section Text $
        panic "subsections-via-symbols doesn't combine with split-sections"

    pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
    pprBasicBlock info_env (BasicBlock blockid instrs)
      = maybe_infotable $$
        pprLabel (blockLbl blockid) $$
        vcat (map pprInstr instrs)
      where
        maybe_infotable = case mapLookup blockid info_env of
           Nothing   -> empty
           Just (Statics info_lbl info) ->
               pprAlignForSection Text $$
               vcat (map pprData info) $$
               pprLabel info_lbl

    pprDatas :: CmmStatics -> SDoc
    -- See note [emit-time elimination of static indirections] in CLabel.
    pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
      | lbl == mkIndStaticInfoLabel
      , let labelInd (CmmLabelOff l _) = Just l
            labelInd (CmmLabel l) = Just l
            labelInd _ = Nothing
      , Just ind' <- labelInd ind
      , alias `mayRedirectTo` ind'
      = pprGloblDecl alias
        $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
    pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)

    pprData :: CmmStatic -> SDoc
    pprData (CmmString str)          = pprBytes str
    pprData (CmmUninitialised bytes) = text ".skip " <> int bytes
    pprData (CmmStaticLit lit)       = pprDataItem lit

    pprGloblDecl :: CLabel -> SDoc
    pprGloblDecl lbl
      | not (externallyVisibleCLabel lbl) = empty
      | otherwise = text ".global " <> ppr lbl

    pprTypeAndSizeDecl :: CLabel -> SDoc
    pprTypeAndSizeDecl lbl
        = sdocWithPlatform $ \platform ->
          if platformOS platform == OSLinux && externallyVisibleCLabel lbl
          then text ".type " <> ppr lbl <> ptext (sLit ", @object")
          else empty

    pprLabel :: CLabel -> SDoc
    pprLabel lbl = pprGloblDecl lbl
                $$ pprTypeAndSizeDecl lbl
                $$ (ppr lbl <> char ':')

    -- -----------------------------------------------------------------------------
    -- pprInstr: print an 'Instr'

    instance Outputable Instr where
        ppr instr = pprInstr instr

    -- | Pretty print a register.
    pprReg :: Reg -> SDoc
    pprReg reg
     = case reg of
            RegVirtual vr
             -> case vr of
                    VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u
                    VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u
                    VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u
                    VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u

            RegReal rr
             -> case rr of
                    RealRegSingle r1
                     -> pprReg_ofRegNo r1

                    RealRegPair r1 r2
                     -> text "(" <> pprReg_ofRegNo r1
                     <> vbar     <> pprReg_ofRegNo r2
                     <> text ")"

    -- | Pretty print a register name, based on this register number.
    --   The definition has been unfolded so we get a jump-table in the
    --   object code. This function is called quite a lot when emitting
    --   the asm file..
    --
    pprReg_ofRegNo :: Int -> SDoc
    pprReg_ofRegNo i
     = ptext
        (case i of {
             0 -> sLit "%g0";   1 -> sLit "%g1";
             2 -> sLit "%g2";   3 -> sLit "%g3";
             4 -> sLit "%g4";   5 -> sLit "%g5";
             6 -> sLit "%g6";   7 -> sLit "%g7";
             8 -> sLit "%o0";   9 -> sLit "%o1";
            10 -> sLit "%o2";  11 -> sLit "%o3";
            12 -> sLit "%o4";  13 -> sLit "%o5";
            14 -> sLit "%o6";  15 -> sLit "%o7";
            16 -> sLit "%l0";  17 -> sLit "%l1";
            18 -> sLit "%l2";  19 -> sLit "%l3";
            20 -> sLit "%l4";  21 -> sLit "%l5";
            22 -> sLit "%l6";  23 -> sLit "%l7";
            24 -> sLit "%i0";  25 -> sLit "%i1";
            26 -> sLit "%i2";  27 -> sLit "%i3";
            28 -> sLit "%i4";  29 -> sLit "%i5";
            30 -> sLit "%i6";  31 -> sLit "%i7";
            32 -> sLit "%f0";  33 -> sLit "%f1";
            34 -> sLit "%f2";  35 -> sLit "%f3";
            36 -> sLit "%f4";  37 -> sLit "%f5";
            38 -> sLit "%f6";  39 -> sLit "%f7";
            40 -> sLit "%f8";  41 -> sLit "%f9";
            42 -> sLit "%f10"; 43 -> sLit "%f11";
            44 -> sLit "%f12"; 45 -> sLit "%f13";
            46 -> sLit "%f14"; 47 -> sLit "%f15";
            48 -> sLit "%f16"; 49 -> sLit "%f17";
            50 -> sLit "%f18"; 51 -> sLit "%f19";
            52 -> sLit "%f20"; 53 -> sLit "%f21";
            54 -> sLit "%f22"; 55 -> sLit "%f23";
            56 -> sLit "%f24"; 57 -> sLit "%f25";
            58 -> sLit "%f26"; 59 -> sLit "%f27";
            60 -> sLit "%f28"; 61 -> sLit "%f29";
            62 -> sLit "%f30"; 63 -> sLit "%f31";
            _  -> sLit "very naughty sparc register" })

    -- | Pretty print a format for an instruction suffix.
    pprFormat :: Format -> SDoc
    pprFormat x
     = ptext
        (case x of
            II8     -> sLit "ub"
            II16    -> sLit "uh"
            II32    -> sLit ""
            II64    -> sLit "d"
            FF32    -> sLit ""
            FF64    -> sLit "d")

    -- | Pretty print a format for an instruction suffix.
    --      eg LD is 32bit on sparc, but LDD is 64 bit.
    pprStFormat :: Format -> SDoc
    pprStFormat x
     = ptext
        (case x of
            II8   -> sLit "b"
            II16  -> sLit "h"
            II32  -> sLit ""
            II64  -> sLit "x"
            FF32  -> sLit ""
            FF64  -> sLit "d")

    -- | Pretty print a condition code.
    pprCond :: Cond -> SDoc
    pprCond c
     = ptext
        (case c of
            ALWAYS  -> sLit ""
            NEVER   -> sLit "n"
            GEU     -> sLit "geu"
            LU      -> sLit "lu"
            EQQ     -> sLit "e"
            GTT     -> sLit "g"
            GE      -> sLit "ge"
            GU      -> sLit "gu"
            LTT     -> sLit "l"
            LE      -> sLit "le"
            LEU     -> sLit "leu"
            NE      -> sLit "ne"
            NEG     -> sLit "neg"
            POS     -> sLit "pos"
            VC      -> sLit "vc"
            VS      -> sLit "vs")

    -- | Pretty print an address mode.
    pprAddr :: AddrMode -> SDoc
    pprAddr am
     = case am of
            AddrRegReg r1 (RegReal (RealRegSingle 0))
             -> pprReg r1

            AddrRegReg r1 r2
             -> hcat [ pprReg r1, char '+', pprReg r2 ]

            AddrRegImm r1 (ImmInt i)
             | i == 0               -> pprReg r1
             | not (fits13Bits i)   -> largeOffsetError i
             | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]
             where
                    pp_sign = if i > 0 then char '+' else empty

            AddrRegImm r1 (ImmInteger i)
             | i == 0               -> pprReg r1
             | not (fits13Bits i)   -> largeOffsetError i
             | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]
             where
                    pp_sign = if i > 0 then char '+' else empty

            AddrRegImm r1 imm
             -> hcat [ pprReg r1, char '+', pprImm imm ]

    -- | Pretty print an immediate value.
    pprImm :: Imm -> SDoc
    pprImm imm
     = case imm of
            ImmInt i        -> int i
            ImmInteger i    -> integer i
            ImmCLbl l       -> ppr l
            ImmIndex l i    -> ppr l <> char '+' <> int i
            ImmLit s        -> s

            ImmConstantSum a b
             -> pprImm a <> char '+' <> pprImm b

            ImmConstantDiff a b
             -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen

            LO i
             -> hcat [ text "%lo(", pprImm i, rparen ]

            HI i
             -> hcat [ text "%hi(", pprImm i, rparen ]

            -- these should have been converted to bytes and placed
            --      in the data section.
            ImmFloat _      -> text "naughty float immediate"
            ImmDouble _     -> text "naughty double immediate"

    -- | Pretty print a section \/ segment header.
    --      On SPARC all the data sections must be at least 8 byte aligned
    --      incase we store doubles in them.
    --
    pprSectionAlign :: Section -> SDoc
    pprSectionAlign sec@(Section seg _) =
      sdocWithPlatform $ \platform ->
        pprSectionHeader platform sec $$
        pprAlignForSection seg

    -- | Print appropriate alignment for the given section type.
    pprAlignForSection :: SectionType -> SDoc
    pprAlignForSection seg =
        ptext (case seg of
          Text              -> sLit ".align 4"
          Data              -> sLit ".align 8"
          ReadOnlyData      -> sLit ".align 8"
          RelocatableReadOnlyData
                            -> sLit ".align 8"
          UninitialisedData -> sLit ".align 8"
          ReadOnlyData16    -> sLit ".align 16"
          -- TODO: This is copied from the ReadOnlyData case, but it can likely be
          -- made more efficient.
          CString           -> sLit ".align 8"
          OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")

    -- | Pretty print a data item.
    pprDataItem :: CmmLit -> SDoc
    pprDataItem lit
      = sdocWithDynFlags $ \dflags ->
        vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
        where
            imm = litToImm lit

            ppr_item II8   _        = [text "\t.byte\t" <> pprImm imm]
            ppr_item II32  _        = [text "\t.long\t" <> pprImm imm]

            ppr_item FF32  (CmmFloat r _)
             = let bs = floatToBytes (fromRational r)
               in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs

            ppr_item FF64 (CmmFloat r _)
             = let bs = doubleToBytes (fromRational r)
               in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs

            ppr_item II16  _        = [text "\t.short\t" <> pprImm imm]
            ppr_item II64  _        = [text "\t.quad\t" <> pprImm imm]
            ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"

    -- | Pretty print an instruction.
    pprInstr :: Instr -> SDoc

    -- nuke comments.
    pprInstr (COMMENT _)
            = empty

    pprInstr (DELTA d)
            = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))

    -- Newblocks and LData should have been slurped out before producing the .s file.
    pprInstr (NEWBLOCK _)
            = panic "X86.Ppr.pprInstr: NEWBLOCK"

    pprInstr (LDATA _ _)
            = panic "PprMach.pprInstr: LDATA"

    -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand
    pprInstr (LD FF64 _ reg)
            | RegReal (RealRegSingle{})     <- reg
            = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"

    pprInstr (LD format addr reg)
            = hcat [
                   text "\tld",
                   pprFormat format,
                   char '\t',
                   lbrack,
                   pprAddr addr,
                   pp_rbracket_comma,
                   pprReg reg
                ]

    -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand
    pprInstr (ST FF64 reg _)
            | RegReal (RealRegSingle{}) <- reg
            = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"

    -- no distinction is made between signed and unsigned bytes on stores for the
    -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
    -- so we call a special-purpose pprFormat for ST..
    pprInstr (ST format reg addr)
            = hcat [
                   text "\tst",
                   pprStFormat format,
                   char '\t',
                   pprReg reg,
                   pp_comma_lbracket,
                   pprAddr addr,
                   rbrack
                ]

    pprInstr (ADD x cc reg1 ri reg2)
            | not x && not cc && riZero ri
            = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]

            | otherwise
            = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2

    pprInstr (SUB x cc reg1 ri reg2)
            | not x && cc && reg2 == g0
            = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ]

            | not x && not cc && riZero ri
            = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]

            | otherwise
            = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2

    pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2

    pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2

    pprInstr (OR b reg1 ri reg2)
            | not b && reg1 == g0
            = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ]
              in  case ri of
                       RIReg rrr | rrr == reg2 -> empty
                       _                       -> doit

            | otherwise
            = pprRegRIReg (sLit "or") b reg1 ri reg2

    pprInstr (ORN b reg1 ri reg2)  = pprRegRIReg (sLit "orn") b reg1 ri reg2

    pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2
    pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2

    pprInstr (SLL reg1 ri reg2)    = pprRegRIReg (sLit "sll") False reg1 ri reg2
    pprInstr (SRL reg1 ri reg2)    = pprRegRIReg (sLit "srl") False reg1 ri reg2
    pprInstr (SRA reg1 ri reg2)    = pprRegRIReg (sLit "sra") False reg1 ri reg2

    pprInstr (RDY rd)              = text "\trd\t%y," <> pprReg rd
    pprInstr (WRY reg1 reg2)
            = text "\twr\t"
                    <> pprReg reg1
                    <> char ','
                    <> pprReg reg2
                    <> char ','
                    <> text "%y"

    pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul")  b reg1 ri reg2
    pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul")  b reg1 ri reg2
    pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv")  b reg1 ri reg2
    pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv")  b reg1 ri reg2

    pprInstr (SETHI imm reg)
      = hcat [
            text "\tsethi\t",
            pprImm imm,
            comma,
            pprReg reg
        ]

    pprInstr NOP
            = text "\tnop"

    pprInstr (FABS format reg1 reg2)
            = pprFormatRegReg (sLit "fabs") format reg1 reg2

    pprInstr (FADD format reg1 reg2 reg3)
            = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3

    pprInstr (FCMP e format reg1 reg2)
            = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")
                              format reg1 reg2

    pprInstr (FDIV format reg1 reg2 reg3)
            = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3

    pprInstr (FMOV format reg1 reg2)
            = pprFormatRegReg (sLit "fmov") format reg1 reg2

    pprInstr (FMUL format reg1 reg2 reg3)
            = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3

    pprInstr (FNEG format reg1 reg2)
            = pprFormatRegReg (sLit "fneg") format reg1 reg2

    pprInstr (FSQRT format reg1 reg2)
            = pprFormatRegReg (sLit "fsqrt") format reg1 reg2

    pprInstr (FSUB format reg1 reg2 reg3)
            = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3

    pprInstr (FxTOy format1 format2 reg1 reg2)
      = hcat [
            text "\tf",
            ptext
            (case format1 of
                II32  -> sLit "ito"
                FF32  -> sLit "sto"
                FF64  -> sLit "dto"
                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
            ptext
            (case format2 of
                II32  -> sLit "i\t"
                II64  -> sLit "x\t"
                FF32  -> sLit "s\t"
                FF64  -> sLit "d\t"
                _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
            pprReg reg1, comma, pprReg reg2
        ]

    pprInstr (BI cond b blockid)
      = hcat [
            text "\tb", pprCond cond,
            if b then pp_comma_a else empty,
            char '\t',
            ppr (blockLbl blockid)
        ]

    pprInstr (BF cond b blockid)
      = hcat [
            text "\tfb", pprCond cond,
            if b then pp_comma_a else empty,
            char '\t',
            ppr (blockLbl blockid)
        ]

    pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr
    pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)

    pprInstr (CALL (Left imm) n _)
      = hcat [ text "\tcall\t", pprImm imm, comma, int n ]

    pprInstr (CALL (Right reg) n _)
      = hcat [ text "\tcall\t", pprReg reg, comma, int n ]

    -- | Pretty print a RI
    pprRI :: RI -> SDoc
    pprRI (RIReg r) = pprReg r
    pprRI (RIImm r) = pprImm r

    -- | Pretty print a two reg instruction.
    pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc
    pprFormatRegReg name format reg1 reg2
      = hcat [
            char '\t',
            ptext name,
            (case format of
                FF32 -> text "s\t"
                FF64 -> text "d\t"
                _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),

            pprReg reg1,
            comma,
            pprReg reg2
        ]

    -- | Pretty print a three reg instruction.
    pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
    pprFormatRegRegReg name format reg1 reg2 reg3
      = hcat [
            char '\t',
            ptext name,
            (case format of
                FF32  -> text "s\t"
                FF64  -> text "d\t"
                _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),
            pprReg reg1,
            comma,
            pprReg reg2,
            comma,
            pprReg reg3
        ]

    -- | Pretty print an instruction of two regs and a ri.
    pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc
    pprRegRIReg name b reg1 ri reg2
      = hcat [
            char '\t',
            ptext name,
            if b then text "cc\t" else char '\t',
            pprReg reg1,
            comma,
            pprRI ri,
            comma,
            pprReg reg2
        ]

    {-
    pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc
    pprRIReg name b ri reg1
      = hcat [
            char '\t',
            ptext name,
            if b then text "cc\t" else char '\t',
            pprRI ri,
            comma,
            pprReg reg1
        ]
    -}

    {-
    pp_ld_lbracket :: SDoc
    pp_ld_lbracket    = text "\tld\t["
    -}

    pp_rbracket_comma :: SDoc
    pp_rbracket_comma = text "],"

    pp_comma_lbracket :: SDoc
    pp_comma_lbracket = text ",["

    pp_comma_a :: SDoc
    pp_comma_a        = text ",a"