{-# 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 "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 :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen (CmmProc info :: LabelMap CmmStatics
info lab :: CLabel
lab live :: [GlobalReg]
live graph :: CmmGraph
graph)
 = do let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
      (nat_blocks :: [[NatBasicBlock Instr]]
nat_blocks,statics :: [[NatCmmDecl CmmStatics Instr]]
statics) <- (CmmBlock
 -> NatM ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr]))
-> [CmmBlock]
-> NatM ([[NatBasicBlock Instr]], [[NatCmmDecl CmmStatics Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen [CmmBlock]
blocks

      let proc :: NatCmmDecl CmmStatics Instr
proc = LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl CmmStatics Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lab [GlobalReg]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
      let tops :: [NatCmmDecl CmmStatics Instr]
tops = NatCmmDecl CmmStatics Instr
proc NatCmmDecl CmmStatics Instr
-> [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl CmmStatics Instr]] -> [NatCmmDecl CmmStatics Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl CmmStatics Instr]]
statics

      [NatCmmDecl CmmStatics Instr] -> NatM [NatCmmDecl CmmStatics Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl CmmStatics Instr]
tops

cmmTopCodeGen (CmmData sec :: Section
sec dat :: CmmStatics
dat) = do
  [NatCmmDecl CmmStatics Instr] -> NatM [NatCmmDecl CmmStatics Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> CmmStatics -> NatCmmDecl CmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec CmmStatics
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 :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block :: CmmBlock
block = do
  let (_, nodes :: Block CmmNode O O
nodes, tail :: CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: Label
id = CmmBlock -> Label
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
  InstrBlock
mid_instrs <- [CmmNode O O] -> NatM InstrBlock
forall e x. [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs [CmmNode O O]
stmts
  InstrBlock
tail_instrs <- CmmNode O C -> NatM InstrBlock
forall e x. CmmNode e x -> NatM InstrBlock
stmtToInstrs CmmNode O C
tail
  let instrs :: InstrBlock
instrs = InstrBlock
mid_instrs InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
tail_instrs
  let
        (top :: [Instr]
top,other_blocks :: [NatBasicBlock Instr]
other_blocks,statics :: [NatCmmDecl CmmStatics Instr]
statics)
                = (Instr
 -> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
 -> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr]))
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
-> InstrBlock
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
mkBlocks ([],[],[]) InstrBlock
instrs

        mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
mkBlocks (NEWBLOCK id :: Label
id) (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl CmmStatics h g]
statics)
          = ([], Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl CmmStatics h g]
statics)

        mkBlocks (LDATA sec :: Section
sec dat :: CmmStatics
dat) (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl CmmStatics h g]
statics)
          = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section -> CmmStatics -> GenCmmDecl CmmStatics h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec CmmStatics
datGenCmmDecl CmmStatics h g
-> [GenCmmDecl CmmStatics h g] -> [GenCmmDecl CmmStatics h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl CmmStatics h g]
statics)

        mkBlocks instr :: Instr
instr (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl CmmStatics h g]
statics)
          = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl CmmStatics h g]
statics)

        -- do intra-block sanity checking
        blocksChecked :: [NatBasicBlock Instr]
blocksChecked
                = (NatBasicBlock Instr -> NatBasicBlock Instr)
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr
checkBlock CmmBlock
block)
                ([NatBasicBlock Instr] -> [NatBasicBlock Instr])
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a b. (a -> b) -> a -> b
$ Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
other_blocks

  ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
-> NatM ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatBasicBlock Instr]
blocksChecked, [NatCmmDecl CmmStatics Instr]
statics)


-- | Convert some Cmm statements to SPARC instructions.
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts :: [CmmNode e x]
stmts
   = do [InstrBlock]
instrss <- (CmmNode e x -> NatM InstrBlock)
-> [CmmNode e x] -> NatM [InstrBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmNode e x -> NatM InstrBlock
forall e x. CmmNode e x -> NatM InstrBlock
stmtToInstrs [CmmNode e x]
stmts
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstrBlock] -> InstrBlock
forall a. [OrdList a] -> OrdList a
concatOL [InstrBlock]
instrss)


stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt :: CmmNode e x
stmt = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  case CmmNode e x
stmt of
    CmmComment s :: FastString
s   -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
    CmmTick {}     -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
