{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}

-----------------------------------------------------------------------------
--
-- The register allocator
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------

{-
The algorithm is roughly:

  1) Compute strongly connected components of the basic block list.

  2) Compute liveness (mapping from pseudo register to
     point(s) of death?).

  3) Walk instructions in each basic block.  We keep track of
        (a) Free real registers (a bitmap?)
        (b) Current assignment of temporaries to machine registers and/or
            spill slots (call this the "assignment").
        (c) Partial mapping from basic block ids to a virt-to-loc mapping.
            When we first encounter a branch to a basic block,
            we fill in its entry in this table with the current mapping.

     For each instruction:
        (a) For each temporary *read* by the instruction:
            If the temporary does not have a real register allocation:
                - Allocate a real register from the free list.  If
                  the list is empty:
                  - Find a temporary to spill.  Pick one that is
                    not used in this instruction (ToDo: not
                    used for a while...)
                  - generate a spill instruction
                - If the temporary was previously spilled,
                  generate an instruction to read the temp from its spill loc.
            (optimisation: if we can see that a real register is going to
            be used soon, then don't use it for allocation).

        (b) For each real register clobbered by this instruction:
            If a temporary resides in it,
                If the temporary is live after this instruction,
                    Move the temporary to another (non-clobbered & free) reg,
                    or spill it to memory.  Mark the temporary as residing
                    in both memory and a register if it was spilled (it might
                    need to be read by this instruction).

            (ToDo: this is wrong for jump instructions?)

            We do this after step (a), because if we start with
               movq v1, %rsi
            which is an instruction that clobbers %rsi, if v1 currently resides
            in %rsi we want to get
               movq %rsi, %freereg
               movq %rsi, %rsi     -- will disappear
            instead of
               movq %rsi, %freereg
               movq %freereg, %rsi

        (c) Update the current assignment

        (d) If the instruction is a branch:
              if the destination block already has a register assignment,
                Generate a new block with fixup code and redirect the
                jump to the new block.
              else,
                Update the block id->assignment mapping with the current
                assignment.

        (e) Delete all register assignments for temps which are read
            (only) and die here.  Update the free register list.

        (f) Mark all registers clobbered by this instruction as not free,
            and mark temporaries which have been spilled due to clobbering
            as in memory (step (a) marks then as in both mem & reg).

        (g) For each temporary *written* by this instruction:
            Allocate a real register as for (b), spilling something
            else if necessary.
                - except when updating the assignment, drop any memory
                  locations that the temporary was previously in, since
                  they will be no longer valid after this instruction.

        (h) Delete all register assignments for temps which are
            written and die here (there should rarely be any).  Update
            the free register list.

        (i) Rewrite the instruction with the new mapping.

        (j) For each spilled reg known to be now dead, re-add its stack slot
            to the free list.

-}

module RegAlloc.Linear.Main (
        regAlloc,
        module  RegAlloc.Linear.Base,
        module  RegAlloc.Linear.Stats
  ) where

#include "HsVersions.h"

import GhcPrelude

import RegAlloc.Linear.State
import RegAlloc.Linear.Base
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
import RegAlloc.Linear.JoinToTargets
import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
import qualified RegAlloc.Linear.X86.FreeRegs    as X86
import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
import TargetReg
import RegAlloc.Liveness
import Instruction
import Reg

import BlockId
import Hoopl.Collections
import Cmm hiding (RegSet)

import Digraph
import DynFlags
import Unique
import UniqSet
import UniqFM
import UniqSupply
import Outputable
import Platform

import Data.Maybe
import Data.List
import Control.Monad

-- -----------------------------------------------------------------------------
-- Top level of the register allocator

-- Allocate registers
regAlloc
        :: (Outputable instr, Instruction instr)
        => DynFlags
        -> LiveCmmDecl statics instr
        -> UniqSM ( NatCmmDecl statics instr
                  , Maybe Int  -- number of extra stack slots required,
                               -- beyond maxSpillSlots
                  , Maybe RegAllocStats
                  )

regAlloc _ (CmmData sec d)
        = return
                ( CmmData sec d
                , Nothing
                , Nothing )

regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
        = return ( CmmProc info lbl live (ListGraph [])
                 , Nothing
                 , Nothing )

regAlloc dflags (CmmProc static lbl live sccs)
        | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
        = do
                -- do register allocation on each component.
                (final_blocks, stats, stack_use)
                        <- linearRegAlloc dflags entry_ids block_live sccs

                -- make sure the block that was first in the input list
                --      stays at the front of the output
                let ((first':_), rest')
                                = partition ((== first_id) . blockId) final_blocks

                let max_spill_slots = maxSpillSlots dflags
                    extra_stack
                      | stack_use > max_spill_slots
                      = Just (stack_use - max_spill_slots)
                      | otherwise
                      = Nothing

                return  ( CmmProc info lbl live (ListGraph (first' : rest'))
                        , extra_stack
                        , Just stats)

-- bogus. to make non-exhaustive match warning go away.
regAlloc _ (CmmProc _ _ _ _)
        = panic "RegAllocLinear.regAlloc: no match"

-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers

-- | Do register allocation on some basic blocks.
--   But be careful to allocate a block in an SCC only if it has
--   an entry in the block map or it is the first block.
--
linearRegAlloc
        :: (Outputable instr, Instruction instr)
        => DynFlags
        -> [BlockId] -- ^ entry points
        -> BlockMap RegSet
              -- ^ live regs on entry to each basic block
        -> [SCC (LiveBasicBlock instr)]
              -- ^ instructions annotated with "deaths"
        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)

linearRegAlloc dflags entry_ids block_live sccs
 = case platformArch platform of
      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"
      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
      ArchARM64      -> panic "linearRegAlloc ArchARM64"
      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
 where
  go f = linearRegAlloc' dflags f entry_ids block_live sccs
  platform = targetPlatform dflags

linearRegAlloc'
        :: (FR freeRegs, Outputable instr, Instruction instr)
        => DynFlags
        -> freeRegs
        -> [BlockId]                    -- ^ entry points
        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)

linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
 = do   us      <- getUniqueSupplyM
        let (_, stack, stats, blocks) =
                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
                    $ linearRA_SCCs entry_ids block_live [] sccs
        return  (blocks, stats, getStackUse stack)

linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
              => [BlockId]
              -> BlockMap RegSet
              -> [NatBasicBlock instr]
              -> [SCC (LiveBasicBlock instr)]
              -> RegM freeRegs [NatBasicBlock instr]

linearRA_SCCs _ _ blocksAcc []
        = return $ reverse blocksAcc

linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
 = do   blocks' <- processBlock block_live block
        linearRA_SCCs entry_ids block_live
                ((reverse blocks') ++ blocksAcc)
                sccs

linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
 = do
        blockss' <- process entry_ids block_live blocks [] (return []) False
        linearRA_SCCs entry_ids block_live
                (reverse (concat blockss') ++ blocksAcc)
                sccs

{- from John Dias's patch 2008/10/16:
   The linear-scan allocator sometimes allocates a block
   before allocating one of its predecessors, which could lead to
   inconsistent allocations. Make it so a block is only allocated
   if a predecessor has set the "incoming" assignments for the block, or
   if it's the procedure's entry block.

   BL 2009/02: Careful. If the assignment for a block doesn't get set for
   some reason then this function will loop. We should probably do some
   more sanity checking to guard against this eventuality.
-}

process :: (FR freeRegs, Instruction instr, Outputable instr)
        => [BlockId]
        -> BlockMap RegSet
        -> [GenBasicBlock (LiveInstr instr)]
        -> [GenBasicBlock (LiveInstr instr)]
        -> [[NatBasicBlock instr]]
        -> Bool
        -> RegM freeRegs [[NatBasicBlock instr]]

process _ _ [] []         accum _
        = return $ reverse accum

process entry_ids block_live [] next_round accum madeProgress
        | not madeProgress

          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
                (  text "Unreachable blocks:"
                $$ vcat (map ppr next_round)) -}
        = return $ reverse accum

        | otherwise
        = process entry_ids block_live
                  next_round [] accum False

process entry_ids block_live (b@(BasicBlock id _) : blocks)
        next_round accum madeProgress
 = do
        block_assig <- getBlockAssigR

        if isJust (mapLookup id block_assig)
             || id `elem` entry_ids
         then do
                b'  <- processBlock block_live b
                process entry_ids block_live blocks
                        next_round (b' : accum) True

         else   process entry_ids block_live blocks
                        (b : next_round) accum madeProgress

-- | Do register allocation on this basic block
--
processBlock
        :: (FR freeRegs, Outputable instr, Instruction instr)
        => BlockMap RegSet              -- ^ live regs on entry to each basic block
        -> LiveBasicBlock instr         -- ^ block to do register allocation on
        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated

processBlock block_live (BasicBlock id instrs)
 = do   initBlock id block_live
        (instrs', fixups)
                <- linearRA block_live [] [] id instrs
        return  $ BasicBlock id instrs' : fixups

-- | Load the freeregs and current reg assignment into the RegM state
--      for the basic block with this BlockId.
initBlock :: FR freeRegs
          => BlockId -> BlockMap RegSet -> RegM freeRegs ()
initBlock id block_live
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags
        block_assig     <- getBlockAssigR
        case mapLookup id block_assig of
                -- no prior info about this block: we must consider
                -- any fixed regs to be allocated, but we can ignore
                -- virtual regs (presumably this is part of a loop,
                -- and we'll iterate again).  The assignment begins
                -- empty.
                Nothing
                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
                        case mapLookup id block_live of
                          Nothing ->
                            setFreeRegsR    (frInitFreeRegs platform)
                          Just live ->
                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
                            -- See Note [Unique Determinism and code generation]
                        setAssigR       emptyRegMap

                -- load info about register assignments leading into this block.
                Just (freeregs, assig)
                 -> do  setFreeRegsR    freeregs
                        setAssigR       assig

-- | Do allocation for a sequence of instructions.
linearRA
        :: (FR freeRegs, Outputable instr, Instruction instr)
        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
        -> [instr]                              -- ^ accumulator for instructions already processed.
        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
        -> BlockId                              -- ^ id of the current block, for debugging.
        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.

        -> RegM freeRegs
                ( [instr]                       --   instructions after register allocation
                , [NatBasicBlock instr])        --   fresh blocks of fixup code.

linearRA _          accInstr accFixup _ []
        = return
                ( reverse accInstr              -- instrs need to be returned in the correct order.
                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.

linearRA block_live accInstr accFixups id (instr:instrs)
 = do
        (accInstr', new_fixups) <- raInsn block_live accInstr id instr

        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs

-- | Do allocation for a single instruction.
raInsn
        :: (FR freeRegs, Outputable instr, Instruction instr)
        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
        -> [instr]                              -- ^ accumulator for instructions already processed.
        -> BlockId                              -- ^ the id of the current block, for debugging
        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
        -> RegM freeRegs
                ( [instr]                       -- new instructions
                , [NatBasicBlock instr])        -- extra fixup blocks

raInsn _     new_instrs _ (LiveInstr ii Nothing)
        | Just n        <- takeDeltaInstr ii
        = do    setDeltaR n
                return (new_instrs, [])

raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
        | isMetaInstr ii
        = return (i : new_instrs, [])

raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
 = do
    assig    <- getAssigR

    -- If we have a reg->reg move between virtual registers, where the
    -- src register is not live after this instruction, and the dst
    -- register does not already have an assignment,
    -- and the source register is assigned to a register, not to a spill slot,
    -- then we can eliminate the instruction.
    -- (we can't eliminate it if the source register is on the stack, because
    --  we do not want to use one spill slot for different virtual registers)
    case takeRegRegMoveInstr instr of
        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
                          isVirtualReg dst,
                          not (dst `elemUFM` assig),
                          isRealReg src || isInReg src assig -> do
           case src of
              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
                -- if src is a fixed reg, then we just map dest to this
                -- reg in the assignment.  src must be an allocatable reg,
                -- otherwise it wouldn't be in r_dying.
              _virt -> case lookupUFM assig src of
                         Nothing -> panic "raInsn"
                         Just loc ->
                           setAssigR (addToUFM (delFromUFM assig src) dst loc)

           -- we have eliminated this instruction
          {-
          freeregs <- getFreeRegsR
          assig <- getAssigR
          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
          -}
           return (new_instrs, [])

        _ -> genRaInsn block_live new_instrs id instr
                        (nonDetEltsUniqSet $ liveDieRead live)
                        (nonDetEltsUniqSet $ liveDieWrite live)
                        -- See Note [Unique Determinism and code generation]

raInsn _ _ _ instr
        = pprPanic "raInsn" (text "no match for:" <> ppr instr)

-- ToDo: what can we do about
--
--     R1 = x
--     jump I64[x] // [R1]
--
-- where x is mapped to the same reg as R1.  We want to coalesce x and
-- R1, but the register allocator doesn't know whether x will be
-- assigned to again later, in which case x and R1 should be in
-- different registers.  Right now we assume the worst, and the
-- assignment to R1 will clobber x, so we'll spill x into another reg,
-- generating another reg->reg move.

isInReg :: Reg -> RegMap Loc -> Bool
isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
                  | otherwise = False

genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
          => BlockMap RegSet
          -> [instr]
          -> BlockId
          -> instr
          -> [Reg]
          -> [Reg]
          -> RegM freeRegs ([instr], [NatBasicBlock instr])

genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
  dflags <- getDynFlags
  let platform = targetPlatform dflags
  case regUsageOfInstr platform instr of { RU read written ->
    do
    let real_written    = [ rr  | (RegReal     rr) <- written ]
    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]

    -- we don't need to do anything with real registers that are
    -- only read by this instr.  (the list is typically ~2 elements,
    -- so using nub isn't a problem).
    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]

    -- debugging
{-    freeregs <- getFreeRegsR
    assig    <- getAssigR
    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
        (ppr instr
                $$ text "r_dying      = " <+> ppr r_dying
                $$ text "w_dying      = " <+> ppr w_dying
                $$ text "virt_read    = " <+> ppr virt_read
                $$ text "virt_written = " <+> ppr virt_written
                $$ text "freeregs     = " <+> text (show freeregs)
                $$ text "assig        = " <+> ppr assig)
        $ do
-}

    -- (a), (b) allocate real regs for all regs read by this instruction.
    (r_spills, r_allocd) <-
        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read

    -- (c) save any temporaries which will be clobbered by this instruction
    clobber_saves <- saveClobberedTemps real_written r_dying

    -- (d) Update block map for new destinations
    -- NB. do this before removing dead regs from the assignment, because
    -- these dead regs might in fact be live in the jump targets (they're
    -- only dead in the code that follows in the current basic block).
    (fixup_blocks, adjusted_instr)
        <- joinToTargets block_live block_id instr

    -- Debugging - show places where the reg alloc inserted
    -- assignment fixup blocks.
    -- when (not $ null fixup_blocks) $
    --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())

    -- (e) Delete all register assignments for temps which are read
    --     (only) and die here.  Update the free register list.
    releaseRegs r_dying

    -- (f) Mark regs which are clobbered as unallocatable
    clobberRegs real_written

    -- (g) Allocate registers for temporaries *written* (only)
    (w_spills, w_allocd) <-
        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written

    -- (h) Release registers for temps which are written here and not
    -- used again.
    releaseRegs w_dying

    let
        -- (i) Patch the instruction
        patch_map
                = listToUFM
                        [ (t, RegReal r)
                                | (t, r) <- zip virt_read    r_allocd
                                         ++ zip virt_written w_allocd ]

        patched_instr
                = patchRegsOfInstr adjusted_instr patchLookup

        patchLookup x
                = case lookupUFM patch_map x of
                        Nothing -> x
                        Just y  -> y

    -- (j) free up stack slots for dead spilled regs
    -- TODO (can't be bothered right now)

    -- erase reg->reg moves where the source and destination are the same.
    --  If the src temp didn't die in this instr but happened to be allocated
    --  to the same real reg as the destination, then we can erase the move anyway.
    let squashed_instr  = case takeRegRegMoveInstr patched_instr of
                                Just (src, dst)
                                 | src == dst   -> []
                                _               -> [patched_instr]

    let code = squashed_instr ++ w_spills ++ reverse r_spills
                ++ clobber_saves ++ new_instrs

--    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
--    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do

    return (code, fixup_blocks)

  }

-- -----------------------------------------------------------------------------
-- releaseRegs

releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs regs = do
  dflags <- getDynFlags
  let platform = targetPlatform dflags
  assig <- getAssigR
  free <- getFreeRegsR
  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
      loop assig !free (r:rs) =
         case lookupUFM assig r of
         Just (InBoth real _) -> loop (delFromUFM assig r)
                                      (frReleaseReg platform real free) rs
         Just (InReg real)    -> loop (delFromUFM assig r)
                                      (frReleaseReg platform real free) rs
         _                    -> loop (delFromUFM assig r) free rs
  loop assig free regs

-- -----------------------------------------------------------------------------
-- Clobber real registers

-- For each temp in a register that is going to be clobbered:
--      - if the temp dies after this instruction, do nothing
--      - otherwise, put it somewhere safe (another reg if possible,
--              otherwise spill and record InBoth in the assignment).
--      - for allocateRegs on the temps *read*,
--      - clobbered regs are allocatable.
--
--      for allocateRegs on the temps *written*,
--        - clobbered regs are not allocatable.
--

saveClobberedTemps
        :: (Instruction instr, FR freeRegs)
        => [RealReg]            -- real registers clobbered by this instruction
        -> [Reg]                -- registers which are no longer live after this insn
        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
                                -- be clobbered.

saveClobberedTemps [] _
        = return []

saveClobberedTemps clobbered dying
 = do
        assig   <- getAssigR
        let to_spill
                = [ (temp,reg)
                        | (temp, InReg reg) <- nonDetUFMToList assig
                        -- This is non-deterministic but we do not
                        -- currently support deterministic code-generation.
                        -- See Note [Unique Determinism and code generation]
                        , any (realRegsAlias reg) clobbered
                        , temp `notElem` map getUnique dying  ]

        (instrs,assig') <- clobber assig [] to_spill
        setAssigR assig'
        return instrs

   where
     clobber assig instrs []
            = return (instrs, assig)

     clobber assig instrs ((temp, reg) : rest)
       = do dflags <- getDynFlags
            let platform = targetPlatform dflags

            freeRegs <- getFreeRegsR
            let regclass = targetClassOfRealReg platform reg
                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs

            case filter (`notElem` clobbered) freeRegs_thisClass of

              -- (1) we have a free reg of the right class that isn't
              -- clobbered by this instruction; use it to save the
              -- clobbered value.
              (my_reg : _) -> do
                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)

                  let new_assign = addToUFM assig temp (InReg my_reg)
                  let instr = mkRegRegMoveInstr platform
                                  (RegReal reg) (RegReal my_reg)

                  clobber new_assign (instr : instrs) rest

              -- (2) no free registers: spill the value
              [] -> do
                  (spill, slot)   <- spillR (RegReal reg) temp

                  -- record why this reg was spilled for profiling
                  recordSpill (SpillClobber temp)

                  let new_assign  = addToUFM assig temp (InBoth reg slot)

                  clobber new_assign (spill : instrs) rest

-- | Mark all these real regs as allocated,
--      and kick out their vreg assignments.
--
clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
clobberRegs []
        = return ()

clobberRegs clobbered
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags

        freeregs        <- getFreeRegsR
        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered

        assig           <- getAssigR
        setAssigR $! clobber assig (nonDetUFMToList assig)
          -- This is non-deterministic but we do not
          -- currently support deterministic code-generation.
          -- See Note [Unique Determinism and code generation]

   where
        -- if the temp was InReg and clobbered, then we will have
        -- saved it in saveClobberedTemps above.  So the only case
        -- we have to worry about here is InBoth.  Note that this
        -- also catches temps which were loaded up during allocation
        -- of read registers, not just those saved in saveClobberedTemps.

        clobber assig []
                = assig

        clobber assig ((temp, InBoth reg slot) : rest)
                | any (realRegsAlias reg) clobbered
                = clobber (addToUFM assig temp (InMem slot)) rest

        clobber assig (_:rest)
                = clobber assig rest

-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill

-- Why are we performing a spill?
data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
              | WriteNew           -- writing to a new variable
              | WriteMem           -- writing to register only in memory
-- Note that ReadNew is not valid, since you don't want to be reading
-- from an uninitialized register.  We also don't need the location of
-- the register in memory, since that will be invalidated by the write.
-- Technically, we could coalesce WriteNew and WriteMem into a single
-- entry as well. -- EZY

-- This function does several things:
--   For each temporary referred to by this instruction,
--   we allocate a real register (spilling another temporary if necessary).
--   We load the temporary up from memory if necessary.
--   We also update the register assignment in the process, and
--   the list of free registers and free stack slots.

allocateRegsAndSpill
        :: (FR freeRegs, Outputable instr, Instruction instr)
        => Bool                 -- True <=> reading (load up spilled regs)
        -> [VirtualReg]         -- don't push these out
        -> [instr]              -- spill insns
        -> [RealReg]            -- real registers allocated (accum.)
        -> [VirtualReg]         -- temps to allocate
        -> RegM freeRegs ( [instr] , [RealReg])

allocateRegsAndSpill _       _    spills alloc []
        = return (spills, reverse alloc)

allocateRegsAndSpill reading keep spills alloc (r:rs)
 = do   assig <- getAssigR
        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
        case lookupUFM assig r of
                -- case (1a): already in a register
                Just (InReg my_reg) ->
                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs

                -- case (1b): already in a register (and memory)
                -- NB1. if we're writing this register, update its assignment to be
                -- InReg, because the memory value is no longer valid.
                -- NB2. This is why we must process written registers here, even if they
                -- are also read by the same instruction.
                Just (InBoth my_reg _)
                 -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs

                -- Not already in a register, so we need to find a free one...
                Just (InMem slot) | reading   -> doSpill (ReadMem slot)
                                  | otherwise -> doSpill WriteMem
                Nothing | reading   ->
                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
                   -- NOTE: if the input to the NCG contains some
                   -- unreachable blocks with junk code, this panic
                   -- might be triggered.  Make sure you only feed
                   -- sensible code into the NCG.  In CmmPipeline we
                   -- call removeUnreachableBlocks at the end for this
                   -- reason.

                        | otherwise -> doSpill WriteNew

-- reading is redundant with reason, but we keep it around because it's
-- convenient and it maintains the recursive structure of the allocator. -- EZY
allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
                        => Bool
                        -> [VirtualReg]
                        -> [instr]
                        -> [RealReg]
                        -> VirtualReg
                        -> [VirtualReg]
                        -> UniqFM Loc
                        -> SpillLoc
                        -> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags
        freeRegs                <- getFreeRegsR
        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs

        case freeRegs_thisClass of

         -- case (2): we have a free register
         (my_reg : _) ->
           do   spills'   <- loadTemp r spill_loc my_reg spills

                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
                setFreeRegsR $  frAllocateReg platform my_reg freeRegs

                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs

          -- case (3): we need to push something out to free up a register
         [] ->
           do   let inRegOrBoth (InReg _) = True
                    inRegOrBoth (InBoth _ _) = True
                    inRegOrBoth _ = False
                let candidates' =
                      flip delListFromUFM keep $
                      filterUFM inRegOrBoth $
                      assig
                      -- This is non-deterministic but we do not
                      -- currently support deterministic code-generation.
                      -- See Note [Unique Determinism and code generation]
                let candidates = nonDetUFMToList candidates'

                -- the vregs we could kick out that are already in a slot
                let candidates_inBoth
                        = [ (temp, reg, mem)
                          | (temp, InBoth reg mem) <- candidates
                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]

                -- the vregs we could kick out that are only in a reg
                --      this would require writing the reg to a new slot before using it.
                let candidates_inReg
                        = [ (temp, reg)
                          | (temp, InReg reg) <- candidates
                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]

                let result

                        -- we have a temporary that is in both register and mem,
                        -- just free up its register for use.
                        | (temp, my_reg, slot) : _      <- candidates_inBoth
                        = do    spills' <- loadTemp r spill_loc my_reg spills
                                let assig1  = addToUFM assig temp (InMem slot)
                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg

                                setAssigR assig2
                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs

                        -- otherwise, we need to spill a temporary that currently
                        -- resides in a register.
                        | (temp_to_push_out, (my_reg :: RealReg)) : _
                                        <- candidates_inReg
                        = do
                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
                                let spill_store  = (if reading then id else reverse)
                                                        [ -- COMMENT (fsLit "spill alloc")
                                                           spill_insn ]

                                -- record that this temp was spilled
                                recordSpill (SpillAlloc temp_to_push_out)

                                -- update the register assignment
                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
                                setAssigR assig2

                                -- if need be, load up a spilled temp into the reg we've just freed up.
                                spills' <- loadTemp r spill_loc my_reg spills

                                allocateRegsAndSpill reading keep
                                        (spill_store ++ spills')
                                        (my_reg:alloc) rs

                        -- there wasn't anything to spill, so we're screwed.
                        | otherwise
                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
                        $ vcat
                                [ text "allocating vreg:  " <> text (show r)
                                , text "assignment:       " <> ppr assig
                                , text "freeRegs:         " <> text (show freeRegs)
                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]

                result

-- | Calculate a new location after a register has been loaded.
newLocation :: SpillLoc -> RealReg -> Loc
-- if the tmp was read from a slot, then now its in a reg as well
newLocation (ReadMem slot) my_reg = InBoth my_reg slot
-- writes will always result in only the register being available
newLocation _ my_reg = InReg my_reg

-- | Load up a spilled temporary if we need to (read from memory).
loadTemp
        :: (Instruction instr)
        => VirtualReg   -- the temp being loaded
        -> SpillLoc     -- the current location of this temp
        -> RealReg      -- the hreg to load the temp into
        -> [instr]
        -> RegM freeRegs [instr]

loadTemp vreg (ReadMem slot) hreg spills
 = do
        insn <- loadR (RegReal hreg) slot
        recordSpill (SpillLoad $ getUnique vreg)
        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills

loadTemp _ _ _ spills =
   return spills


-- | The assignment of virtual registers to stack slots

--      We have lots of stack slots. Memory-to-memory moves are a pain on most
--      architectures. Therefore, we avoid having to generate memory-to-memory moves
--      by simply giving every virtual register its own stack slot.

--      The StackMap stack map keeps track of virtual register - stack slot
--      associations and of which stack slots are still free. Once it has been
--      associated, a stack slot is never "freed" or removed from the StackMap again,
--      it remains associated until we are done with the current CmmProc.
--
module RegAlloc.Linear.StackMap (
        StackSlot,
        StackMap(..),
        emptyStackMap,
        getStackSlotFor,
        getStackUse
)

where

import GhcPrelude

import DynFlags
import UniqFM
import Unique

-- | Identifier for a stack slot.
type StackSlot = Int

data StackMap
        = StackMap
        { -- | The slots that are still available to be allocated.
          stackMapNextFreeSlot  :: !Int

          -- | Assignment of vregs to stack slots.
        , stackMapAssignment    :: UniqFM StackSlot }

-- | An empty stack map, with all slots available.
emptyStackMap :: DynFlags -> StackMap
emptyStackMap _ = StackMap 0 emptyUFM

-- | If this vreg unique already has a stack assignment then return the slot number,
--      otherwise allocate a new slot, and update the map.
--
getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)

getStackSlotFor fs@(StackMap _ reserved) reg
  | Just slot <- lookupUFM reserved reg  =  (fs, slot)

getStackSlotFor (StackMap freeSlot reserved) reg =
    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)

-- | Return the number of stack slots that were allocated
getStackUse :: StackMap -> Int
getStackUse (StackMap freeSlot _) = freeSlot


{-# LANGUAGE UnboxedTuples #-}

-- | State monad for the linear register allocator.

--      Here we keep all the state that the register allocator keeps track
--      of as it walks the instructions in a basic block.

module RegAlloc.Linear.State (
        RA_State(..),
        RegM,
        runR,

        spillR,
        loadR,

        getFreeRegsR,
        setFreeRegsR,

        getAssigR,
        setAssigR,

        getBlockAssigR,
        setBlockAssigR,

        setDeltaR,
        getDeltaR,

        getUniqueR,

        recordSpill,
        recordFixupBlock
)
where

import GhcPrelude

import RegAlloc.Linear.Stats
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.Base
import RegAlloc.Liveness
import Instruction
import Reg
import BlockId

import DynFlags
import Unique
import UniqSupply

import Control.Monad (liftM, ap)

-- | The register allocator monad type.
newtype RegM freeRegs a
        = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }

instance Functor (RegM freeRegs) where
      fmap = liftM

instance Applicative (RegM freeRegs) where
      pure a  =  RegM $ \s -> (# s, a #)
      (<*>) = ap

instance Monad (RegM freeRegs) where
  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }

instance HasDynFlags (RegM a) where
    getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)

-- | Run a computation in the RegM register allocator monad.
runR    :: DynFlags
        -> BlockAssignment freeRegs
        -> freeRegs
        -> RegMap Loc
        -> StackMap
        -> UniqSupply
        -> RegM freeRegs a
        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)

runR dflags block_assig freeregs assig stack us thing =
  case unReg thing
        (RA_State
                { ra_blockassig = block_assig
                , ra_freeregs   = freeregs
                , ra_assig      = assig
                , ra_delta      = 0{-???-}
                , ra_stack      = stack
                , ra_us         = us
                , ra_spills     = []
                , ra_DynFlags   = dflags
                , ra_fixups     = [] })
   of
        (# state'@RA_State
                { ra_blockassig = block_assig
                , ra_stack      = stack' }
                , returned_thing #)

         ->     (block_assig, stack', makeRAStats state', returned_thing)

-- | Make register allocator stats from its final state.
makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats state
        = RegAllocStats
        { ra_spillInstrs        = binSpillReasons (ra_spills state)
        , ra_fixupList          = ra_fixups state }

spillR :: Instruction instr
       => Reg -> Unique -> RegM freeRegs (instr, Int)

spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
  let dflags = ra_DynFlags s
      (stack',slot) = getStackSlotFor stack temp
      instr  = mkSpillInstr dflags reg delta slot
  in
  (# s{ra_stack=stack'}, (instr,slot) #)

loadR :: Instruction instr
      => Reg -> Int -> RegM freeRegs instr

loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
  let dflags = ra_DynFlags s
  in (# s, mkLoadInstr dflags reg delta slot #)

getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
  (# s, freeregs #)

setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
  (# s{ra_freeregs = regs}, () #)

getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
  (# s, assig #)

setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
  (# s{ra_assig=assig}, () #)

getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
  (# s, assig #)

setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
  (# s{ra_blockassig = assig}, () #)

setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
  (# s{ra_delta = n}, () #)

getDeltaR :: RegM freeRegs Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)

getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
  case takeUniqFromSupply (ra_us s) of
    (uniq, us) -> (# s{ra_us = us}, uniq #)

-- | Record that a spill instruction was inserted, for profiling.
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
    = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)

-- | Record a created fixup block
recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock from between to
    = RegM $ \s -> (# s { ra_fixups = (from,between,to) : ra_fixups s}, () #)


module RegAlloc.Linear.Stats (
        binSpillReasons,
        countRegRegMovesNat,
        pprStats
)

where

import GhcPrelude

import RegAlloc.Linear.Base
import RegAlloc.Liveness
import Instruction

import UniqFM
import Outputable

import State

-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
        :: [SpillReason] -> UniqFM [Int]

binSpillReasons reasons
        = addListToUFM_C
                (zipWith (+))
                emptyUFM
                (map (\reason -> case reason of
                        SpillAlloc r    -> (r, [1, 0, 0, 0, 0])
                        SpillClobber r  -> (r, [0, 1, 0, 0, 0])
                        SpillLoad r     -> (r, [0, 0, 1, 0, 0])
                        SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])
                        SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)

-- | Count reg-reg moves remaining in this code.
countRegRegMovesNat
        :: Instruction instr
        => NatCmmDecl statics instr -> Int

countRegRegMovesNat cmm
        = execState (mapGenBlockTopM countBlock cmm) 0
 where
        countBlock b@(BasicBlock _ instrs)
         = do   mapM_ countInstr instrs
                return  b

        countInstr instr
                | Just _        <- takeRegRegMoveInstr instr
                = do    modify (+ 1)
                        return instr

                | otherwise
                =       return instr

-- | Pretty print some RegAllocStats
pprStats
        :: Instruction instr
        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc

pprStats code statss
 = let  -- sum up all the instrs inserted by the spiller
        spills          = foldl' (plusUFM_C (zipWith (+)))
                                emptyUFM
                        $ map ra_spillInstrs statss

        spillTotals     = foldl' (zipWith (+))
                                [0, 0, 0, 0, 0]
                        $ nonDetEltsUFM spills
                        -- See Note [Unique Determinism and code generation]

        -- count how many reg-reg-moves remain in the code
        moves           = sum $ map countRegRegMovesNat code

        pprSpill (reg, spills)
                = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))

   in   (  text "-- spills-added-total"
        $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
        $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
        $$ text ""
        $$ text "-- spills-added"
        $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
        $$ (pprUFMWithKeys spills (vcat . map pprSpill))
        $$ text "")


-- | Free regs map for PowerPC
module RegAlloc.Linear.PPC.FreeRegs
where

import GhcPrelude

import PPC.Regs
import RegClass
import Reg

import Outputable
import Platform

import Data.Word
import Data.Bits

-- The PowerPC has 32 integer and 32 floating point registers.
-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
-- better.
-- Note that when getFreeRegs scans for free registers, it starts at register
-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
-- registers are callee-saves, while the lower regs are caller-saves, so it
-- makes sense to start at the high end.
-- Apart from that, the code does nothing PowerPC-specific, so feel free to
-- add your favourite platform to the #if (if you have 64 registers but only
-- 32-bit words).

data FreeRegs = FreeRegs !Word32 !Word32
              deriving( Show )  -- The Show is used in an ASSERT

noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0

releaseReg :: RealReg -> FreeRegs -> FreeRegs
releaseReg (RealRegSingle r) (FreeRegs g f)
    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))
    | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f

releaseReg _ _
        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"

initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)

getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
getFreeRegs cls (FreeRegs g f)
    | RcDouble <- cls = go f (0x80000000) 63
    | RcInteger <- cls = go g (0x80000000) 31
    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)
    where
        go _ 0 _ = []
        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
                 | otherwise    = go x (m `shiftR` 1) $! i-1

allocateReg :: RealReg -> FreeRegs -> FreeRegs
allocateReg (RealRegSingle r) (FreeRegs g f)
    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))
    | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f

allocateReg _ _
        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"


-- | Free regs map for SPARC
module RegAlloc.Linear.SPARC.FreeRegs
where

import GhcPrelude

import SPARC.Regs
import RegClass
import Reg

import CodeGen.Platform
import Outputable
import Platform

import Data.Word
import Data.Bits

--------------------------------------------------------------------------------
-- SPARC is like PPC, except for twinning of floating point regs.
--      When we allocate a double reg we must take an even numbered
--      float reg, as well as the one after it.

-- Holds bitmaps showing what registers are currently allocated.
--      The float and double reg bitmaps overlap, but we only alloc
--      float regs into the float map, and double regs into the double map.
--
--      Free regs have a bit set in the corresponding bitmap.
--
data FreeRegs
        = FreeRegs
                !Word32         -- int    reg bitmap    regs  0..31
                !Word32         -- float  reg bitmap    regs 32..63
                !Word32         -- double reg bitmap    regs 32..63

instance Show FreeRegs where
        show = showFreeRegs

-- | A reg map where no regs are free to be allocated.
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0 0

-- | The initial set of free regs.
initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
 =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs

-- | Get all the free registers of this class.
getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
getFreeRegs cls (FreeRegs g f d)
        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0
        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32
        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32
        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
        where
                go _    _      0    _
                        = []

                go step bitmap mask ix
                        | bitmap .&. mask /= 0
                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)

                        | otherwise
                        = go step bitmap (mask `shiftL` step) $! ix + step

-- | Grab a register.
allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
allocateReg platform
         reg@(RealRegSingle r)
             (FreeRegs g f d)

        -- can't allocate free regs
        | not $ freeReg platform r
        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)

        -- a general purpose reg
        | r <= 31
        = let   mask    = complement (bitMask r)
          in    FreeRegs
                        (g .&. mask)
                        f
                        d

        -- a float reg
        | r >= 32, r <= 63
        = let   mask    = complement (bitMask (r - 32))

                -- the mask of the double this FP reg aliases
                maskLow = if r `mod` 2 == 0
                                then complement (bitMask (r - 32))
                                else complement (bitMask (r - 32 - 1))
          in    FreeRegs
                        g
                        (f .&. mask)
                        (d .&. maskLow)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)

allocateReg _
         reg@(RealRegPair r1 r2)
             (FreeRegs g f d)

        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
        , r2 >= 32, r2 <= 63
        = let   mask1   = complement (bitMask (r1 - 32))
                mask2   = complement (bitMask (r2 - 32))
          in
                FreeRegs
                        g
                        ((f .&. mask1) .&. mask2)
                        (d .&. mask1)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)

-- | Release a register from allocation.
--      The register liveness information says that most regs die after a C call,
--      but we still don't want to allocate to some of them.
--
releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg platform
         reg@(RealRegSingle r)
        regs@(FreeRegs g f d)

        -- don't release pinned reg
        | not $ freeReg platform r
        = regs

        -- a general purpose reg
        | r <= 31
        = let   mask    = bitMask r
          in    FreeRegs (g .|. mask) f d

        -- a float reg
        | r >= 32, r <= 63
        = let   mask    = bitMask (r - 32)

                -- the mask of the double this FP reg aliases
                maskLow = if r `mod` 2 == 0
                                then bitMask (r - 32)
                                else bitMask (r - 32 - 1)
          in    FreeRegs
                        g
                        (f .|. mask)
                        (d .|. maskLow)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)

releaseReg _
         reg@(RealRegPair r1 r2)
             (FreeRegs g f d)

        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
        , r2 >= 32, r2 <= 63
        = let   mask1   = bitMask (r1 - 32)
                mask2   = bitMask (r2 - 32)
          in
                FreeRegs
                        g
                        ((f .|. mask1) .|. mask2)
                        (d .|. mask1)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)

