{-# LANGUAGE CPP #-}

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

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

where

#include "HsVersions.h"

-- NCG stuff:
import GHC.Prelude

import GHC.CmmToAsm.SPARC.Base
import GHC.CmmToAsm.SPARC.CodeGen.Sanity
import GHC.CmmToAsm.SPARC.CodeGen.Amode
import GHC.CmmToAsm.SPARC.CodeGen.CondCode
import GHC.CmmToAsm.SPARC.CodeGen.Gen64
import GHC.CmmToAsm.SPARC.CodeGen.Gen32
import GHC.CmmToAsm.SPARC.CodeGen.Base
import GHC.CmmToAsm.SPARC.Instr
import GHC.CmmToAsm.SPARC.Imm
import GHC.CmmToAsm.SPARC.AddrMode
import GHC.CmmToAsm.SPARC.Regs
import GHC.CmmToAsm.SPARC.Stack
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig )
import GHC.CmmToAsm.Config

-- Our intermediate code:
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.CmmToAsm.PIC
import GHC.Platform.Reg
import GHC.Cmm.CLabel
import GHC.CmmToAsm.CPrim

-- The rest:
import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Utils.Panic
import GHC.Platform

import Control.Monad    ( mapAndUnzipM )

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

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

      let proc :: NatCmmDecl RawCmmStatics Instr
proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl RawCmmStatics Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
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 RawCmmStatics Instr]
tops = NatCmmDecl RawCmmStatics Instr
proc NatCmmDecl RawCmmStatics Instr
-> [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl RawCmmStatics Instr]]
-> [NatCmmDecl RawCmmStatics Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl RawCmmStatics Instr]]
statics

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

cmmTopCodeGen (CmmData Section
sec RawCmmStatics
dat) =
  [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
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 RawCmmStatics Instr])

basicBlockCodeGen :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen CmmBlock
block = do
  let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: Label
id = CmmBlock -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
  Platform
platform <- NatM Platform
getPlatform
  InstrBlock
mid_instrs <- [CmmNode O O] -> NatM InstrBlock
forall (e :: Extensibility) (x :: Extensibility).
[CmmNode e x] -> NatM InstrBlock
stmtsToInstrs [CmmNode O O]
stmts
  InstrBlock
tail_instrs <- CmmNode O C -> NatM InstrBlock
forall (e :: Extensibility) (x :: Extensibility).
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
        ([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl RawCmmStatics Instr]
statics)
                = (Instr
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr])
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr]))
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> InstrBlock
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall {h} {g}.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks ([],[],[]) InstrBlock
instrs

        mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks (NEWBLOCK Label
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics 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 RawCmmStatics h g]
statics)

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

        mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics 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 (Platform -> CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr
checkBlock Platform
platform 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 RawCmmStatics Instr])
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatBasicBlock Instr]
blocksChecked, [NatCmmDecl RawCmmStatics Instr]
statics)


-- | Convert some Cmm statements to SPARC instructions.
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
[CmmNode e x] -> NatM InstrBlock
stmtsToInstrs [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 :: Extensibility) (x :: Extensibility).
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 :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM InstrBlock
stmtToInstrs CmmNode e x
stmt = do
  Platform
platform <- NatM Platform
getPlatform
  NCGConfig
config <- NatM NCGConfig
getConfig
  case CmmNode e x
stmt of
    CmmComment 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 CmmReg
reg 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 = Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

    CmmStore CmmExpr
addr 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 = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

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

    CmmBranch   Label
id              -> Label -> NatM InstrBlock
genBranch Label
id
    CmmCondBranch CmmExpr
arg Label
true Label
false Maybe Bool
_ -> 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 CmmExpr
arg SwitchTargets
ids   -> NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch NCGConfig
config CmmExpr
arg SwitchTargets
ids
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg } -> CmmExpr -> NatM InstrBlock
genJump CmmExpr
arg

    CmmNode e x
_
     -> String -> NatM InstrBlock
