{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
--
-- Machine-dependent assembly language
--
-- (c) The University of Glasgow 1993-2004
--
-----------------------------------------------------------------------------
#include "HsVersions.h"
#include "nativeGen/NCG.h"

module SPARC.Instr (
        RI(..),
        riZero,

        fpRelEA,
        moveSp,

        isUnconditionalJump,

        Instr(..),
        maxSpillSlots
)

where

import GhcPrelude

import SPARC.Stack
import SPARC.Imm
import SPARC.AddrMode
import SPARC.Cond
import SPARC.Regs
import SPARC.Base
import TargetReg
import Instruction
import RegClass
import Reg
import Format

import CLabel
import CodeGen.Platform
import BlockId
import DynFlags
import Cmm
import FastString
import Outputable
import Platform

-- | Register or immediate
data RI
        = RIReg Reg
        | RIImm Imm

-- | Check if a RI represents a zero value.
--      - a literal zero
--      - register %g0, which is always zero.
--
riZero :: RI -> Bool
riZero (RIImm (ImmInt 0))                       = True
riZero (RIImm (ImmInteger 0))                   = True
riZero (RIReg (RegReal (RealRegSingle 0)))      = True
riZero _                                        = False

-- | Calculate the effective address which would be used by the
--      corresponding fpRel sequence.
fpRelEA :: Int -> Reg -> Instr
fpRelEA n dst
   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst

-- | Code to shift the stack pointer by n words.
moveSp :: Int -> Instr
moveSp n
   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp

-- | An instruction that will cause the one after it never to be exectuted
isUnconditionalJump :: Instr -> Bool
isUnconditionalJump ii
 = case ii of
        CALL{}          -> True
        JMP{}           -> True
        JMP_TBL{}       -> True
        BI ALWAYS _ _   -> True
        BF ALWAYS _ _   -> True
        _               -> False

-- | instance for sparc instruction set
instance Instruction Instr where
        regUsageOfInstr         = sparc_regUsageOfInstr
        patchRegsOfInstr        = sparc_patchRegsOfInstr
        isJumpishInstr          = sparc_isJumpishInstr
        jumpDestsOfInstr        = sparc_jumpDestsOfInstr
        patchJumpInstr          = sparc_patchJumpInstr
        mkSpillInstr            = sparc_mkSpillInstr
        mkLoadInstr             = sparc_mkLoadInstr
        takeDeltaInstr          = sparc_takeDeltaInstr
        isMetaInstr             = sparc_isMetaInstr
        mkRegRegMoveInstr       = sparc_mkRegRegMoveInstr
        takeRegRegMoveInstr     = sparc_takeRegRegMoveInstr
        mkJumpInstr             = sparc_mkJumpInstr
        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"
        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"

-- | SPARC instruction set.
--      Not complete. This is only the ones we need.
--
data Instr

        -- meta ops --------------------------------------------------
        -- comment pseudo-op
        = COMMENT FastString

        -- some static data spat out during code generation.
        -- Will be extracted before pretty-printing.
        | LDATA   Section CmmStatics

        -- Start a new basic block.  Useful during codegen, removed later.
        -- Preceding instruction should be a jump, as per the invariants
        -- for a BasicBlock (see Cmm).
        | NEWBLOCK BlockId

        -- specify current stack offset for benefit of subsequent passes.
        | DELTA   Int

        -- real instrs -----------------------------------------------
        -- Loads and stores.
        | LD            Format AddrMode Reg             -- format, src, dst
        | ST            Format Reg AddrMode             -- format, src, dst

        -- Int Arithmetic.
        --      x:   add/sub with carry bit.
        --              In SPARC V9 addx and friends were renamed addc.
        --
        --      cc:  modify condition codes
        --
        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst
        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst

        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst
        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst

        -- The SPARC divide instructions perform 64bit by 32bit division
        --   The Y register is xored into the first operand.

        --   On _some implementations_ the Y register is overwritten by
        --   the remainder, so we have to make sure it is 0 each time.

        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2
        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst
        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst

        | RDY           Reg                             -- move contents of Y register to reg
        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2

        -- Logic operations.
        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst
        | SLL           Reg RI Reg                      -- src1, src2, dst
        | SRL           Reg RI Reg                      -- src1, src2, dst
        | SRA           Reg RI Reg                      -- src1, src2, dst

        -- Load immediates.
        | SETHI         Imm Reg                         -- src, dst

        -- Do nothing.
        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias
        | NOP

        -- Float Arithmetic.
        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single
        -- instructions right up until we spit them out.
        --
        | FABS          Format Reg Reg                  -- src dst
        | FADD          Format Reg Reg Reg              -- src1, src2, dst
        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst
        | FDIV          Format Reg Reg Reg              -- src1, src2, dst
        | FMOV          Format Reg Reg                  -- src, dst
        | FMUL          Format Reg Reg Reg              -- src1, src2, dst
        | FNEG          Format Reg Reg                  -- src, dst
        | FSQRT         Format Reg Reg                  -- src, dst
        | FSUB          Format Reg Reg Reg              -- src1, src2, dst
        | FxTOy         Format Format Reg Reg           -- src, dst

        -- Jumping around.
        | BI            Cond Bool BlockId               -- cond, annul?, target
        | BF            Cond Bool BlockId               -- cond, annul?, target

        | JMP           AddrMode                        -- target

        -- With a tabled jump we know all the possible destinations.
        -- We also need this info so we can work out what regs are live across the jump.
        --
        | JMP_TBL       AddrMode [Maybe BlockId] CLabel

        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal

-- | regUsage returns the sets of src and destination registers used
--      by a particular instruction.  Machine registers that are
--      pre-allocated to stgRegs are filtered out, because they are
--      uninteresting from a register allocation standpoint.  (We wouldn't
--      want them to end up on the free list!)  As far as we are concerned,
--      the fixed registers simply don't exist (for allocation purposes,
--      anyway).

--      regUsage doesn't need to do any trickery for jumps and such.  Just
--      state precisely the regs read and written by that insn.  The
--      consequences of control flow transfers, as far as register
--      allocation goes, are taken care of by the register allocator.
--
sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage
sparc_regUsageOfInstr platform instr
 = case instr of
    LD    _ addr reg            -> usage (regAddr addr,         [reg])
    ST    _ reg addr            -> usage (reg : regAddr addr,   [])
    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    RDY       rd                -> usage ([],                   [rd])
    WRY       r1 r2             -> usage ([r1, r2],             [])
    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
    SETHI   _ reg               -> usage ([],                   [reg])
    FABS    _ r1 r2             -> usage ([r1],                 [r2])
    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])
    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
    FMOV    _ r1 r2             -> usage ([r1],                 [r2])
    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
    FNEG    _ r1 r2             -> usage ([r1],                 [r2])
    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])
    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])

    JMP     addr                -> usage (regAddr addr, [])
    JMP_TBL addr _ _            -> usage (regAddr addr, [])

    CALL  (Left _  )  _ True    -> noUsage
    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)
    CALL  (Right reg) _ True    -> usage ([reg], [])
    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)
    _                           -> noUsage

  where
    usage (src, dst)
     = RU (filter (interesting platform) src)
          (filter (interesting platform) dst)

    regAddr (AddrRegReg r1 r2)  = [r1, r2]
    regAddr (AddrRegImm r1 _)   = [r1]

    regRI (RIReg r)             = [r]
    regRI  _                    = []