bitMask :: Int -> Word32
bitMask n       = 1 `shiftL` n

showFreeRegs :: FreeRegs -> String
showFreeRegs regs
        =  "FreeRegs\n"
        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"
        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"
        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"


-- | Free regs map for i386
module RegAlloc.Linear.X86.FreeRegs
where

import GhcPrelude

import X86.Regs
import RegClass
import Reg
import Panic
import Platform

import Data.Word
import Data.Bits

newtype FreeRegs = FreeRegs Word32
    deriving Show

noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0

releaseReg :: RealReg -> FreeRegs -> FreeRegs
releaseReg (RealRegSingle n) (FreeRegs f)
        = FreeRegs (f .|. (1 `shiftL` n))

releaseReg _ _
        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"

initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)

getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
getFreeRegs platform cls (FreeRegs f) = go f 0

  where go 0 _ = []
        go n m
          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))

          | otherwise
          = go (n `shiftR` 1) $! (m+1)
        -- ToDo: there's no point looking through all the integer registers
        -- in order to find a floating-point one.

allocateReg :: RealReg -> FreeRegs -> FreeRegs
allocateReg (RealRegSingle r) (FreeRegs f)
        = FreeRegs (f .&. complement (1 `shiftL` r))

allocateReg _ _
        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"


-- | Free regs map for x86_64
module RegAlloc.Linear.X86_64.FreeRegs
where

