module SPARC.CodeGen (
cmmTopCodeGen,
InstrBlock
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "../includes/MachDeps.h"
import SPARC.CodeGen.Sanity
import SPARC.CodeGen.Amode
import SPARC.CodeGen.CondCode
import SPARC.CodeGen.Gen64
import SPARC.CodeGen.Gen32
import SPARC.CodeGen.CCall
import SPARC.CodeGen.Base
import SPARC.Ppr ()
import SPARC.Instr
import SPARC.Imm
import SPARC.AddrMode
import SPARC.Regs
import Instruction
import Size
import NCGMonad
import BlockId
import Cmm
import CLabel
import StaticFlags ( opt_PIC )
import OrdList
import Outputable
import Control.Monad ( mapAndUnzipM )
import DynFlags
cmmTopCodeGen
:: DynFlags
-> RawCmmTop
-> NatM [NatCmmTop Instr]
cmmTopCodeGen _
(CmmProc info lab params (ListGraph blocks))
= do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
let tops = proc : concat statics
return tops
cmmTopCodeGen _ (CmmData sec dat) = do
return [CmmData sec dat]
basicBlockCodeGen
:: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmTop Instr])
basicBlockCodeGen cmm@(BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
let
(top,other_blocks,statics)
= foldrOL mkBlocks ([],[],[]) instrs
mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
= ([], BasicBlock id instrs : blocks, statics)
mkBlocks (LDATA sec dat) (instrs,blocks,statics)
= (instrs, blocks, CmmData sec dat:statics)
mkBlocks instr (instrs,blocks,statics)
= (instr:instrs, blocks, statics)
blocksChecked
= map (checkBlock cmm)
$ BasicBlock id top : other_blocks
return (blocksChecked, statics)
stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
stmtsToInstrs stmts
= do instrss <- mapM stmtToInstrs stmts
return (concatOL instrss)
stmtToInstrs :: CmmStmt -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
CmmNop -> return nilOL
CmmComment s -> return (unitOL (COMMENT s))
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode size reg src
| isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode size reg src
where ty = cmmRegType reg
size = cmmTypeSize ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode size addr src
| isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode size addr src
where ty = cmmExprType src
size = cmmTypeSize ty
CmmCall target result_regs args _ _
-> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
CmmSwitch arg ids -> genSwitch arg ids
CmmJump arg _ -> genJump arg
CmmReturn _
-> panic "stmtToInstrs: return statement should have been cps'd away"
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = mkAsmTempLabel id
assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk addr src = do
(srcReg, code) <- getSomeReg src
Amode dstAddr addr_code <- getAmode addr
return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode _ reg src = do
r <- getRegister src
return $ case r of
Any _ code -> code dst
Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
where
dst = getRegisterReg reg
assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode pk addr src = do
Amode dst__2 code1 <- getAmode addr
(src__2, code2) <- getSomeReg src
tmp1 <- getNewRegNat pk
let
pk__2 = cmmExprType src
code__2 = code1 `appOL` code2 `appOL`
if sizeToWidth pk == typeWidth pk__2
then unitOL (ST pk src__2 dst__2)
else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1
, ST pk tmp1 dst__2]
return code__2
assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_FltCode pk dstCmmReg srcCmmExpr = do
srcRegister <- getRegister srcCmmExpr
let dstReg = getRegisterReg dstCmmReg
return $ case srcRegister of
Any _ code -> code dstReg
Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
genJump :: CmmExpr -> NatM InstrBlock
genJump (CmmLit (CmmLabel lbl))
= return (toOL [CALL (Left target) 0 True, NOP])
where
target = ImmCLbl lbl
genJump tree
= do
(target, code) <- getSomeReg tree
return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> NatM InstrBlock
genCondJump bid bool = do
CondCode is_float cond code <- getCondCode bool
return (
code `appOL`
toOL (
if is_float
then [NOP, BF cond False bid, NOP]
else [BI cond False bid, NOP]
)
)
genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
genSwitch expr ids
| opt_PIC
= error "MachCodeGen: sparc genSwitch PIC not finished\n"
| otherwise
= do (e_reg, e_code) <- getSomeReg expr
base_reg <- getNewRegNat II32
offset_reg <- getNewRegNat II32
dst <- getNewRegNat II32
label <- getNewLabelNat
let jumpTable = map jumpTableEntry ids
return $ e_code `appOL`
toOL
[ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
, SETHI (HI (ImmCLbl label)) base_reg
, OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
, SLL e_reg (RIImm $ ImmInt 2) offset_reg
, LD II32 (AddrRegReg base_reg offset_reg) dst
, JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
, NOP ]