-- | Interesting regs are virtuals, or ones that are allocatable
--      by the register allocator.
interesting :: Platform -> Reg -> Bool
interesting platform reg
 = case reg of
        RegVirtual _                    -> True
        RegReal (RealRegSingle r1)      -> freeReg platform r1
        RegReal (RealRegPair r1 _)      -> freeReg platform r1

-- | Apply a given mapping to tall the register references in this instruction.
sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
sparc_patchRegsOfInstr instr env = case instr of
    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)
    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)

    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)
    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)
    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)
    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)
    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)
    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)
    RDY   rd                    -> RDY         (env rd)
    WRY   r1 r2                 -> WRY         (env r1) (env r2)
    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)
    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)
    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)
    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)
    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)
    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)
    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)
    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)
    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)

    SETHI imm reg               -> SETHI imm (env reg)

    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)
    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)
    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)
    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)
    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)
    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)
    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)
    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)
    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)
    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)

    JMP     addr                -> JMP     (fixAddr addr)
    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l

    CALL  (Left i) n t          -> CALL (Left i) n t
    CALL  (Right r) n t         -> CALL (Right (env r)) n t
    _                           -> instr

  where
    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)
    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i

    fixRI (RIReg r)             = RIReg (env r)
    fixRI other                 = other

--------------------------------------------------------------------------------
sparc_isJumpishInstr :: Instr -> Bool
sparc_isJumpishInstr instr
 = case instr of
        BI{}            -> True
        BF{}            -> True
        JMP{}           -> True
        JMP_TBL{}       -> True
        CALL{}          -> True
        _               -> False

sparc_jumpDestsOfInstr :: Instr -> [BlockId]
sparc_jumpDestsOfInstr insn
  = case insn of
        BI   _ _ id     -> [id]
        BF   _ _ id     -> [id]
        JMP_TBL _ ids _ -> [id | Just id <- ids]
        _               -> []

sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
sparc_patchJumpInstr insn patchF
  = case insn of
        BI cc annul id  -> BI cc annul (patchF id)
        BF cc annul id  -> BF cc annul (patchF id)
        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l
        _               -> insn

--------------------------------------------------------------------------------
-- | Make a spill instruction.
--      On SPARC we spill below frame pointer leaving 2 words/spill
sparc_mkSpillInstr
    :: DynFlags
    -> Reg      -- ^ register to spill
    -> Int      -- ^ current stack delta
    -> Int      -- ^ spill slot to use
    -> Instr

sparc_mkSpillInstr dflags reg _ slot
 = let  platform = targetPlatform dflags
        off      = spillSlotToOffset dflags slot
        off_w    = 1 + (off `div` 4)
        fmt      = case targetClassOfReg platform reg of
                        RcInteger -> II32
                        RcFloat   -> FF32
                        RcDouble  -> FF64
                        _         -> panic "sparc_mkSpillInstr"

    in ST fmt reg (fpRel (negate off_w))

-- | Make a spill reload instruction.
sparc_mkLoadInstr
    :: DynFlags
    -> Reg      -- ^ register to load into
    -> Int      -- ^ current stack delta
    -> Int      -- ^ spill slot to use
    -> Instr

sparc_mkLoadInstr dflags reg _ slot
  = let platform = targetPlatform dflags
        off      = spillSlotToOffset dflags slot
        off_w    = 1 + (off `div` 4)
        fmt      = case targetClassOfReg platform reg of
                        RcInteger -> II32
                        RcFloat   -> FF32
                        RcDouble  -> FF64
                        _         -> panic "sparc_mkLoadInstr"

        in LD fmt (fpRel (- off_w)) reg

--------------------------------------------------------------------------------
-- | See if this instruction is telling us the current C stack delta
sparc_takeDeltaInstr
        :: Instr
        -> Maybe Int

sparc_takeDeltaInstr instr
 = case instr of
        DELTA i         -> Just i
        _               -> Nothing

sparc_isMetaInstr
        :: Instr
        -> Bool

sparc_isMetaInstr instr
 = case instr of
        COMMENT{}       -> True
        LDATA{}         -> True
        NEWBLOCK{}      -> True
        DELTA{}         -> True
        _               -> False

-- | Make a reg-reg move instruction.
--      On SPARC v8 there are no instructions to move directly between
--      floating point and integer regs. If we need to do that then we
--      have to go via memory.
--
sparc_mkRegRegMoveInstr
    :: Platform
    -> Reg
    -> Reg
    -> Instr

sparc_mkRegRegMoveInstr platform src dst
        | srcClass      <- targetClassOfReg platform src
        , dstClass      <- targetClassOfReg platform dst
        , srcClass == dstClass
        = case srcClass of
                RcInteger -> ADD  False False src (RIReg g0) dst
                RcDouble  -> FMOV FF64 src dst
                RcFloat   -> FMOV FF32 src dst
                _         -> panic "sparc_mkRegRegMoveInstr"

        | otherwise
        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"

-- | Check whether an instruction represents a reg-reg move.
--      The register allocator attempts to eliminate reg->reg moves whenever it can,
--      by assigning the src and dest temporaries to the same real register.
--
sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
sparc_takeRegRegMoveInstr instr
 = case instr of
        ADD False False src (RIReg src2) dst
         | g0 == src2           -> Just (src, dst)

        FMOV FF64 src dst       -> Just (src, dst)
        FMOV FF32  src dst      -> Just (src, dst)
        _                       -> Nothing

-- | Make an unconditional branch instruction.
sparc_mkJumpInstr
        :: BlockId
        -> [Instr]

sparc_mkJumpInstr id
 =       [BI ALWAYS False id
        , NOP]                  -- fill the branch delay slot.


{-# 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"
#include "nativeGen/NCG.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()
import BlockId
import CLabel
import Hoopl.Label
import Hoopl.Collections

import Unique           ( pprUniqueAlways )
import Outputable
import 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
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
                VirtualRegSSE u -> text "%vSSE_" <> 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"
        _       -> panic "SPARC.Ppr.pprFormat: no match")

-- | 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"
        _       -> panic "SPARC.Ppr.pprFormat: no match")

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


-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1994-2004
--
-- -----------------------------------------------------------------------------

module SPARC.Regs (
        -- registers
        showReg,
        virtualRegSqueeze,
        realRegSqueeze,
        classOfRealReg,
        allRealRegs,

        -- machine specific info
        gReg, iReg, lReg, oReg, fReg,
        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,

        -- allocatable
        allocatableRegs,

        -- args
        argRegs,
        allArgRegs,
        callClobberedRegs,

        --
        mkVirtualReg,
        regDotColor
)

where

import GhcPrelude

import CodeGen.Platform.SPARC
import Reg
import RegClass
import Format

import Unique
import Outputable

{-
        The SPARC has 64 registers of interest; 32 integer registers and 32
        floating point registers.  The mapping of STG registers to SPARC
        machine registers is defined in StgRegs.h.  We are, of course,
        prepared for any eventuality.

        The whole fp-register pairing thing on sparcs is a huge nuisance.  See
        includes/stg/MachRegs.h for a description of what's going on
        here.
-}

-- | Get the standard name for the register with this number.
showReg :: RegNo -> String
showReg n
        | n >= 0  && n < 8   = "%g" ++ show n
        | n >= 8  && n < 16  = "%o" ++ show (n-8)
        | n >= 16 && n < 24  = "%l" ++ show (n-16)
        | n >= 24 && n < 32  = "%i" ++ show (n-24)
        | n >= 32 && n < 64  = "%f" ++ show (n-32)
        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"