import GhcPrelude

import X86.Regs
import RegClass
import Reg
import Panic
import Platform

import Data.Word
import Data.Bits

newtype FreeRegs = FreeRegs Word64
    deriving Show

noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0

releaseReg :: RealReg -> FreeRegs -> FreeRegs
releaseReg (RealRegSingle n) (FreeRegs f)
        = FreeRegs (f .|. (1 `shiftL` n))

releaseReg _ _
        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"

initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)

getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
getFreeRegs platform cls (FreeRegs f) = go f 0

  where go 0 _ = []
        go n m
          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))

          | otherwise
          = go (n `shiftR` 1) $! (m+1)
        -- ToDo: there's no point looking through all the integer registers
        -- in order to find a floating-point one.

allocateReg :: RealReg -> FreeRegs -> FreeRegs
allocateReg (RealRegSingle r) (FreeRegs f)
        = FreeRegs (f .&. complement (1 `shiftL` r))

allocateReg _ _
        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"


module SPARC.AddrMode (
        AddrMode(..),
        addrOffset
)

where

import GhcPrelude

import SPARC.Imm
import SPARC.Base
import Reg

-- addressing modes ------------------------------------------------------------

-- | Represents a memory address in an instruction.
--      Being a RISC machine, the SPARC addressing modes are very regular.
--
data AddrMode
        = AddrRegReg    Reg Reg         -- addr = r1 + r2
        | AddrRegImm    Reg Imm         -- addr = r1 + imm