forall a. String -> a
panic String
"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 :: Platform -> Maybe BlockId -> CmmStatic
jumpTableEntry :: Platform -> Maybe Label -> CmmStatic
jumpTableEntry Platform
platform Maybe Label
Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (Platform -> Width
wordWidth Platform
platform))
jumpTableEntry Platform
_ (Just 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 Format
pk CmmExpr
addr CmmExpr
src = do
    (Reg
srcReg, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
    Amode AddrMode
dstAddr 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 Format
_ CmmReg
reg CmmExpr
src = do
    Platform
platform <- NatM Platform
getPlatform
    Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
src
    let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform 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 Format
_ Reg -> InstrBlock
code         -> Reg -> InstrBlock
code Reg
dst
        Fixed Format
_ Reg
freg 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 Format
pk CmmExpr
addr CmmExpr
src = do
    Platform
platform <- NatM Platform
getPlatform
    Amode AddrMode
dst__2 InstrBlock
code1 <- CmmExpr -> NatM Amode
getAmode CmmExpr
addr
    (Reg
src__2, InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
    Reg
tmp1 <- Format -> NatM Reg
getNewRegNat Format
pk
    let
        pk__2 :: CmmType
pk__2   = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform 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 Format
pk CmmReg
dstCmmReg CmmExpr
srcCmmExpr = do
    Platform
platform <- NatM Platform
getPlatform
    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 Format
_ Reg -> InstrBlock
code                  -> Reg -> InstrBlock
code Reg
dstReg
        Fixed Format
_ Reg
srcFixedReg 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 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) Int
0 Bool
True, Instr
NOP])
  where
    target :: Imm
target = CLabel -> Imm
ImmCLbl CLabel
lbl

genJump CmmExpr
tree
  = do
        (Reg
target, 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]
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 Label
bid CmmExpr
bool = do
  CondCode Bool
is_float Cond
cond 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 :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch NCGConfig
config CmmExpr
expr SwitchTargets
targets
        | NCGConfig -> Bool
ncgPIC NCGConfig
config
        = String -> NatM InstrBlock
forall a. HasCallStack => String -> a
error String
"MachCodeGen: sparc genSwitch PIC not finished\n"

        | Bool
otherwise
        = do    (Reg
e_reg, InstrBlock
e_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset (NCGConfig -> Platform
ncgPlatform NCGConfig
config) 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 Int
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 Int
0)) [Maybe Label]
ids CLabel
label
                        , Instr
NOP ]
  where (Int
offset, [Maybe Label]
ids) = SwitchTargets -> (Int, [Maybe Label])
switchTargetsToTable SwitchTargets
targets

generateJumpTableForInstr :: Platform -> Instr
                          -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: Platform -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr Platform
platform (JMP_TBL AddrMode
_ [Maybe Label]
ids CLabel
label) =
  let jumpTable :: [CmmStatic]
jumpTable = (Maybe Label -> CmmStatic) -> [Maybe Label] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Maybe Label -> CmmStatic
jumpTableEntry Platform
platform) [Maybe Label]
ids
  in NatCmmDecl RawCmmStatics Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
label) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (a :: Bool). CLabel -> [CmmStatic] -> GenCmmStatics a
CmmStaticsRaw CLabel
label [CmmStatic]
jumpTable))
generateJumpTableForInstr Platform
_ Instr
_ = Maybe (NatCmmDecl RawCmmStatics 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 CallishMachOp
MO_ReadBarrier) [CmmFormal]
_ [CmmExpr]
_
 = 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 CallishMachOp
MO_WriteBarrier) [CmmFormal]
_ [CmmExpr]
_
 = 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 Int
_)) [CmmFormal]
_ [CmmExpr]
_
 = 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 ForeignTarget