-- Get the register class of a certain real reg
classOfRealReg :: RealReg -> RegClass
classOfRealReg reg
 = case reg of
        RealRegSingle i
                | i < 32        -> RcInteger
                | otherwise     -> RcFloat

        RealRegPair{}           -> RcDouble

-- | regSqueeze_class reg
--      Calculate the maximum number of register colors that could be
--      denied to a node of this class due to having this reg
--      as a neighbour.
--
{-# INLINE virtualRegSqueeze #-}
virtualRegSqueeze :: RegClass -> VirtualReg -> Int

virtualRegSqueeze cls vr
 = case cls of
        RcInteger
         -> case vr of
                VirtualRegI{}           -> 1
                VirtualRegHi{}          -> 1
                _other                  -> 0

        RcFloat
         -> case vr of
                VirtualRegF{}           -> 1
                VirtualRegD{}           -> 2
                _other                  -> 0

        RcDouble
         -> case vr of
                VirtualRegF{}           -> 1
                VirtualRegD{}           -> 1
                _other                  -> 0

        _other -> 0

{-# INLINE realRegSqueeze #-}
realRegSqueeze :: RegClass -> RealReg -> Int

realRegSqueeze cls rr
 = case cls of
        RcInteger
         -> case rr of
                RealRegSingle regNo
                        | regNo < 32    -> 1
                        | otherwise     -> 0

                RealRegPair{}           -> 0

        RcFloat
         -> case rr of
                RealRegSingle regNo
                        | regNo < 32    -> 0
                        | otherwise     -> 1

                RealRegPair{}           -> 2

        RcDouble
         -> case rr of
                RealRegSingle regNo
                        | regNo < 32    -> 0
                        | otherwise     -> 1

                RealRegPair{}           -> 1

        _other -> 0

-- | All the allocatable registers in the machine,
--      including register pairs.
allRealRegs :: [RealReg]
allRealRegs
        =  [ (RealRegSingle i)          | i <- [0..63] ]
        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]

-- | Get the regno for this sort of reg
gReg, lReg, iReg, oReg, fReg :: Int -> RegNo

gReg x  = x             -- global regs
oReg x  = (8 + x)       -- output regs
lReg x  = (16 + x)      -- local regs
iReg x  = (24 + x)      -- input regs
fReg x  = (32 + x)      -- float regs

-- | Some specific regs used by the code generator.
g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg

f6  = RegReal (RealRegSingle (fReg 6))
f8  = RegReal (RealRegSingle (fReg 8))
f22 = RegReal (RealRegSingle (fReg 22))
f26 = RegReal (RealRegSingle (fReg 26))
f27 = RegReal (RealRegSingle (fReg 27))

-- g0 is always zero, and writes to it vanish.
g0  = RegReal (RealRegSingle (gReg 0))
g1  = RegReal (RealRegSingle (gReg 1))
g2  = RegReal (RealRegSingle (gReg 2))

-- FP, SP, int and float return (from C) regs.
fp  = RegReal (RealRegSingle (iReg 6))
sp  = RegReal (RealRegSingle (oReg 6))
o0  = RegReal (RealRegSingle (oReg 0))
o1  = RegReal (RealRegSingle (oReg 1))
f0  = RegReal (RealRegSingle (fReg 0))
f1  = RegReal (RealRegSingle (fReg 1))

-- | Produce the second-half-of-a-double register given the first half.
{-
fPair :: Reg -> Maybe Reg
fPair (RealReg n)
        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))

fPair (VirtualRegD u)
        = Just (VirtualRegHi u)

fPair reg
        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)
                Nothing
-}

-- | All the regs that the register allocator can allocate to,
--      with the fixed use regs removed.
--
allocatableRegs :: [RealReg]
allocatableRegs
   = let isFree rr
           = case rr of
                RealRegSingle r     -> freeReg r
                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2
     in filter isFree allRealRegs

-- | The registers to place arguments for function calls,
--      for some number of arguments.
--
argRegs :: RegNo -> [Reg]
argRegs r
 = case r of
        0       -> []
        1       -> map (RegReal . RealRegSingle . oReg) [0]
        2       -> map (RegReal . RealRegSingle . oReg) [0,1]
        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]
        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]
        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]
        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]
        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"

-- | All all the regs that could possibly be returned by argRegs
--
allArgRegs :: [Reg]
allArgRegs
        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]

-- These are the regs that we cannot assume stay alive over a C call.
--      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02
--
callClobberedRegs :: [Reg]
callClobberedRegs
        = map (RegReal . RealRegSingle)
                (  oReg 7 :
                  [oReg i | i <- [0..5]] ++
                  [gReg i | i <- [1..7]] ++
                  [fReg i | i <- [0..31]] )

-- | Make a virtual reg with this format.
mkVirtualReg :: Unique -> Format -> VirtualReg
mkVirtualReg u format
        | not (isFloatFormat format)
        = VirtualRegI u

        | otherwise
        = case format of
                FF32    -> VirtualRegF u
                FF64    -> VirtualRegD u
                _       -> panic "mkVReg"

regDotColor :: RealReg -> SDoc
regDotColor reg
 = case classOfRealReg reg of
        RcInteger       -> text "blue"
        RcFloat         -> text "red"
        _other          -> text "green"


module SPARC.ShortcutJump (
        JumpDest(..), getJumpDestBlockId,
        canShortcut,
        shortcutJump,
        shortcutStatics,
        shortBlockId
)

where

import GhcPrelude

import SPARC.Instr
import SPARC.Imm

import CLabel
import BlockId
import Cmm

import Panic
import Outputable

data JumpDest
        = DestBlockId BlockId
        | DestImm Imm

-- Debug Instance
instance Outputable JumpDest where
  ppr (DestBlockId bid) = text "blk:" <> ppr bid
  ppr (DestImm _bid)    = text "imm:?"

getJumpDestBlockId :: JumpDest -> Maybe BlockId
getJumpDestBlockId (DestBlockId bid) = Just bid
getJumpDestBlockId _                 = Nothing

canShortcut :: Instr -> Maybe JumpDest
canShortcut _ = Nothing

shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump _ other = other

shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
shortcutStatics fn (Statics lbl statics)
  = Statics lbl $ map (shortcutStatic fn) statics
  -- we need to get the jump tables, so apply the mapping to the entries
  -- of a CmmData too.

shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
shortcutLabel fn lab
  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
  | otherwise                              = lab

shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
shortcutStatic _ other_static
        = other_static

shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel
shortBlockId fn blockid =
   case fn blockid of
      Nothing -> blockLbl blockid
      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
      Just (DestImm (ImmCLbl lbl)) -> lbl
      _other -> panic "shortBlockId"


module SPARC.Stack (
        spRel,
        fpRel,
        spillSlotToOffset,
        maxSpillSlots
)

where

import GhcPrelude

import SPARC.AddrMode
import SPARC.Regs
import SPARC.Base
import SPARC.Imm

import DynFlags
import Outputable

-- | Get an AddrMode relative to the address in sp.
--      This gives us a stack relative addressing mode for volatile
--      temporaries and for excess call arguments.
--
spRel :: Int            -- ^ stack offset in words, positive or negative
      -> AddrMode

spRel n = AddrRegImm sp (ImmInt (n * wordLength))

-- | Get an address relative to the frame pointer.
--      This doesn't work work for offsets greater than 13 bits; we just hope for the best
--
fpRel :: Int -> AddrMode
fpRel n
        = AddrRegImm fp (ImmInt (n * wordLength))