-- | Add an integer offset to the address in an AddrMode.
--
addrOffset :: AddrMode -> Int -> Maybe AddrMode
addrOffset addr off
  = case addr of
      AddrRegImm r (ImmInt n)
       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))
       | otherwise     -> Nothing
       where n2 = n + off

      AddrRegImm r (ImmInteger n)
       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
       | otherwise     -> Nothing
       where n2 = n + toInteger off

      AddrRegReg r (RegReal (RealRegSingle 0))
       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))
       | otherwise     -> Nothing

      _ -> Nothing


-- | Bits and pieces on the bottom of the module dependency tree.
--      Also import the required constants, so we know what we're using.
--
--      In the interests of cross-compilation, we want to free ourselves
--      from the autoconf generated modules like main/Constants

module SPARC.Base (
        wordLength,
        wordLengthInBits,
        spillAreaLength,
        spillSlotSize,
        extraStackArgsHere,
        fits13Bits,
        is32BitInteger,
        largeOffsetError
)

where

import GhcPrelude

import DynFlags
import Panic

import Data.Int

-- On 32 bit SPARC, pointers are 32 bits.
wordLength :: Int
wordLength = 4

wordLengthInBits :: Int
wordLengthInBits
        = wordLength * 8

-- Size of the available spill area
spillAreaLength :: DynFlags -> Int
spillAreaLength
        = rESERVED_C_STACK_BYTES