target [CmmFormal]
dest_regs [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 ([InstrBlock]
argcodes, [[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 CLabel
lbl)) ForeignConvention
_ ->
                        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 CmmExpr
expr ForeignConvention
_
                 -> do  (InstrBlock
dyn_c, [Reg]
dyn_rs) <- CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs CmmExpr
expr
                        let dyn_r :: Reg
dyn_r = case [Reg]
dyn_rs of
                                      [Reg
dyn_r'] -> Reg
dyn_r'
                                      [Reg]
_ -> String -> Reg
forall a. String -> a
panic String
"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 CallishMachOp
mop
                 -> do  Either CLabel CmmExpr
res     <- CallishMachOp -> NatM (Either CLabel CmmExpr)
outOfLineMachOp CallishMachOp
mop
                        case Either CLabel CmmExpr
res of
                                Left 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))

                                Right CmmExpr
mopExpr -> do
                                        (InstrBlock
dyn_c, [Reg]
dyn_rs) <- CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs CmmExpr
mopExpr
                                        let dyn_r :: Reg
dyn_r = case [Reg]
dyn_rs of
                                                      [Reg
dyn_r'] -> Reg
dyn_r'
                                                      [Reg]
_ -> String -> Reg
forall a. String -> a
panic String
"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)

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

        let (InstrBlock
move_sp_down, 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
+ Int
1 else Int
diff -- keep 8-byte alignment
                     in  if   Int
nn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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 (-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nn)), Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Int -> Instr
moveSp (Int
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)

        Platform
platform <- NatM Platform
getPlatform
        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 Platform
platform [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 CmmExpr
arg = do Platform
platform <- NatM Platform
getPlatform
                          Platform -> CmmExpr -> NatM (InstrBlock, [Reg])
arg_to_int_vregs' Platform
platform CmmExpr
arg

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

        -- If the expr produces a 64 bit int, then we can just use iselExpr64
        | CmmType -> Bool
isWord64 (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
arg)
        = do    (ChildCode64 InstrBlock
code 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    (Reg
src, InstrBlock
code)     <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg
                let pk :: CmmType
pk          = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
arg

                case CmmType -> Format
cmmTypeFormat CmmType
pk of

                 -- Load a 64 bit float return value into two integer regs.
                 Format
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 Int
16)        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel Int
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 Int
16)        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel Int
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
                 Format
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 Int
16)       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                Format -> AddrMode -> Reg -> Instr
LD   Format
II32  (Int -> AddrMode
spRel Int
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.
                 Format
_ -> 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 [] [Reg]
_ Int
_
        = []

-- out of aregs; move to stack
move_final (Reg
v:[Reg]
vs) [] 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
+Int
1)

-- move into an arg (%o[0..5]) reg
move_final (Reg
v:[Reg]
vs) (Reg
a:[Reg]
az) 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 Platform
_ [] = InstrBlock
forall a. OrdList a
nilOL

assign_code Platform
platform [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 Int
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 Int
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
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg Int
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
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg Int
0) Reg
r_dest_hi
                        , Platform -> Reg -> Reg -> Instr
mkRegRegMoveInstr Platform
platform (Int -> Reg
regSingle (Int -> Reg) -> Int -> Reg
forall a b. (a -> b) -> a -> b
$ Int -> Int
oReg Int
1) Reg
r_dest]

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

   in   InstrBlock
result

assign_code Platform
_ [CmmFormal]
_
        = String -> InstrBlock
forall a. String -> a
panic String
"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 CallishMachOp
mop
 = do   let functionName :: FastString
functionName
                = CallishMachOp -> FastString
outOfLineMachOp_table CallishMachOp
mop

        NCGConfig
config  <- NatM NCGConfig
getConfig
        CmmExpr
mopExpr <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config 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 CLabel
lbl)   -> CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl
                        CmmExpr
_                       -> 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 CallishMachOp
mop
 = case CallishMachOp
mop of
        CallishMachOp
MO_F32_Exp    -> String -> FastString
fsLit String
"expf"
        CallishMachOp
MO_F32_ExpM1  -> String -> FastString
fsLit String
"expm1f"
        CallishMachOp
MO_F32_Log    -> String -> FastString
fsLit String
"logf"
        CallishMachOp
MO_F32_Log1P  -> String -> FastString
fsLit String
"log1pf"
        CallishMachOp
MO_F32_Sqrt   -> String -> FastString
fsLit String
"sqrtf"
        CallishMachOp
MO_F32_Fabs   -> FastString
unsupported
        CallishMachOp
MO_F32_Pwr    -> String -> FastString
fsLit String
"powf"

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

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

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

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

        CallishMachOp
MO_F64_Exp    -> String -> FastString
fsLit String
"exp"
        CallishMachOp
MO_F64_ExpM1  -> String -> FastString
fsLit String
"expm1"
        CallishMachOp
MO_F64_Log    -> String -> FastString
fsLit String
"log"
        CallishMachOp
MO_F64_Log1P  -> String -> FastString
fsLit String
"log1p"
        CallishMachOp
MO_F64_Sqrt   -> String -> FastString
fsLit String
"sqrt"
        CallishMachOp
MO_F64_Fabs   -> FastString
unsupported
        CallishMachOp
MO_F64_Pwr    -> String -> FastString
fsLit String
"pow"

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

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

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

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

        CallishMachOp