-- | Convert a spill slot number to a *byte* offset, with no sign.
--
spillSlotToOffset :: DynFlags -> Int -> Int
spillSlotToOffset dflags slot
        | slot >= 0 && slot < maxSpillSlots dflags
        = 64 + spillSlotSize * slot

        | otherwise
        = pprPanic "spillSlotToOffset:"
                      (   text "invalid spill location: " <> int slot
                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))

-- | The maximum number of spill slots available on the C stack.
--      If we use up all of the slots, then we're screwed.
--
--      Why do we reserve 64 bytes, instead of using the whole thing??
--              -- BL 2009/02/15
--
maxSpillSlots :: DynFlags -> Int
maxSpillSlots dflags
        = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1


module SPARC.CodeGen.Amode (
        getAmode
)

where

import GhcPrelude

import {-# SOURCE #-} SPARC.CodeGen.Gen32
import SPARC.CodeGen.Base
import SPARC.AddrMode
import SPARC.Imm
import SPARC.Instr
import SPARC.Regs
import SPARC.Base
import NCGMonad
import Format

import Cmm

import OrdList

-- | Generate code to reference a memory address.
getAmode
        :: CmmExpr      -- ^ expr producing an address
        -> NatM Amode

getAmode tree@(CmmRegOff _ _)
    = do dflags <- getDynFlags
         getAmode (mangleIndexTree dflags tree)

getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])
  | fits13Bits (-i)
  = do
       (reg, code) <- getSomeReg x
       let
         off  = ImmInt (-(fromInteger i))
       return (Amode (AddrRegImm reg off) code)

getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])
  | fits13Bits i
  = do
       (reg, code) <- getSomeReg x
       let
         off  = ImmInt (fromInteger i)
       return (Amode (AddrRegImm reg off) code)

getAmode (CmmMachOp (MO_Add _) [x, y])
  = do
    (regX, codeX) <- getSomeReg x
    (regY, codeY) <- getSomeReg y
    let
        code = codeX `appOL` codeY
    return (Amode (AddrRegReg regX regY) code)

getAmode (CmmLit lit)
  = do
        let imm__2      = litToImm lit
        tmp1    <- getNewRegNat II32
        tmp2    <- getNewRegNat II32

        let code = toOL [ SETHI (HI imm__2) tmp1
                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]

        return (Amode (AddrRegReg tmp2 g0) code)

getAmode other
  = do
       (reg, code) <- getSomeReg other
       let
            off  = ImmInt 0
       return (Amode (AddrRegImm reg off) code)


module SPARC.CodeGen.Base (
        InstrBlock,
        CondCode(..),
        ChildCode64(..),
        Amode(..),

        Register(..),
        setFormatOfRegister,

        getRegisterReg,
        mangleIndexTree
)

where

import GhcPrelude

import SPARC.Instr
import SPARC.Cond
import SPARC.AddrMode
import SPARC.Regs
import Format
import Reg

import CodeGen.Platform
import DynFlags
import Cmm
import PprCmmExpr ()
import Platform

import Outputable
import OrdList

--------------------------------------------------------------------------------
-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
--      They are really trees of insns to facilitate fast appending, where a
--      left-to-right traversal yields the insns in the correct order.
--
type InstrBlock
        = OrdList Instr

-- | Condition codes passed up the tree.
--
data CondCode
        = CondCode Bool Cond InstrBlock

-- | a.k.a "Register64"
--      Reg is the lower 32-bit temporary which contains the result.
--      Use getHiVRegFromLo to find the other VRegUnique.
--
--      Rules of this simplified insn selection game are therefore that
--      the returned Reg may be modified
--
data ChildCode64
   = ChildCode64
        InstrBlock
        Reg

-- | Holds code that references a memory address.
data Amode
        = Amode
                -- the AddrMode we can use in the instruction
                --      that does the real load\/store.
                AddrMode

                -- other setup code we have to run first before we can use the
                --      above AddrMode.
                InstrBlock

--------------------------------------------------------------------------------
-- | Code to produce a result into a register.
--      If the result must go in a specific register, it comes out as Fixed.
--      Otherwise, the parent can decide which register to put it in.
--
data Register
        = Fixed Format Reg InstrBlock
        | Any   Format (Reg -> InstrBlock)

-- | Change the format field in a Register.
setFormatOfRegister
        :: Register -> Format -> Register

setFormatOfRegister reg format
 = case reg of
        Fixed _ reg code        -> Fixed format reg code
        Any _ codefn            -> Any   format codefn

--------------------------------------------------------------------------------
-- | Grab the Reg for a CmmReg
getRegisterReg :: Platform -> CmmReg -> Reg

getRegisterReg _ (CmmLocal (LocalReg u pk))
        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)

getRegisterReg platform (CmmGlobal mid)
  = case globalRegMaybe platform mid of
        Just reg -> RegReal reg
        Nothing  -> pprPanic
                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"
                        (ppr $ CmmGlobal mid)

-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr

mangleIndexTree dflags (CmmRegOff reg off)
        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
        where width = typeWidth (cmmRegType dflags reg)

mangleIndexTree _ _
        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"


module SPARC.CodeGen.CondCode (
        getCondCode,
        condIntCode,
        condFltCode
)

where

import GhcPrelude

import {-# SOURCE #-} SPARC.CodeGen.Gen32
import SPARC.CodeGen.Base
import SPARC.Instr
import SPARC.Regs
import SPARC.Cond
import SPARC.Imm
import SPARC.Base
import NCGMonad
import Format

import Cmm

import OrdList
import Outputable

getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp mop [x, y])
  =
    case mop of
      MO_F_Eq W32 -> condFltCode EQQ x y
      MO_F_Ne W32 -> condFltCode NE  x y
      MO_F_Gt W32 -> condFltCode GTT x y
      MO_F_Ge W32 -> condFltCode GE  x y
      MO_F_Lt W32 -> condFltCode LTT x y
      MO_F_Le W32 -> condFltCode LE  x y

      MO_F_Eq W64 -> condFltCode EQQ x y
      MO_F_Ne W64 -> condFltCode NE  x y
      MO_F_Gt W64 -> condFltCode GTT x y
      MO_F_Ge W64 -> condFltCode GE  x y
      MO_F_Lt W64 -> condFltCode LTT x y
      MO_F_Le W64 -> condFltCode LE  x y

      MO_Eq   _   -> condIntCode EQQ  x y
      MO_Ne   _   -> condIntCode NE   x y

      MO_S_Gt _   -> condIntCode GTT  x y
      MO_S_Ge _   -> condIntCode GE   x y
      MO_S_Lt _   -> condIntCode LTT  x y
      MO_S_Le _   -> condIntCode LE   x y

      MO_U_Gt _   -> condIntCode GU   x y
      MO_U_Ge _   -> condIntCode GEU  x y
      MO_U_Lt _   -> condIntCode LU   x y
      MO_U_Le _   -> condIntCode LEU  x y

      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))

getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)

-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-- passed back up the tree.

condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode cond x (CmmLit (CmmInt y _))
  | fits13Bits y
  = do
       (src1, code) <- getSomeReg x
       let
           src2 = ImmInt (fromInteger y)
           code' = code `snocOL` SUB False True src1 (RIImm src2) g0
       return (CondCode False cond code')

condIntCode cond x y = do
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    let
        code__2 = code1 `appOL` code2 `snocOL`
                  SUB False True src1 (RIReg src2) g0
    return (CondCode False cond code__2)

condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode cond x y = do
    dflags <- getDynFlags
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    tmp <- getNewRegNat FF64
    let
        promote x = FxTOy FF32 FF64 x tmp

        pk1   = cmmExprType dflags x
        pk2   = cmmExprType dflags y

        code__2 =
                if pk1 `cmmEqType` pk2 then
                    code1 `appOL` code2 `snocOL`
                    FCMP True (cmmTypeFormat pk1) src1 src2
                else if typeWidth pk1 == W32 then
                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
                    FCMP True FF64 tmp src2
                else
                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
                    FCMP True FF64 src1 tmp
    return (CondCode True cond code__2)


-- | Expand out synthetic instructions into single machine instrs.
module SPARC.CodeGen.Expand (
        expandTop
)

where

import GhcPrelude

import SPARC.Instr
import SPARC.Imm
import SPARC.AddrMode
import SPARC.Regs
import SPARC.Ppr        ()
import Instruction
import Reg
import Format
import Cmm

import Outputable
import OrdList

-- | Expand out synthetic instructions in this top level thing
expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr
expandTop top@(CmmData{})
        = top

expandTop (CmmProc info lbl live (ListGraph blocks))
        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)

-- | Expand out synthetic instructions in this block
expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr

expandBlock (BasicBlock label instrs)
 = let  instrs_ol       = expandBlockInstrs instrs
        instrs'         = fromOL instrs_ol
   in   BasicBlock label instrs'

-- | Expand out some instructions
expandBlockInstrs :: [Instr] -> OrdList Instr
expandBlockInstrs []    = nilOL

expandBlockInstrs (ii:is)
 = let  ii_doubleRegs   = remapRegPair ii
        is_misaligned   = expandMisalignedDoubles ii_doubleRegs

   in   is_misaligned `appOL` expandBlockInstrs is

-- | In the SPARC instruction set the FP register pairs that are used
--      to hold 64 bit floats are refered to by just the first reg
--      of the pair. Remap our internal reg pairs to the appropriate reg.
--
--      For example:
--          ldd [%l1], (%f0 | %f1)
--
--      gets mapped to
--          ldd [$l1], %f0
--
remapRegPair :: Instr -> Instr
remapRegPair instr
 = let  patchF reg
         = case reg of
                RegReal (RealRegSingle _)
                        -> reg

                RegReal (RealRegPair r1 r2)

                        -- sanity checking
                        | r1         >= 32
                        , r1         <= 63
                        , r1 `mod` 2 == 0
                        , r2         == r1 + 1
                        -> RegReal (RealRegSingle r1)

                        | otherwise
                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)

                RegVirtual _
                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)

   in   patchRegsOfInstr instr patchF

-- Expand out 64 bit load/stores into individual instructions to handle
--      possible double alignment problems.
--
--      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.
--              We might be able to do this faster if we use the UA2007 instr set
--              instead of restricting ourselves to SPARC V9.
--
expandMisalignedDoubles :: Instr -> OrdList Instr
expandMisalignedDoubles instr

        -- Translate to:
        --    add g1,g2,g1
        --    ld  [g1],%fn
        --    ld  [g1+4],%f(n+1)
        --    sub g1,g2,g1           -- to restore g1
        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr
        =       toOL    [ ADD False False r1 (RIReg r2) r1
                        , LD  FF32  (AddrRegReg r1 g0)          fReg
                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)
                        , SUB False False r1 (RIReg r2) r1 ]

        -- Translate to
        --    ld  [addr],%fn
        --    ld  [addr+4],%f(n+1)
        | LD FF64 addr fReg                     <- instr
        = let   Just addr'      = addrOffset addr 4
          in    toOL    [ LD  FF32  addr        fReg
                        , LD  FF32  addr'       (fRegHi fReg) ]

        -- Translate to:
        --    add g1,g2,g1
        --    st  %fn,[g1]
        --    st  %f(n+1),[g1+4]
        --    sub g1,g2,g1           -- to restore g1
        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr
        =       toOL    [ ADD False False r1 (RIReg r2) r1
                        , ST  FF32  fReg           (AddrRegReg r1 g0)
                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))
                        , SUB False False r1 (RIReg r2) r1 ]

        -- Translate to
        --    ld  [addr],%fn
        --    ld  [addr+4],%f(n+1)
        | ST FF64 fReg addr                     <- instr
        = let   Just addr'      = addrOffset addr 4
          in    toOL    [ ST  FF32  fReg           addr
                        , ST  FF32  (fRegHi fReg)  addr'         ]

        -- some other instr
        | otherwise
        = unitOL instr

-- | The high partner for this float reg.
fRegHi :: Reg -> Reg
fRegHi (RegReal (RealRegSingle r1))
        | r1            >= 32
        , r1            <= 63
        , r1 `mod` 2 == 0
        = (RegReal $ RealRegSingle (r1 + 1))

-- Can't take high partner for non-low reg.
fRegHi reg
        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)


-- | Evaluation of 32 bit values.
module SPARC.CodeGen.Gen32 (
        getSomeReg,
        getRegister
)

where

import GhcPrelude

import SPARC.CodeGen.CondCode
import SPARC.CodeGen.Amode
import SPARC.CodeGen.Gen64
import SPARC.CodeGen.Base
import SPARC.Stack
import SPARC.Instr
import SPARC.Cond
import SPARC.AddrMode
import SPARC.Imm
import SPARC.Regs
import SPARC.Base
import NCGMonad
import Format
import Reg

import Cmm

import Control.Monad (liftM)
import DynFlags
import OrdList
import Outputable

-- | The dual to getAnyReg: compute an expression into a register, but
--      we don't mind which one it is.
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg expr = do
  r <- getRegister expr
  case r of
    Any rep code -> do
        tmp <- getNewRegNat rep
        return (tmp, code tmp)
    Fixed _ reg code ->
        return (reg, code)

-- | Make code to evaluate a 32 bit expression.
--
getRegister :: CmmExpr -> NatM Register

getRegister (CmmReg reg)
  = do dflags <- getDynFlags
       let platform = targetPlatform dflags
       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
                     (getRegisterReg platform reg) nilOL)

getRegister tree@(CmmRegOff _ _)
  = do dflags <- getDynFlags
       getRegister (mangleIndexTree dflags tree)