-- | We need 8 bytes because our largest registers are 64 bit.
spillSlotSize :: Int
spillSlotSize = 8

-- | We (allegedly) put the first six C-call arguments in registers;
--      where do we start putting the rest of them?
extraStackArgsHere :: Int
extraStackArgsHere = 23

{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}
-- | Check whether an offset is representable with 13 bits.
fits13Bits :: Integral a => a -> Bool
fits13Bits x = x >= -4096 && x < 4096

-- | Check whether an integer will fit in 32 bits.
--      A CmmInt is intended to be truncated to the appropriate
--      number of bits, so here we truncate it to Int64.  This is
--      important because e.g. -1 as a CmmInt might be either
--      -1 or 18446744073709551615.
--
is32BitInteger :: Integer -> Bool
is32BitInteger i
        = i64 <= 0x7fffffff && i64 >= -0x80000000
        where i64 = fromIntegral i :: Int64

-- | Sadness.
largeOffsetError :: (Show a) => a -> b
largeOffsetError i
  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("
                ++ show i ++ ");\nprobably because of large constant data structures;" ++
                "\nworkaround: use -fllvm on this module.\n")


{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
--
-- Generating machine code (instruction selection)
--
-- (c) The University of Glasgow 1996-2013
--
-----------------------------------------------------------------------------

{-# LANGUAGE GADTs #-}
module SPARC.CodeGen (
        cmmTopCodeGen,
        generateJumpTableForInstr,
        InstrBlock
)

where

#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "../includes/MachDeps.h"

-- NCG stuff:
import GhcPrelude

import SPARC.Base
import SPARC.CodeGen.Sanity
import SPARC.CodeGen.Amode
import SPARC.CodeGen.CondCode
import SPARC.CodeGen.Gen64
import SPARC.CodeGen.Gen32
import SPARC.CodeGen.Base
import SPARC.Ppr        ()
import SPARC.Instr
import SPARC.Imm
import SPARC.AddrMode
import SPARC.Regs
import SPARC.Stack
import Instruction
import Format
import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat )

-- Our intermediate code:
import BlockId
import Cmm
import CmmUtils
import CmmSwitch
import Hoopl.Block
import Hoopl.Graph
import PIC
import Reg
import CLabel
import CPrim

-- The rest:
import BasicTypes
import DynFlags
import FastString
import OrdList
import Outputable
import Platform

import Control.Monad    ( mapAndUnzipM )

-- | Top level code generation
cmmTopCodeGen :: RawCmmDecl
              -> NatM [NatCmmDecl CmmStatics Instr]

cmmTopCodeGen (CmmProc info lab live graph)
 = do let blocks = toBlockListEntryFirst graph
      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks

      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
      let tops = proc : concat statics

      return tops

cmmTopCodeGen (CmmData sec dat) = do
  return [CmmData sec dat]  -- no translation, we just use CmmStatic

-- | Do code generation on a single block of CMM code.
--      code generation may introduce new basic block boundaries, which
--      are indicated by the NEWBLOCK instruction.  We must split up the
--      instruction stream into basic blocks again.  Also, we extract
--      LDATAs here too.
basicBlockCodeGen :: CmmBlock
                  -> NatM ( [NatBasicBlock Instr]
                          , [NatCmmDecl CmmStatics Instr])

basicBlockCodeGen block = do
  let (_, nodes, tail)  = blockSplit block
      id = entryLabel block
      stmts = blockToList nodes
  mid_instrs <- stmtsToInstrs stmts
  tail_instrs <- stmtToInstrs tail
  let instrs = mid_instrs `appOL` tail_instrs
  let
        (top,other_blocks,statics)
                = foldrOL mkBlocks ([],[],[]) instrs

        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
          = ([], BasicBlock id instrs : blocks, statics)

        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
          = (instrs, blocks, CmmData sec dat:statics)

        mkBlocks instr (instrs,blocks,statics)
          = (instr:instrs, blocks, statics)

        -- do intra-block sanity checking
        blocksChecked
                = map (checkBlock block)
                $ BasicBlock id top : other_blocks

  return (blocksChecked, statics)

-- | Convert some Cmm statements to SPARC instructions.
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts
   = do instrss <- mapM stmtToInstrs stmts
        return (concatOL instrss)

stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
  dflags <- getDynFlags
  case stmt of
    CmmComment s   -> return (unitOL (COMMENT s))
    CmmTick {}     -> return nilOL
    CmmUnwind {}   -> return nilOL

    CmmAssign reg src
      | isFloatType ty  -> assignReg_FltCode format reg src
      | isWord64 ty     -> assignReg_I64Code        reg src
      | otherwise       -> assignReg_IntCode format reg src
        where ty = cmmRegType dflags reg
              format = cmmTypeFormat ty

    CmmStore addr src
      | isFloatType ty  -> assignMem_FltCode format addr src
      | isWord64 ty     -> assignMem_I64Code      addr src
      | otherwise       -> assignMem_IntCode format addr src
        where ty = cmmExprType dflags src
              format = cmmTypeFormat ty

    CmmUnsafeForeignCall target result_regs args
       -> genCCall target result_regs args

    CmmBranch   id              -> genBranch id
    CmmCondBranch arg true false _ -> do
      b1 <- genCondJump true arg
      b2 <- genBranch false
      return (b1 `appOL` b2)
    CmmSwitch arg ids   -> do dflags <- getDynFlags
                              genSwitch dflags arg ids
    CmmCall { cml_target = arg } -> genJump arg

    _
     -> panic "stmtToInstrs: statement should have been cps'd away"

{-
Now, given a tree (the argument to a CmmLoad) that references memory,
produce a suitable addressing mode.

A Rule of the Game (tm) for Amodes: use of the addr bit must
immediately follow use of the code part, since the code part puts
values in registers which the addr then refers to.  So you can't put
anything in between, lest it overwrite some of those registers.  If
you need to do some other computation between the code part and use of
the addr bit, first store the effective address from the amode in a
temporary, then do the other computation, and then use the temporary:

    code
    LEA amode, tmp
    ... other computation ...
    ... (tmp) ...
-}

-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
    where blockLabel = blockLbl blockid

-- -----------------------------------------------------------------------------
-- Generating assignments

-- Assignments are really at the heart of the whole code generation
-- business.  Almost all top-level nodes of any real importance are
-- assignments, which correspond to loads, stores, or register
-- transfers.  If we're really lucky, some of the register transfers
-- will go away, because we can use the destination register to
-- complete the code generation for the right hand side.  This only
-- fails when the right hand side is forced into a fixed register
-- (e.g. the result of a call).

assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk addr src = do
    (srcReg, code) <- getSomeReg src
    Amode dstAddr addr_code <- getAmode addr
    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr

assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_IntCode _ reg src = do
    dflags <- getDynFlags
    r <- getRegister src
    let dst = getRegisterReg (targetPlatform dflags) reg
    return $ case r of
        Any _ code         -> code dst
        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst

-- Floating point assignment to memory
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode pk addr src = do
    dflags <- getDynFlags
    Amode dst__2 code1 <- getAmode addr
    (src__2, code2) <- getSomeReg src
    tmp1 <- getNewRegNat pk
    let
        pk__2   = cmmExprType dflags src
        code__2 = code1 `appOL` code2 `appOL`
            if   formatToWidth pk == typeWidth pk__2
            then unitOL (ST pk src__2 dst__2)
            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1
                        , ST    pk tmp1 dst__2]
    return code__2