MO_I64_ToI   -> String -> FastString
fsLit String
"hs_int64ToInt"
        CallishMachOp
MO_I64_FromI -> String -> FastString
fsLit String
"hs_intToInt64"
        CallishMachOp
MO_W64_ToW   -> String -> FastString
fsLit String
"hs_word64ToWord"
        CallishMachOp
MO_W64_FromW -> String -> FastString
fsLit String
"hs_wordToWord64"
        CallishMachOp
MO_x64_Neg   -> String -> FastString
fsLit String
"hs_neg64"
        CallishMachOp
MO_x64_Add   -> String -> FastString
fsLit String
"hs_add64"
        CallishMachOp
MO_x64_Sub   -> String -> FastString
fsLit String
"hs_sub64"
        CallishMachOp
MO_x64_Mul   -> String -> FastString
fsLit String
"hs_mul64"
        CallishMachOp
MO_I64_Quot  -> String -> FastString
fsLit String
"hs_quotInt64"
        CallishMachOp
MO_I64_Rem   -> String -> FastString
fsLit String
"hs_remInt64"
        CallishMachOp
MO_W64_Quot  -> String -> FastString
fsLit String
"hs_quotWord64"
        CallishMachOp
MO_W64_Rem   -> String -> FastString
fsLit String
"hs_remWord64"
        CallishMachOp
MO_x64_And   -> String -> FastString
fsLit String
"hs_and64"
        CallishMachOp
MO_x64_Or    -> String -> FastString
fsLit String
"hs_or64"
        CallishMachOp
MO_x64_Xor   -> String -> FastString
fsLit String
"hs_xor64"
        CallishMachOp
MO_x64_Not   -> String -> FastString
fsLit String
"hs_not64"
        CallishMachOp
MO_x64_Shl   -> String -> FastString
fsLit String
"hs_uncheckedShiftL64"
        CallishMachOp
MO_I64_Shr   -> String -> FastString
fsLit String
"hs_uncheckedIShiftRA64"
        CallishMachOp
MO_W64_Shr   -> String -> FastString
fsLit String
"hs_uncheckedShiftRL64"
        CallishMachOp
MO_x64_Eq    -> String -> FastString
fsLit String
"hs_eq64"
        CallishMachOp
MO_x64_Ne    -> String -> FastString
fsLit String
"hs_ne64"
        CallishMachOp
MO_I64_Ge    -> String -> FastString
fsLit String
"hs_geInt64"
        CallishMachOp
MO_I64_Gt    -> String -> FastString
fsLit String
"hs_gtInt64"
        CallishMachOp
MO_I64_Le    -> String -> FastString
fsLit String
"hs_leInt64"
        CallishMachOp
MO_I64_Lt    -> String -> FastString
fsLit String
"hs_ltInt64"
        CallishMachOp
MO_W64_Ge    -> String -> FastString
fsLit String
"hs_geWord64"
        CallishMachOp
MO_W64_Gt    -> String -> FastString
fsLit String
"hs_gtWord64"
        CallishMachOp
MO_W64_Le    -> String -> FastString
fsLit String
"hs_leWord64"
        CallishMachOp
MO_W64_Lt    -> String -> FastString
fsLit String
"hs_ltWord64"

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

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

        MO_BSwap Width
w   -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
bSwapLabel Width
w
        MO_BRev Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
bRevLabel Width
w
        MO_PopCnt Width
w  -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
popCntLabel Width
w
        MO_Pdep Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w
        MO_Pext Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w
        MO_Clz Width
w     -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
clzLabel Width
w
        MO_Ctz Width
w     -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
ctzLabel Width
w
        MO_AtomicRMW Width
w 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 Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
cmpxchgLabel Width
w
        MO_Xchg Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
xchgLabel Width
w
        MO_AtomicRead Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicReadLabel Width
w
        MO_AtomicWrite Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicWriteLabel Width
w

        MO_S_Mul2    {}  -> FastString
unsupported
        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
        CallishMachOp
MO_ReadBarrier   -> FastString
unsupported
        CallishMachOp
MO_WriteBarrier  -> FastString
unsupported
        CallishMachOp
MO_Touch         -> FastString
unsupported
        (MO_Prefetch_Data Int
_) -> FastString
unsupported
    where unsupported :: FastString
unsupported = String -> FastString
forall a. String -> a
panic (String
"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]
++ String
" not supported here")