getRegister (CmmMachOp (MO_UU_Conv W64 W32)
             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

getRegister (CmmMachOp (MO_SS_Conv W64 W32)
             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 rlo code

getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
  ChildCode64 code rlo <- iselExpr64 x
  return $ Fixed II32 rlo code

-- Load a literal float into a float register.
--      The actual literal is stored in a new data area, and we load it
--      at runtime.
getRegister (CmmLit (CmmFloat f W32)) = do

    -- a label for the new data area
    lbl <- getNewLabelNat
    tmp <- getNewRegNat II32

    let code dst = toOL [
            -- the data area
            LDATA (Section ReadOnlyData lbl) $ Statics lbl
                         [CmmStaticLit (CmmFloat f W32)],

            -- load the literal
            SETHI (HI (ImmCLbl lbl)) tmp,
            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]

    return (Any FF32 code)

getRegister (CmmLit (CmmFloat d W64)) = do
    lbl <- getNewLabelNat
    tmp <- getNewRegNat II32
    let code dst = toOL [
            LDATA (Section ReadOnlyData lbl) $ Statics lbl
                         [CmmStaticLit (CmmFloat d W64)],
            SETHI (HI (ImmCLbl lbl)) tmp,
            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
    return (Any FF64 code)

-- Unary machine ops
getRegister (CmmMachOp mop [x])
  = case mop of
        -- Floating point negation -------------------------
        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x
        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x

        -- Integer negation --------------------------------
        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x
        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x

        -- Float word size conversion ----------------------
        MO_FF_Conv W64 W32      -> coerceDbl2Flt x
        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x

        -- Float <-> Signed Int conversion -----------------
        MO_FS_Conv from to      -> coerceFP2Int from to x
        MO_SF_Conv from to      -> coerceInt2FP from to x

        -- Unsigned integer word size conversions ----------

        -- If it's the same size, then nothing needs to be done.
        MO_UU_Conv from to
         | from == to           -> conversionNop (intFormat to)  x

        -- To narrow an unsigned word, mask out the high bits to simulate what would
        --      happen if we copied the value into a smaller register.
        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))

        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8
        --      case because the only way we can load it is via SETHI, which needs 2 ops.
        --      Do some shifts to chop out the high bits instead.
        MO_UU_Conv W32 W16
         -> do  tmpReg          <- getNewRegNat II32
                (xReg, xCode)   <- getSomeReg x
                let code dst
                        =       xCode
                        `appOL` toOL
                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg
                                , SRL tmpReg (RIImm $ ImmInt 16) dst]

                return  $ Any II32 code

                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))

        -- To widen an unsigned word we don't have to do anything.
        --      Just leave it in the same register and mark the result as the new size.
        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x
        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x
        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x

        -- Signed integer word size conversions ------------

        -- Mask out high bits when narrowing them
        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))

        -- Sign extend signed words when widening them.
        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x
        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x
        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x

        _                       -> panic ("Unknown unary mach op: " ++ show mop)

-- Binary machine ops
getRegister (CmmMachOp mop [x, y])
  = case mop of
      MO_Eq _           -> condIntReg EQQ x y
      MO_Ne _           -> condIntReg NE x y

      MO_S_Gt _         -> condIntReg GTT x y
      MO_S_Ge _         -> condIntReg GE x y
      MO_S_Lt _         -> condIntReg LTT x y
      MO_S_Le _         -> condIntReg LE x y

      MO_U_Gt W32       -> condIntReg GU  x y
      MO_U_Ge W32       -> condIntReg GEU x y
      MO_U_Lt W32       -> condIntReg LU  x y
      MO_U_Le W32       -> condIntReg LEU x y

      MO_U_Gt W16       -> condIntReg GU  x y
      MO_U_Ge W16       -> condIntReg GEU x y
      MO_U_Lt W16       -> condIntReg LU  x y
      MO_U_Le W16       -> condIntReg LEU x y

      MO_Add W32        -> trivialCode W32 (ADD False False) x y
      MO_Sub W32        -> trivialCode W32 (SUB False False) x y

      MO_S_MulMayOflo rep -> imulMayOflo rep x y

      MO_S_Quot W32     -> idiv True  False x y
      MO_U_Quot W32     -> idiv False False x y

      MO_S_Rem  W32     -> irem True  x y
      MO_U_Rem  W32     -> irem False x y

      MO_F_Eq _         -> condFltReg EQQ x y
      MO_F_Ne _         -> condFltReg NE x y

      MO_F_Gt _         -> condFltReg GTT x y
      MO_F_Ge _         -> condFltReg GE x y
      MO_F_Lt _         -> condFltReg LTT x y
      MO_F_Le _         -> condFltReg LE x y

      MO_F_Add  w       -> trivialFCode w FADD x y
      MO_F_Sub  w       -> trivialFCode w FSUB x y
      MO_F_Mul  w       -> trivialFCode w FMUL x y
      MO_F_Quot w       -> trivialFCode w FDIV x y

      MO_And rep        -> trivialCode rep (AND False) x y
      MO_Or  rep        -> trivialCode rep (OR  False) x y
      MO_Xor rep        -> trivialCode rep (XOR False) x y

      MO_Mul rep        -> trivialCode rep (SMUL False) x y

      MO_Shl rep        -> trivialCode rep SLL  x y
      MO_U_Shr rep      -> trivialCode rep SRL x y
      MO_S_Shr rep      -> trivialCode rep SRA x y

      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)

getRegister (CmmLoad mem pk) = do
    Amode src code <- getAmode mem
    let
        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst
    return (Any (cmmTypeFormat pk) code__2)

getRegister (CmmLit (CmmInt i _))
  | fits13Bits i
  = let
        src = ImmInt (fromInteger i)
        code dst = unitOL (OR False g0 (RIImm src) dst)
    in
        return (Any II32 code)

getRegister (CmmLit lit)
  = let imm = litToImm lit
        code dst = toOL [
            SETHI (HI imm) dst,
            OR False dst (RIImm (LO imm)) dst]
    in return (Any II32 code)

getRegister _
        = panic "SPARC.CodeGen.Gen32.getRegister: no match"

-- | sign extend and widen
integerExtend
        :: Width                -- ^ width of source expression
        -> Width                -- ^ width of result
        -> CmmExpr              -- ^ source expression
        -> NatM Register

integerExtend from to expr
 = do   -- load the expr into some register
        (reg, e_code)   <- getSomeReg expr
        tmp             <- getNewRegNat II32
        let bitCount
                = case (from, to) of
                        (W8,  W32)      -> 24
                        (W16, W32)      -> 16
                        (W8,  W16)      -> 24
                        _               -> panic "SPARC.CodeGen.Gen32: no match"
        let code dst
                = e_code

                -- local shift word left to load the sign bit
                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp

                -- arithmetic shift right to sign extend
                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst

        return (Any (intFormat to) code)

-- | For nop word format conversions we set the resulting value to have the
--      required size, but don't need to generate any actual code.
--
conversionNop
        :: Format -> CmmExpr -> NatM Register

conversionNop new_rep expr
 = do   e_code <- getRegister expr
        return (setFormatOfRegister e_code new_rep)

-- | Generate an integer division instruction.
idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register

-- For unsigned division with a 32 bit numerator,
--              we can just clear the Y register.
idiv False cc x y
 = do
        (a_reg, a_code)         <- getSomeReg x
        (b_reg, b_code)         <- getSomeReg y

        let code dst
                =       a_code
                `appOL` b_code
                `appOL` toOL
                        [ WRY  g0 g0
                        , UDIV cc a_reg (RIReg b_reg) dst]

        return (Any II32 code)

-- For _signed_ division with a 32 bit numerator,
--              we have to sign extend the numerator into the Y register.
idiv True cc x y
 = do
        (a_reg, a_code)         <- getSomeReg x
        (b_reg, b_code)         <- getSomeReg y

        tmp                     <- getNewRegNat II32

        let code dst
                =       a_code
                `appOL` b_code
                `appOL` toOL
                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
                        , SRA  tmp   (RIImm (ImmInt 16)) tmp

                        , WRY  tmp g0
                        , SDIV cc a_reg (RIReg b_reg) dst]

        return (Any II32 code)

-- | Do an integer remainder.
--
--       NOTE:  The SPARC v8 architecture manual says that integer division
--              instructions _may_ generate a remainder, depending on the implementation.
--              If so it is _recommended_ that the remainder is placed in the Y register.
--
--          The UltraSparc 2007 manual says Y is _undefined_ after division.
--
--              The SPARC T2 doesn't store the remainder, not sure about the others.
--              It's probably best not to worry about it, and just generate our own
--              remainders.
--
irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register

-- For unsigned operands:
--              Division is between a 64 bit numerator and a 32 bit denominator,
--              so we still have to clear the Y register.
irem False x y
 = do
        (a_reg, a_code) <- getSomeReg x
        (b_reg, b_code) <- getSomeReg y

        tmp_reg         <- getNewRegNat II32

        let code dst
                =       a_code
                `appOL` b_code
                `appOL` toOL
                        [ WRY   g0 g0
                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg
                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
                        , SUB   False False   a_reg (RIReg tmp_reg) dst]

        return  (Any II32 code)