-- Floating point assignment to a register/temporary
assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_FltCode pk dstCmmReg srcCmmExpr = do
    dflags <- getDynFlags
    let platform = targetPlatform dflags
    srcRegister <- getRegister srcCmmExpr
    let dstReg  = getRegisterReg platform dstCmmReg

    return $ case srcRegister of
        Any _ code                  -> code dstReg
        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg

genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock

genJump (CmmLit (CmmLabel lbl))
  = return (toOL [CALL (Left target) 0 True, NOP])
  where
    target = ImmCLbl lbl

genJump tree
  = do
        (target, code) <- getSomeReg tree
        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)

-- -----------------------------------------------------------------------------
--  Unconditional branches

genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr

-- -----------------------------------------------------------------------------
--  Conditional jumps

{-
Conditional jumps are always to local labels, so we can use branch
instructions.  We peek at the arguments to decide what kind of
comparison to do.

SPARC: First, we have to ensure that the condition codes are set
according to the supplied comparison operation.  We generate slightly
different code for floating point comparisons, because a floating
point operation cannot directly precede a @BF@.  We assume the worst
and fill that slot with a @NOP@.

SPARC: Do not fill the delay slots here; you will confuse the register
allocator.
-}

genCondJump
    :: BlockId      -- the branch target
    -> CmmExpr      -- the condition on which to branch
    -> NatM InstrBlock

genCondJump bid bool = do
  CondCode is_float cond code <- getCondCode bool
  return (
       code `appOL`
       toOL (
         if   is_float
         then [NOP, BF cond False bid, NOP]
         else [BI cond False bid, NOP]
       )
    )

-- -----------------------------------------------------------------------------
-- Generating a table-branch

genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
        | positionIndependent dflags
        = error "MachCodeGen: sparc genSwitch PIC not finished\n"

        | otherwise
        = do    (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)

                base_reg        <- getNewRegNat II32
                offset_reg      <- getNewRegNat II32
                dst             <- getNewRegNat II32

                label           <- getNewLabelNat

                return $ e_code `appOL`
                 toOL
                        [ -- load base of jump table
                          SETHI (HI (ImmCLbl label)) base_reg
                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg

                        -- the addrs in the table are 32 bits wide..
                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg

                        -- load and jump to the destination
                        , LD      II32 (AddrRegReg base_reg offset_reg) dst
                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
                        , NOP ]
  where (offset, ids) = switchTargetsToTable targets

generateJumpTableForInstr :: DynFlags -> Instr
                          -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr dflags (JMP_TBL _ ids label) =
  let jumpTable = map (jumpTableEntry dflags) ids
  in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable))
generateJumpTableForInstr _ _ = Nothing

-- -----------------------------------------------------------------------------
-- Generating C calls

{-
   Now the biggest nightmare---calls.  Most of the nastiness is buried in
   @get_arg@, which moves the arguments to the correct registers/stack
   locations.  Apart from that, the code is easy.

   The SPARC calling convention is an absolute
   nightmare.  The first 6x32 bits of arguments are mapped into
   %o0 through %o5, and the remaining arguments are dumped to the
   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)

   If we have to put args on the stack, move %o6==%sp down by
   the number of words to go on the stack, to ensure there's enough space.

   According to Fraser and Hanson's lcc book, page 478, fig 17.2,
   16 words above the stack pointer is a word for the address of
   a structure return value.  I use this as a temporary location
   for moving values from float to int regs.  Certainly it isn't
   safe to put anything in the 16 words starting at %sp, since
   this area can get trashed at any time due to window overflows
   caused by signal handlers.

   A final complication (if the above isn't enough) is that
   we can't blithely calculate the arguments one by one into
   %o0 .. %o5.  Consider the following nested calls:

       fff a (fff b c)

   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
   the inner call will itself use %o0, which trashes the value put there
   in preparation for the outer call.  Upshot: we need to calculate the
   args into temporary regs, and move those to arg regs or onto the
   stack only immediately prior to the call proper.  Sigh.
-}

genCCall
    :: ForeignTarget            -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> NatM InstrBlock

-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
-- are guaranteed to take place before writes afterwards (unlike on PowerPC).
-- Ref: Section 8.4 of the SPARC V9 Architecture manual.
--
-- In the SPARC case we don't need a barrier.
--
genCCall (PrimTarget MO_WriteBarrier) _ _
 = return $ nilOL

genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
 = return $ nilOL

genCCall target dest_regs args
 = do   -- work out the arguments, and assign them to integer regs
        argcode_and_vregs       <- mapM arg_to_int_vregs args
        let (argcodes, vregss)  = unzip argcode_and_vregs
        let vregs               = concat vregss

        let n_argRegs           = length allArgRegs
        let n_argRegs_used      = min (length vregs) n_argRegs

        -- deal with static vs dynamic call targets
        callinsns <- case target of
                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->
                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))

                ForeignTarget expr _
                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr
                        let dyn_r = case dyn_rs of
                                      [dyn_r'] -> dyn_r'
                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)

                PrimTarget mop
                 -> do  res     <- outOfLineMachOp mop
                        lblOrMopExpr <- case res of
                                Left lbl -> do
                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))

                                Right mopExpr -> do
                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
                                        let dyn_r = case dyn_rs of
                                                      [dyn_r'] -> dyn_r'
                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)

                        return lblOrMopExpr

        let argcode = concatOL argcodes

        let (move_sp_down, move_sp_up)
                   = let diff = length vregs - n_argRegs
                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
                     in  if   nn <= 0
                         then (nilOL, nilOL)
                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))

        let transfer_code
                = toOL (move_final vregs allArgRegs extraStackArgsHere)

        dflags <- getDynFlags
        return
         $      argcode                 `appOL`
                move_sp_down            `appOL`
                transfer_code           `appOL`
                callinsns               `appOL`
                unitOL NOP              `appOL`
                move_sp_up              `appOL`
                assign_code (targetPlatform dflags) dest_regs

-- | Generate code to calculate an argument, and move it into one
--      or two integer vregs.
arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
arg_to_int_vregs arg = do dflags <- getDynFlags
                          arg_to_int_vregs' dflags arg

arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])
arg_to_int_vregs' dflags arg

        -- If the expr produces a 64 bit int, then we can just use iselExpr64
        | isWord64 (cmmExprType dflags arg)
        = do    (ChildCode64 code r_lo) <- iselExpr64 arg
                let r_hi                = getHiVRegFromLo r_lo
                return (code, [r_hi, r_lo])

        | otherwise
        = do    (src, code)     <- getSomeReg arg
                let pk          = cmmExprType dflags arg

                case cmmTypeFormat pk of

                 -- Load a 64 bit float return value into two integer regs.
                 FF64 -> do
                        v1 <- getNewRegNat II32
                        v2 <- getNewRegNat II32

                        let code2 =
                                code                            `snocOL`
                                FMOV FF64 src f0                `snocOL`
                                ST   FF32  f0 (spRel 16)        `snocOL`
                                LD   II32  (spRel 16) v1        `snocOL`
                                ST   FF32  f1 (spRel 16)        `snocOL`
                                LD   II32  (spRel 16) v2

                        return  (code2, [v1,v2])

                 -- Load a 32 bit float return value into an integer reg
                 FF32 -> do
                        v1 <- getNewRegNat II32

                        let code2 =
                                code                            `snocOL`
                                ST   FF32  src (spRel 16)       `snocOL`
                                LD   II32  (spRel 16) v1

                        return (code2, [v1])

                 -- Move an integer return value into its destination reg.
                 _ -> do
                        v1 <- getNewRegNat II32

                        let code2 =
                                code                            `snocOL`
                                OR False g0 (RIReg src) v1

                        return (code2, [v1])