forall a. OrdList a
nilOL
    CmmUnwind {}   -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
forall a. OrdList a
nilOL

    CmmAssign reg :: CmmReg
reg src :: CmmExpr
src
      | CmmType -> Bool
isFloatType CmmType
ty  -> Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
      | CmmType -> Bool
isWord64 CmmType
ty     -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code        CmmReg
reg CmmExpr
src
      | Bool
otherwise       -> Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode Format
format CmmReg
reg CmmExpr
src
        where ty :: CmmType
ty = DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

    CmmStore addr :: CmmExpr
addr src :: CmmExpr
src
      | CmmType -> Bool
isFloatType CmmType
ty  -> Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
      | CmmType -> Bool
isWord64 CmmType
ty     -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code      CmmExpr
addr CmmExpr
src
      | Bool
otherwise       -> Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
        where ty :: CmmType
ty = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
src
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

    CmmUnsafeForeignCall target :: ForeignTarget
target result_regs :: [CmmFormal]
result_regs args :: [CmmExpr]
args
       -> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args

    CmmBranch   id :: Label
id              -> Label -> NatM InstrBlock
genBranch Label
id
    CmmCondBranch arg :: CmmExpr
arg true :: Label
true false :: Label
false _ -> do
      InstrBlock
b1 <- Label -> CmmExpr -> NatM InstrBlock
genCondJump Label
true CmmExpr
arg
      InstrBlock
b2 <- Label -> NatM InstrBlock
genBranch Label
false
      InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
b1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b2)
    CmmSwitch arg :: CmmExpr
arg ids :: SwitchTargets
ids   -> do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                              DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch DynFlags
dflags CmmExpr
arg SwitchTargets
ids
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg } -> CmmExpr -> NatM InstrBlock
genJump CmmExpr
arg

    _
     -> String -> NatM InstrBlock
forall a. String -> a
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 :: DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry dflags :: DynFlags
dflags Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
wordWidth DynFlags
dflags))
jumpTableEntry _ (Just blockid :: Label
blockid) = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel CLabel
blockLabel)
    where blockLabel :: CLabel
blockLabel = Label -> CLabel
blockLbl Label
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 :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk :: Format
pk addr :: CmmExpr
addr src :: CmmExpr
src = do
    (srcReg :: Reg
srcReg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
    Amode dstAddr :: AddrMode
dstAddr addr_code :: InstrBlock
addr_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
addr
    InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
pk Reg
srcReg AddrMode
dstAddr


assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode _ reg :: CmmReg
reg src :: CmmExpr
src = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
src
    let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg (DynFlags -> Platform
targetPlatform DynFlags
dflags) CmmReg
reg
    InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ case Register
r of
        Any _ code :: Reg -> InstrBlock
code         -> Reg -> InstrBlock
code Reg
dst
        Fixed _ freg :: Reg
freg fcode :: InstrBlock
fcode -> InstrBlock
fcode InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Reg -> RI
RIReg Reg
freg) Reg
dst