-- For signed operands:
--              Make sure to sign extend into the Y register, or the remainder
--              will have the wrong sign when the numerator is negative.
--
--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
--              not the full 32. Not sure why this is, something to do with overflow?
--              If anyone cares enough about the speed of signed remainder they
--              can work it out themselves (then tell me). -- BL 2009/01/20
irem True x y
 = do
        (a_reg, a_code) <- getSomeReg x
        (b_reg, b_code) <- getSomeReg y

        tmp1_reg        <- getNewRegNat II32
        tmp2_reg        <- getNewRegNat II32

        let code dst
                =       a_code
                `appOL` b_code
                `appOL` toOL
                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
                        , WRY   tmp1_reg g0

                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg
                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]

        return (Any II32 code)

imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo rep a b
 = do
        (a_reg, a_code) <- getSomeReg a
        (b_reg, b_code) <- getSomeReg b
        res_lo <- getNewRegNat II32
        res_hi <- getNewRegNat II32

        let shift_amt  = case rep of
                          W32 -> 31
                          W64 -> 63
                          _ -> panic "shift_amt"

        let code dst = a_code `appOL` b_code `appOL`
                       toOL [
                           SMUL False a_reg (RIReg b_reg) res_lo,
                           RDY res_hi,
                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
                           SUB False False res_lo (RIReg res_hi) dst
                        ]
        return (Any II32 code)

-- -----------------------------------------------------------------------------
-- 'trivial*Code': deal with trivial instructions

-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
-- Only look for constants on the right hand side, because that's
-- where the generic optimizer will have put them.

-- Similarly, for unary instructions, we don't have to worry about
-- matching an StInt as the argument, because genericOpt will already
-- have handled the constant-folding.

trivialCode
        :: Width
        -> (Reg -> RI -> Reg -> Instr)
        -> CmmExpr
        -> CmmExpr
        -> NatM Register

trivialCode _ instr x (CmmLit (CmmInt y _))
  | fits13Bits y
  = do
      (src1, code) <- getSomeReg x
      let
        src2 = ImmInt (fromInteger y)
        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
      return (Any II32 code__2)

trivialCode _ instr x y = do
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    let
        code__2 dst = code1 `appOL` code2 `snocOL`
                      instr src1 (RIReg src2) dst
    return (Any II32 code__2)

trivialFCode
        :: Width
        -> (Format -> Reg -> Reg -> Reg -> Instr)
        -> CmmExpr
        -> CmmExpr
        -> NatM Register

trivialFCode pk instr x y = do
    dflags <- getDynFlags
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    tmp <- getNewRegNat FF64
    let
        promote x = FxTOy FF32 FF64 x tmp

        pk1   = cmmExprType dflags x
        pk2   = cmmExprType dflags y

        code__2 dst =
                if pk1 `cmmEqType` pk2 then
                    code1 `appOL` code2 `snocOL`
                    instr (floatFormat pk) src1 src2 dst
                else if typeWidth pk1 == W32 then
                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
                    instr FF64 tmp src2 dst
                else
                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
                    instr FF64 src1 tmp dst
    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)
                code__2)

trivialUCode
        :: Format
        -> (RI -> Reg -> Instr)
        -> CmmExpr
        -> NatM Register

trivialUCode format instr x = do
    (src, code) <- getSomeReg x
    let
        code__2 dst = code `snocOL` instr (RIReg src) dst
    return (Any format code__2)

trivialUFCode
        :: Format
        -> (Reg -> Reg -> Instr)
        -> CmmExpr
        -> NatM Register

trivialUFCode pk instr x = do
    (src, code) <- getSomeReg x
    let
        code__2 dst = code `snocOL` instr src dst
    return (Any pk code__2)

-- Coercions -------------------------------------------------------------------

-- | Coerce a integer value to floating point
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP width1 width2 x = do
    (src, code) <- getSomeReg x
    let
        code__2 dst = code `appOL` toOL [
            ST (intFormat width1) src (spRel (-2)),
            LD (intFormat width1) (spRel (-2)) dst,
            FxTOy (intFormat width1) (floatFormat width2) dst dst]
    return (Any (floatFormat $ width2) code__2)

-- | Coerce a floating point value to integer
--
--   NOTE: On sparc v9 there are no instructions to move a value from an
--         FP register directly to an int register, so we have to use a load/store.
--
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int width1 width2 x
 = do   let fformat1      = floatFormat width1
            fformat2      = floatFormat width2

            iformat2      = intFormat   width2

        (fsrc, code)    <- getSomeReg x
        fdst            <- getNewRegNat fformat2

        let code2 dst
                =       code
                `appOL` toOL
                        -- convert float to int format, leaving it in a float reg.
                        [ FxTOy fformat1 iformat2 fsrc fdst

                        -- store the int into mem, then load it back to move
                        --      it into an actual int reg.
                        , ST    fformat2 fdst (spRel (-2))
                        , LD    iformat2 (spRel (-2)) dst]

        return (Any iformat2 code2)

-- | Coerce a double precision floating point value to single precision.
coerceDbl2Flt :: CmmExpr -> NatM Register
coerceDbl2Flt x = do
    (src, code) <- getSomeReg x
    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))

-- | Coerce a single precision floating point value to double precision
coerceFlt2Dbl :: CmmExpr -> NatM Register
coerceFlt2Dbl x = do
    (src, code) <- getSomeReg x
    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))