-- | Move args from the integer vregs into which they have been
--      marshalled, into %o0 .. %o5, and the rest onto the stack.
--
move_final :: [Reg] -> [Reg] -> Int -> [Instr]

-- all args done
move_final [] _ _
        = []

-- out of aregs; move to stack
move_final (v:vs) [] offset
        = ST II32 v (spRel offset)
        : move_final vs [] (offset+1)

-- move into an arg (%o[0..5]) reg
move_final (v:vs) (a:az) offset
        = OR False g0 (RIReg v) a
        : move_final vs az offset

-- | Assign results returned from the call into their
--      destination regs.
--
assign_code :: Platform -> [LocalReg] -> OrdList Instr

assign_code _ [] = nilOL

assign_code platform [dest]
 = let  rep     = localRegType dest
        width   = typeWidth rep
        r_dest  = getRegisterReg platform (CmmLocal dest)

        result
                | isFloatType rep
                , W32   <- width
                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest

                | isFloatType rep
                , W64   <- width
                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest

                | not $ isFloatType rep
                , W32   <- width
                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest

                | not $ isFloatType rep
                , W64           <- width
                , r_dest_hi     <- getHiVRegFromLo r_dest
                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi
                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]

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

   in   result

assign_code _ _
        = panic "SPARC.CodeGen.GenCCall: no match"

-- | Generate a call to implement an out-of-line floating point operation
outOfLineMachOp
        :: CallishMachOp
        -> NatM (Either CLabel CmmExpr)

outOfLineMachOp mop
 = do   let functionName
                = outOfLineMachOp_table mop

        dflags  <- getDynFlags
        mopExpr <- cmmMakeDynamicReference dflags CallReference
                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction

        let mopLabelOrExpr
                = case mopExpr of
                        CmmLit (CmmLabel lbl)   -> Left lbl
                        _                       -> Right mopExpr

        return mopLabelOrExpr

-- | Decide what C function to use to implement a CallishMachOp
--
outOfLineMachOp_table
        :: CallishMachOp
        -> FastString

outOfLineMachOp_table mop
 = case mop of
        MO_F32_Exp    -> fsLit "expf"
        MO_F32_Log    -> fsLit "logf"
        MO_F32_Sqrt   -> fsLit "sqrtf"
        MO_F32_Fabs   -> unsupported
        MO_F32_Pwr    -> fsLit "powf"

        MO_F32_Sin    -> fsLit "sinf"
        MO_F32_Cos    -> fsLit "cosf"
        MO_F32_Tan    -> fsLit "tanf"

        MO_F32_Asin   -> fsLit "asinf"
        MO_F32_Acos   -> fsLit "acosf"
        MO_F32_Atan   -> fsLit "atanf"

        MO_F32_Sinh   -> fsLit "sinhf"
        MO_F32_Cosh   -> fsLit "coshf"
        MO_F32_Tanh   -> fsLit "tanhf"

        MO_F32_Asinh  -> fsLit "asinhf"
        MO_F32_Acosh  -> fsLit "acoshf"
        MO_F32_Atanh  -> fsLit "atanhf"

        MO_F64_Exp    -> fsLit "exp"
        MO_F64_Log    -> fsLit "log"
        MO_F64_Sqrt   -> fsLit "sqrt"
        MO_F64_Fabs   -> unsupported
        MO_F64_Pwr    -> fsLit "pow"

        MO_F64_Sin    -> fsLit "sin"
        MO_F64_Cos    -> fsLit "cos"
        MO_F64_Tan    -> fsLit "tan"

        MO_F64_Asin   -> fsLit "asin"
        MO_F64_Acos   -> fsLit "acos"
        MO_F64_Atan   -> fsLit "atan"

        MO_F64_Sinh   -> fsLit "sinh"
        MO_F64_Cosh   -> fsLit "cosh"
        MO_F64_Tanh   -> fsLit "tanh"

        MO_F64_Asinh  -> fsLit "asinh"
        MO_F64_Acosh  -> fsLit "acosh"
        MO_F64_Atanh  -> fsLit "atanh"

        MO_UF_Conv w -> fsLit $ word2FloatLabel w

        MO_Memcpy _  -> fsLit "memcpy"
        MO_Memset _  -> fsLit "memset"
        MO_Memmove _ -> fsLit "memmove"
        MO_Memcmp _  -> fsLit "memcmp"

        MO_BSwap w   -> fsLit $ bSwapLabel w
        MO_PopCnt w  -> fsLit $ popCntLabel w
        MO_Pdep w    -> fsLit $ pdepLabel w
        MO_Pext w    -> fsLit $ pextLabel w
        MO_Clz w     -> fsLit $ clzLabel w
        MO_Ctz w     -> fsLit $ ctzLabel w
        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
        MO_AtomicRead w -> fsLit $ atomicReadLabel w
        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w

        MO_S_QuotRem {}  -> unsupported
        MO_U_QuotRem {}  -> unsupported
        MO_U_QuotRem2 {} -> unsupported
        MO_Add2 {}       -> unsupported
        MO_AddWordC {}   -> unsupported
        MO_SubWordC {}   -> unsupported
        MO_AddIntC {}    -> unsupported
        MO_SubIntC {}    -> unsupported
        MO_U_Mul2 {}     -> unsupported
        MO_WriteBarrier  -> unsupported
        MO_Touch         -> unsupported
        (MO_Prefetch_Data _) -> unsupported
    where unsupported = panic ("outOfLineCmmOp: " ++ show mop
                            ++ " not supported here")


module SPARC.Cond (
        Cond(..),
        condUnsigned,
        condToSigned,
        condToUnsigned
)

where

import GhcPrelude

-- | Branch condition codes.
data Cond
        = ALWAYS
        | EQQ
        | GE
        | GEU
        | GTT
        | GU
        | LE
        | LEU
        | LTT
        | LU
        | NE
        | NEG
        | NEVER
        | POS
        | VC
        | VS
        deriving Eq

condUnsigned :: Cond -> Bool
condUnsigned GU  = True
condUnsigned LU  = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _   = False

condToSigned :: Cond -> Cond
condToSigned GU  = GTT
condToSigned LU  = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x   = x

condToUnsigned :: Cond -> Cond
condToUnsigned GTT = GU
condToUnsigned LTT = LU
condToUnsigned GE  = GEU
condToUnsigned LE  = LEU
condToUnsigned x   = x


module SPARC.Imm (
        -- immediate values
        Imm(..),
        strImmLit,
        litToImm
)

where

import GhcPrelude

import Cmm
import CLabel

import Outputable

-- | An immediate value.
--      Not all of these are directly representable by the machine.
--      Things like ImmLit are slurped out and put in a data segment instead.
--
data Imm
        = ImmInt        Int

        -- Sigh.
        | ImmInteger    Integer

        -- AbstractC Label (with baggage)
        | ImmCLbl       CLabel

        -- Simple string
        | ImmLit        SDoc
        | ImmIndex      CLabel Int
        | ImmFloat      Rational
        | ImmDouble     Rational

        | ImmConstantSum  Imm Imm
        | ImmConstantDiff Imm Imm

        | LO    Imm
        | HI    Imm

-- | Create a ImmLit containing this string.
strImmLit :: String -> Imm
strImmLit s = ImmLit (text s)

-- | Convert a CmmLit to an Imm.
--      Narrow to the width: a CmmInt might be out of
--      range, but we assume that ImmInteger only contains
--      in-range values.  A signed value should be fine here.
--
litToImm :: CmmLit -> Imm
litToImm lit
 = case lit of
        CmmInt i w              -> ImmInteger (narrowS w i)
        CmmFloat f W32          -> ImmFloat f
        CmmFloat f W64          -> ImmDouble f
        CmmLabel l              -> ImmCLbl l
        CmmLabelOff l off       -> ImmIndex l off

        CmmLabelDiffOff l1 l2 off _
         -> ImmConstantSum
                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
                (ImmInt off)

        _               -> panic "SPARC.Regs.litToImm: no match"