-- Floating point assignment to memory
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode pk :: Format
pk addr :: CmmExpr
addr src :: CmmExpr
src = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Amode dst__2 :: AddrMode
dst__2 code1 :: InstrBlock
code1 <- CmmExpr -> NatM Amode
getAmode CmmExpr
addr
    (src__2 :: Reg
src__2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
    Reg
tmp1 <- Format -> NatM Reg
getNewRegNat Format
pk
    let
        pk__2 :: CmmType
pk__2   = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
src
        code__2 :: InstrBlock
code__2 = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            if   Format -> Width
formatToWidth Format
pk Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== CmmType -> Width
typeWidth CmmType
pk__2
            then Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Format -> Reg -> AddrMode -> Instr
ST Format
pk Reg
src__2 AddrMode
dst__2)
            else [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL   [ Format -> Format -> Reg -> Reg -> Instr
FxTOy (CmmType -> Format
cmmTypeFormat CmmType
pk__2) Format
pk Reg
src__2 Reg
tmp1
                        , Format -> Reg -> AddrMode -> Instr
ST    Format
pk Reg
tmp1 AddrMode
dst__2]
    InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
code__2

-- Floating point assignment to a register/temporary
assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_FltCode pk :: Format
pk dstCmmReg :: CmmReg
dstCmmReg srcCmmExpr :: CmmExpr
srcCmmExpr = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    Register
srcRegister <- CmmExpr -> NatM Register
getRegister CmmExpr
srcCmmExpr
    let dstReg :: Reg
dstReg  = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
dstCmmReg

    InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ case Register
srcRegister of
        Any _ code :: Reg -> InstrBlock
code                  -> Reg -> InstrBlock
code Reg
dstReg
        Fixed _ srcFixedReg :: Reg
srcFixedReg srcCode :: InstrBlock
srcCode -> InstrBlock
srcCode InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
FMOV Format
pk Reg
srcFixedReg Reg
dstReg




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

genJump :: CmmExpr -> NatM InstrBlock
genJump (CmmLit (CmmLabel lbl :: CLabel
lbl))
  = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ([Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [Either Imm Reg -> Int -> Bool -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left Imm
target) 0 Bool
True, Instr
NOP])
  where
    target :: Imm
target = CLabel -> Imm
ImmCLbl CLabel
lbl

genJump tree :: CmmExpr
tree
  = do
        (target :: Reg
target, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
tree
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` AddrMode -> Instr
JMP (Reg -> Reg -> AddrMode
AddrRegReg Reg
target Reg
g0)  InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
NOP)

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

genBranch :: BlockId -> NatM InstrBlock
genBranch :: Label -> NatM InstrBlock
genBranch = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock)
-> (Label -> InstrBlock) -> Label -> NatM InstrBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL ([Instr] -> InstrBlock)
-> (Label -> [Instr]) -> Label -> InstrBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> [Instr]
forall instr. Instruction instr => Label -> [instr]
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 :: Label -> CmmExpr -> NatM InstrBlock
genCondJump bid :: Label
bid bool :: CmmExpr
bool = do
  CondCode is_float :: Bool
is_float cond :: Cond
cond code :: InstrBlock
code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
bool
  InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (
       InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
       [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL (
         if   Bool
is_float
         then [Instr
NOP, Cond -> Bool -> Label -> Instr
BF Cond
cond Bool
False Label
bid, Instr
NOP]
         else [Cond -> Bool -> Label -> Instr
BI Cond
cond Bool
False Label
bid, Instr
NOP]
       )
    )



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

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

        | Bool
otherwise
        = do    (e_reg :: Reg
e_reg, e_code :: InstrBlock
e_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
expr Int
offset)

                Reg
base_reg        <- Format -> NatM Reg
getNewRegNat Format
II32
                Reg
offset_reg      <- Format -> NatM Reg
getNewRegNat Format
II32
                Reg
dst             <- Format -> NatM Reg
getNewRegNat Format
II32

                CLabel
label           <- NatM CLabel
getNewLabelNat

                InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
e_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                 [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        [ -- load base of jump table
                          Imm -> Reg -> Instr
SETHI (Imm -> Imm
HI (CLabel -> Imm
ImmCLbl CLabel
label)) Reg
base_reg
                        , Bool -> Reg -> RI -> Reg -> Instr
OR    Bool
False Reg
base_reg (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Imm -> Imm
LO (Imm -> Imm) -> Imm -> Imm
forall a b. (a -> b) -> a -> b
$ CLabel -> Imm
ImmCLbl CLabel
label) Reg
base_reg

                        -- the addrs in the table are 32 bits wide..
                        , Reg -> RI -> Reg -> Instr
SLL   Reg
e_reg (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt 2) Reg
offset_reg

                        -- load and jump to the destination
                        , Format -> AddrMode -> Reg -> Instr
LD      Format
II32 (Reg -> Reg -> AddrMode
AddrRegReg Reg
base_reg Reg
offset_reg) Reg
dst
                        , AddrMode -> [Maybe Label] -> CLabel -> Instr
JMP_TBL (Reg -> Imm -> AddrMode
AddrRegImm Reg
dst (Int -> Imm
ImmInt 0)) [Maybe Label]
ids CLabel
label
                        , Instr
NOP ]
  where (offset :: Int
offset, ids :: [Maybe Label]
ids) = SwitchTargets -> (Int, [Maybe Label])
switchTargetsToTable SwitchTargets
targets

generateJumpTableForInstr :: DynFlags -> Instr
                          -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr dflags :: DynFlags
dflags (JMP_TBL _ ids :: [Maybe Label]
ids label :: CLabel
label) =
  let jumpTable :: [CmmStatic]
jumpTable = (Maybe Label -> CmmStatic) -> [Maybe Label] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry DynFlags
dflags) [Maybe Label]
ids
  in NatCmmDecl CmmStatics Instr -> Maybe (NatCmmDecl CmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> CmmStatics -> NatCmmDecl CmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
label) (CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
label [CmmStatic]
jumpTable))
generateJumpTableForInstr _ _ = Maybe (NatCmmDecl CmmStatics Instr)
forall a. Maybe a
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 :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
genCCall (PrimTarget MO_ReadBarrier) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
forall a. OrdList a
nilOL
genCCall (PrimTarget MO_WriteBarrier) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
forall a. OrdList a
nilOL

genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
forall a. OrdList a
nilOL

genCCall target :: ForeignTarget
target dest_regs :: [CmmFormal]
dest_regs args :: [CmmExpr]
args
 = do   -- work out the arguments, and assign them to integer regs
        [(InstrBlock, [Reg])]
argcode_and_vregs       <- (CmmExpr -> NatM (InstrBlock, [Reg]))
-> [CmmExpr] -> NatM [(InstrBlock, [Reg])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs [CmmExpr]
args
        let (argcodes :: [InstrBlock]
argcodes, vregss :: [[Reg]]
vregss)  = [(InstrBlock, [Reg])] -> ([InstrBlock], [[Reg]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(InstrBlock, [Reg])]
argcode_and_vregs
        let vregs :: [Reg]
vregs               = [[Reg]] -> [Reg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Reg]]
vregss

        let n_argRegs :: Int
n_argRegs           = [Reg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
allArgRegs
        let n_argRegs_used :: Int
n_argRegs_used      = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([Reg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
vregs) Int
n_argRegs


        -- deal with static vs dynamic call targets
        InstrBlock
callinsns <- case ForeignTarget
target of
                ForeignTarget (CmmLit (CmmLabel lbl :: CLabel
lbl)) _ ->
                        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Either Imm Reg -> Int -> Bool -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left (CmmLit -> Imm
litToImm (CLabel -> CmmLit
CmmLabel CLabel
lbl))) Int
n_argRegs_used Bool
False))

                ForeignTarget expr :: CmmExpr
expr _
                 -> do  (dyn_c :: InstrBlock
dyn_c, dyn_rs :: [Reg]
dyn_rs) <- CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs CmmExpr
expr
                        let dyn_r :: Reg
dyn_r = case [Reg]
dyn_rs of
                                      [dyn_r' :: Reg
dyn_r'] -> Reg
dyn_r'
                                      _ -> String -> Reg
forall a. String -> a
panic "SPARC.CodeGen.genCCall: arg_to_int"
                        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
dyn_c InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> Int -> Bool -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) Int
n_argRegs_used Bool
False)

                PrimTarget mop :: CallishMachOp
mop
                 -> do  Either CLabel CmmExpr
res     <- CallishMachOp -> NatM (Either CLabel CmmExpr)
outOfLineMachOp CallishMachOp
mop
                        InstrBlock
lblOrMopExpr <- case Either CLabel CmmExpr
res of
                                Left lbl :: CLabel
lbl -> do
                                        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Either Imm Reg -> Int -> Bool -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left (CmmLit -> Imm
litToImm (CLabel -> CmmLit
CmmLabel CLabel
lbl))) Int
n_argRegs_used Bool
False))

                                Right mopExpr :: CmmExpr
mopExpr -> do
                                        (dyn_c :: InstrBlock
dyn_c, dyn_rs :: [Reg]
dyn_rs) <- CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs CmmExpr
mopExpr
                                        let dyn_r :: Reg
dyn_r = case [Reg]
dyn_rs of
                                                      [dyn_r' :: Reg
dyn_r'] -> Reg
dyn_r'
                                                      _ -> String -> Reg
forall a. String -> a
panic "SPARC.CodeGen.genCCall: arg_to_int"
                                        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
dyn_c InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> Int -> Bool -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) Int
n_argRegs_used Bool
False)

                        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
lblOrMopExpr

        let argcode :: InstrBlock
argcode = [InstrBlock] -> InstrBlock
forall a. [OrdList a] -> OrdList a
concatOL [InstrBlock]
argcodes

        let (move_sp_down :: InstrBlock
move_sp_down, move_sp_up :: InstrBlock
move_sp_up)
                   = let diff :: Int
diff = [Reg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
vregs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_argRegs
                         nn :: Int
nn   = if Int -> Bool
forall a. Integral a => a -> Bool
odd Int
diff then Int
diff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 else Int
diff -- keep 8-byte alignment
                     in  if   Int
nn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
                         then (InstrBlock
forall a. OrdList a
nilOL, InstrBlock
forall a. OrdList a
nilOL)
                         else (Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Int -> Instr
moveSp (-1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nn)), Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Int -> Instr
moveSp (1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nn)))

        let transfer_code :: InstrBlock
transfer_code
                = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL ([Reg] -> [Reg] -> Int -> [Instr]
move_final [Reg]
vregs [Reg]
allArgRegs Int
extraStackArgsHere)

        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return
         (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$      InstrBlock
argcode                 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
move_sp_down            InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
transfer_code           InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
callinsns               InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
NOP              InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
move_sp_up              InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Platform -> [CmmFormal] -> InstrBlock
assign_code (DynFlags -> Platform
targetPlatform DynFlags
dflags) [CmmFormal]
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 :: CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs arg :: CmmExpr
arg = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                          DynFlags -> CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs' DynFlags
dflags CmmExpr
arg

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

        -- If the expr produces a 64 bit int, then we can just use iselExpr64
        | CmmType -> Bool
isWord64 (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
arg)
        = do    (ChildCode64 code :: InstrBlock
code r_lo :: Reg
r_lo) <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
arg
                let r_hi :: Reg
r_hi                = Reg -> Reg
getHiVRegFromLo Reg
r_lo
                (InstrBlock, [Reg]) -> NatM (InstrBlock, [Reg])
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code, [Reg
r_hi, Reg
r_lo])

        | Bool
otherwise
        = do    (src :: Reg
src, code :: InstrBlock
code)     <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg
                let pk :: CmmType
pk          = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
arg

                case CmmType -> Format
cmmTypeFormat CmmType
pk of

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

                        let code2 :: InstrBlock
code2 =
                                InstrBlock
code                            InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> Reg -> Reg -> Instr
FMOV Format
FF64 Reg
src Reg
f0                InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> Reg -> AddrMode -> Instr
ST   Format
FF32  Reg
f0 (Int -> AddrMode
spRel 16)        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel 16) Reg
v1        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> Reg -> AddrMode -> Instr
ST   Format
FF32  Reg
f1 (Int -> AddrMode
spRel 16)        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel 16) Reg
v2

                        (InstrBlock, [Reg]) -> NatM (InstrBlock, [Reg])
forall (m :: * -> *) a. Monad m => a -> m a
return  (InstrBlock
code2, [Reg
v1,Reg
v2])

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

                        let code2 :: InstrBlock
code2 =
                                InstrBlock
code                            InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> Reg -> AddrMode -> Instr
ST   Format
FF32  Reg
src (Int -> AddrMode
spRel 16)       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel 16) Reg
v1

                        (InstrBlock, [Reg]) -> NatM (InstrBlock, [Reg])
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code2, [Reg
v1])

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

                        let code2 :: InstrBlock
code2 =
                                InstrBlock
code                            InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Reg -> RI
RIReg Reg
src) Reg
v1

                        (InstrBlock, [Reg]) -> NatM (InstrBlock, [Reg])
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code2, [Reg
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 :: [Reg] -> [Reg] -> Int -> [Instr]
move_final [] _ _
        = []

-- out of aregs; move to stack
move_final (v :: Reg
v:vs :: [Reg]
vs) [] offset :: Int
offset
        = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
v (Int -> AddrMode
spRel Int
offset)
        Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Reg] -> [Reg] -> Int -> [Instr]
move_final [Reg]
vs [] (Int
offsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)

-- move into an arg (%o[0..5]) reg
move_final (v :: Reg
v:vs :: [Reg]
vs) (a :: Reg
a:az :: [Reg]
az) offset :: Int
offset
        = Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Reg -> RI
RIReg Reg
v) Reg
a
        Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Reg] -> [Reg] -> Int -> [Instr]
move_final [Reg]
vs [Reg]
az Int
offset


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

assign_code :: Platform -> [CmmFormal] -> InstrBlock
assign_code _ [] = InstrBlock
forall a. OrdList a
nilOL

assign_code platform :: Platform
platform [dest :: CmmFormal
dest]
 = let  rep :: CmmType
rep     = CmmFormal -> CmmType
localRegType CmmFormal
dest
        width :: Width
width   = CmmType -> Width
typeWidth CmmType
rep
        r_dest :: Reg
r_dest  = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)

        result :: InstrBlock
result
                | CmmType -> Bool
isFloatType CmmType
rep
                , Width
W32   <- Width
width
                = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
FMOV Format
FF32 (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
fReg 0) Reg
r_dest

                | CmmType -> Bool
isFloatType CmmType
rep
                , Width
W64   <- Width
width
                = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
FMOV Format
FF64 (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
fReg 0) Reg
r_dest

                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CmmType -> Bool
isFloatType CmmType
rep
                , Width
W32   <- Width
width
                = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Platform -> Reg -> Reg -> Instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg 0) Reg
r_dest

                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CmmType -> Bool
isFloatType CmmType
rep
                , Width
W64           <- Width
width
                , Reg
r_dest_hi     <- Reg -> Reg
getHiVRegFromLo Reg
r_dest
                = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL  [ Platform -> Reg -> Reg -> Instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg 0) Reg
r_dest_hi
                        , Platform -> Reg -> Reg -> Instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg 1) Reg
r_dest]

                | Bool
otherwise
                = String -> InstrBlock
forall a. String -> a
panic "SPARC.CodeGen.GenCCall: no match"

   in   InstrBlock
result

assign_code _ _
        = String -> InstrBlock
forall a. String -> a
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 :: CallishMachOp -> NatM (Either CLabel CmmExpr)
outOfLineMachOp mop :: CallishMachOp
mop
 = do   let functionName :: FastString
functionName
                = CallishMachOp -> FastString
outOfLineMachOp_table CallishMachOp
mop

        DynFlags
dflags  <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        CmmExpr
mopExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference
                (CLabel -> NatM CmmExpr) -> CLabel -> NatM CmmExpr
forall a b. (a -> b) -> a -> b
$  FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
functionName Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction

        let mopLabelOrExpr :: Either CLabel CmmExpr
mopLabelOrExpr
                = case CmmExpr
mopExpr of
                        CmmLit (CmmLabel lbl :: CLabel
lbl)   -> CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl
                        _                       -> CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
mopExpr

        Either CLabel CmmExpr -> NatM (Either CLabel CmmExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Either CLabel CmmExpr
mopLabelOrExpr


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

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

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

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

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

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

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

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

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

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

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

        MO_UF_Conv w :: Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
word2FloatLabel Width
w

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

        MO_BSwap w :: Width
w   -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
bSwapLabel Width
w
        MO_PopCnt w :: Width
w  -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
popCntLabel Width
w
        MO_Pdep w :: Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w
        MO_Pext w :: Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w
        MO_Clz w :: Width
w     -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
clzLabel Width
w
        MO_Ctz w :: Width
w     -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
ctzLabel Width
w
        MO_AtomicRMW w :: Width
w amop :: AtomicMachOp
amop -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> AtomicMachOp -> String
atomicRMWLabel Width
w AtomicMachOp
amop
        MO_Cmpxchg w :: Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
cmpxchgLabel Width
w
        MO_AtomicRead w :: Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicReadLabel Width
w
        MO_AtomicWrite w :: Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicWriteLabel Width
w

        MO_S_QuotRem {}  -> FastString
unsupported
        MO_U_QuotRem {}  -> FastString
unsupported
        MO_U_QuotRem2 {} -> FastString
unsupported
        MO_Add2 {}       -> FastString
unsupported
        MO_AddWordC {}   -> FastString
unsupported
        MO_SubWordC {}   -> FastString
unsupported
        MO_AddIntC {}    -> FastString
unsupported
        MO_SubIntC {}    -> FastString
unsupported
        MO_U_Mul2 {}     -> FastString
unsupported
        MO_ReadBarrier   -> FastString
unsupported
        MO_WriteBarrier  -> FastString
unsupported
        MO_Touch         -> FastString
unsupported
        (MO_Prefetch_Data _) -> FastString
unsupported
    where unsupported :: FastString
unsupported = String -> FastString
forall a. String -> a
panic ("outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not supported here")