-- Condition Codes -------------------------------------------------------------
--
-- Evaluate a comparison, and get the result into a register.
--
-- Do not fill the delay slots here. you will confuse the register allocator.
--
condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do
    (src, code) <- getSomeReg x
    let
        code__2 dst = code `appOL` toOL [
            SUB False True g0 (RIReg src) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
    return (Any II32 code__2)

condIntReg EQQ x y = do
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    let
        code__2 dst = code1 `appOL` code2 `appOL` toOL [
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
    return (Any II32 code__2)

condIntReg NE x (CmmLit (CmmInt 0 _)) = do
    (src, code) <- getSomeReg x
    let
        code__2 dst = code `appOL` toOL [
            SUB False True g0 (RIReg src) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
    return (Any II32 code__2)

condIntReg NE x y = do
    (src1, code1) <- getSomeReg x
    (src2, code2) <- getSomeReg y
    let
        code__2 dst = code1 `appOL` code2 `appOL` toOL [
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
    return (Any II32 code__2)

condIntReg cond x y = do
    bid1 <- liftM (\a -> seq a a) getBlockIdNat
    bid2 <- liftM (\a -> seq a a) getBlockIdNat
    CondCode _ cond cond_code <- condIntCode cond x y
    let
        code__2 dst
         =      cond_code
          `appOL` toOL
                [ BI cond False bid1
                , NOP

                , OR False g0 (RIImm (ImmInt 0)) dst
                , BI ALWAYS False bid2
                , NOP

                , NEWBLOCK bid1
                , OR False g0 (RIImm (ImmInt 1)) dst
                , BI ALWAYS False bid2
                , NOP

                , NEWBLOCK bid2]

    return (Any II32 code__2)

condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg cond x y = do
    bid1 <- liftM (\a -> seq a a) getBlockIdNat
    bid2 <- liftM (\a -> seq a a) getBlockIdNat

    CondCode _ cond cond_code <- condFltCode cond x y
    let
        code__2 dst
         =      cond_code
          `appOL` toOL
                [ NOP
                , BF cond False bid1
                , NOP

                , OR False g0 (RIImm (ImmInt 0)) dst
                , BI ALWAYS False bid2
                , NOP

                , NEWBLOCK bid1
                , OR False g0 (RIImm (ImmInt 1)) dst
                , BI ALWAYS False bid2
                , NOP

                , NEWBLOCK bid2 ]

    return (Any II32 code__2)


-- | Evaluation of 64 bit values on 32 bit platforms.
module SPARC.CodeGen.Gen64 (
        assignMem_I64Code,
        assignReg_I64Code,
        iselExpr64
)

where

import GhcPrelude

import {-# SOURCE #-} SPARC.CodeGen.Gen32
import SPARC.CodeGen.Base
import SPARC.CodeGen.Amode
import SPARC.Regs
import SPARC.AddrMode
import SPARC.Imm
import SPARC.Instr
import SPARC.Ppr()
import NCGMonad
import Instruction
import Format
import Reg

import Cmm

import DynFlags
import OrdList
import Outputable

-- | Code to assign a 64 bit value to memory.
assignMem_I64Code
        :: CmmExpr              -- ^ expr producing the destination address
        -> CmmExpr              -- ^ expr producing the source value.
        -> NatM InstrBlock

assignMem_I64Code addrTree valueTree
 = do
     ChildCode64 vcode rlo      <- iselExpr64 valueTree

     (src, acode) <- getSomeReg addrTree
     let
         rhi = getHiVRegFromLo rlo

         -- Big-endian store
         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))
         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))

         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo

{-     pprTrace "assignMem_I64Code"
        (vcat   [ text "addrTree:  " <+> ppr addrTree
                , text "valueTree: " <+> ppr valueTree
                , text "vcode:"
                , vcat $ map ppr $ fromOL vcode
                , text ""
                , text "acode:"
                , vcat $ map ppr $ fromOL acode ])
       $ -}
     return code

-- | Code to assign a 64 bit value to a register.
assignReg_I64Code
        :: CmmReg               -- ^ the destination register
        -> CmmExpr              -- ^ expr producing the source value
        -> NatM InstrBlock

assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree
 = do
     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
     let
         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)
         r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = mkMOV r_src_lo r_dst_lo
         mov_hi = mkMOV r_src_hi r_dst_hi
         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg

     return (vcode `snocOL` mov_hi `snocOL` mov_lo)

assignReg_I64Code _ _
   = panic "assignReg_I64Code(sparc): invalid lvalue"

-- | Get the value of an expression into a 64 bit register.

iselExpr64 :: CmmExpr -> NatM ChildCode64

-- Load a 64 bit word
iselExpr64 (CmmLoad addrTree ty)
 | isWord64 ty
 = do   Amode amode addr_code   <- getAmode addrTree
        let result

                | AddrRegReg r1 r2      <- amode
                = do    rlo     <- getNewRegNat II32
                        tmp     <- getNewRegNat II32
                        let rhi = getHiVRegFromLo rlo

                        return  $ ChildCode64
                                (        addr_code
                                `appOL`  toOL
                                         [ ADD False False r1 (RIReg r2) tmp
                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi
                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])
                                rlo

                | AddrRegImm r1 (ImmInt i) <- amode
                = do    rlo     <- getNewRegNat II32
                        let rhi = getHiVRegFromLo rlo

                        return  $ ChildCode64
                                (        addr_code
                                `appOL`  toOL
                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi
                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])
                                rlo

                | otherwise
                = panic "SPARC.CodeGen.Gen64: no match"

        result

-- Add a literal to a 64 bit integer
iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])
 = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
        let r1_hi       = getHiVRegFromLo r1_lo

        r_dst_lo        <- getNewRegNat II32
        let r_dst_hi    =  getHiVRegFromLo r_dst_lo

        let code =      code1
                `appOL` toOL
                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo
                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]

        return  $ ChildCode64 code r_dst_lo

-- Addition of II64
iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])
 = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
        let r1_hi       = getHiVRegFromLo r1_lo

        ChildCode64 code2 r2_lo <- iselExpr64 e2
        let r2_hi       = getHiVRegFromLo r2_lo

        r_dst_lo        <- getNewRegNat II32
        let r_dst_hi    = getHiVRegFromLo r_dst_lo

        let code =      code1
                `appOL` code2
                `appOL` toOL
                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo
                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]

        return  $ ChildCode64 code r_dst_lo

iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))
 | isWord64 ty
 = do
     r_dst_lo <-  getNewRegNat II32
     let r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_lo = RegVirtual $ mkVirtualReg uq II32
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = mkMOV r_src_lo r_dst_lo
         mov_hi = mkMOV r_src_hi r_dst_hi
         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
     return (
            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
         )

-- Convert something into II64
iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
 = do
        r_dst_lo        <- getNewRegNat II32
        let r_dst_hi    = getHiVRegFromLo r_dst_lo

        -- compute expr and load it into r_dst_lo
        (a_reg, a_code) <- getSomeReg expr

        dflags <- getDynFlags
        let platform = targetPlatform dflags
            code        = a_code
                `appOL` toOL
                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits
                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]

        return  $ ChildCode64 code r_dst_lo

-- only W32 supported for now
iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])
 = do
        r_dst_lo        <- getNewRegNat II32
        let r_dst_hi    = getHiVRegFromLo r_dst_lo

        -- compute expr and load it into r_dst_lo
        (a_reg, a_code) <- getSomeReg expr

        dflags          <- getDynFlags
        let platform    = targetPlatform dflags
            code        = a_code
                `appOL` toOL
                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi
                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]

        return  $ ChildCode64 code r_dst_lo

iselExpr64 expr
   = pprPanic "iselExpr64(sparc)" (ppr expr)


-- | One ounce of sanity checking is worth 10000000000000000 ounces
-- of staring blindly at assembly code trying to find the problem..
module SPARC.CodeGen.Sanity (
        checkBlock
)

where

import GhcPrelude

import SPARC.Instr
import SPARC.Ppr        ()
import Instruction

import Cmm

import Outputable

-- | Enforce intra-block invariants.
--
checkBlock :: CmmBlock
           -> NatBasicBlock Instr
           -> NatBasicBlock Instr

checkBlock cmm block@(BasicBlock _ instrs)
        | checkBlockInstrs instrs
        = block

        | otherwise
        = pprPanic
                ("SPARC.CodeGen: bad block\n")
                ( vcat  [ text " -- cmm -----------------\n"
                        , ppr cmm
                        , text " -- native code ---------\n"
                        , ppr block ])

checkBlockInstrs :: [Instr] -> Bool
checkBlockInstrs ii

        -- An unconditional jumps end the block.
        --      There must be an unconditional jump in the block, otherwise
        --      the register liveness determinator will get the liveness
        --      information wrong.
        --
        --      If the block ends with a cmm call that never returns
        --      then there can be unreachable instructions after the jump,
        --      but we don't mind here.
        --
        | instr : NOP : _       <- ii
        , isUnconditionalJump instr
        = True

        -- All jumps must have a NOP in their branch delay slot.
        --      The liveness determinator and register allocators aren't smart
        --      enough to handle branch delay slots.
        --
        | instr : NOP : is      <- ii
        , isJumpishInstr instr
        = checkBlockInstrs is

        -- keep checking
        | _:i2:is               <- ii
        = checkBlockInstrs (i2:is)

        -- this block is no good
        | otherwise
        = False